File: /nfs/home/0/users/jenkins/mfix.git/model/dmp_modules/mpi_utility_mod.f

1     !       MPI Modules written at ORNL by Ed and Sreekanth for MFIX
2     !       under joint effort with FETC - 06/08/99.
3     
4             module mpi_utility
5     
6     !       module to perform most of the mpi functionalities like scatter,
7     !       gather, bcast, globalsum and so on.
8     
9             use geometry
10             use compar
11             use parallel_mpi
12             use debug
13             use indices
14             implicit none
15     
16     !       Object-oriented approach to direct to the correct procedure
17     !       depending on the argument type. i stands for integer, r for real
18     !       and d for double precision. 0 for scalar, 1 for vector, 2 for
19     !       2-D array and similarly 3.
20     
21     !==============================================================================
22     !  JFD: Interfaces used for vtk file writting (Cartesian grid):
23     !==============================================================================
24     
25             interface allgather
26             module  procedure allgather_1i
27             end interface
28     
29             interface gatherv
30             module  procedure gatherv_1d
31             end interface
32     
33     !==============================================================================
34     !  JFD: End of Interfaces used for vtk file writting (Cartesian grid):
35     !==============================================================================
36     
37             interface scatter
38             module  procedure scatter_1i, scatter_2i, scatter_3i, &
39                               scatter_1r, scatter_2r, scatter_3r, &
40                               scatter_1d, scatter_2d, scatter_3d, &
41                               scatter_1c,scatter_1l
42             end interface
43     
44             interface gather
45             module  procedure gather_1i, gather_2i, gather_3i, &
46                               gather_1r, gather_2r, gather_3r, &
47                               gather_1d, gather_2d, gather_3d, &
48                               gather_1c, gather_1l
49             end interface
50     
51             interface bcast
52             module  procedure bcast_0i, bcast_1i, bcast_2i, bcast_3i, &
53                               bcast_0r, bcast_1r, bcast_2r, bcast_3r, &
54                               bcast_0d, bcast_1d, bcast_2d, bcast_3d, &
55                               bcast_0l, bcast_1l, bcast_0c, bcast_1c
56             end interface
57     
58             interface global_sum
59             module  procedure global_sum_0i, global_sum_1i, global_sum_2i, global_sum_3i, &
60                               global_sum_0r, global_sum_1r, global_sum_2r, global_sum_3r, &
61                               global_sum_0d, global_sum_1d, global_sum_2d, global_sum_3d
62             end interface
63     
64             interface global_all_sum
65             module  procedure &
66                               global_all_sum_0i, global_all_sum_1i, &
67                               global_all_sum_2i, global_all_sum_3i, &
68                               global_all_sum_0r, global_all_sum_1r, &
69                               global_all_sum_2r, global_all_sum_3r, &
70                               global_all_sum_0d, global_all_sum_1d, &
71                               global_all_sum_2d, global_all_sum_3d, &
72                               global_all_sum_onevar_0i, global_all_sum_onevar_1i, &
73                               global_all_sum_onevar_2i, global_all_sum_onevar_3i, &
74                               global_all_sum_onevar_0r, global_all_sum_onevar_1r, &
75                               global_all_sum_onevar_2r, global_all_sum_onevar_3r, &
76                               global_all_sum_onevar_0d, global_all_sum_onevar_1d, &
77                               global_all_sum_onevar_2d, global_all_sum_onevar_3d
78             end interface
79     
80             interface global_min
81             module  procedure global_min_0i, global_min_1i, global_min_2i, global_min_3i, &
82                               global_min_0r, global_min_1r, global_min_2r, global_min_3r, &
83                               global_min_0d, global_min_1d, global_min_2d, global_min_3d
84             end interface
85     
86             interface global_all_min
87             module  procedure &
88                               global_all_min_0i, global_all_min_1i, &
89                               global_all_min_2i, global_all_min_3i, &
90                               global_all_min_0r, global_all_min_1r, &
91                               global_all_min_2r, global_all_min_3r, &
92                               global_all_min_0d, global_all_min_1d, &
93                               global_all_min_2d, global_all_min_3d, &
94                               global_all_min_onevar_0i, global_all_min_onevar_1i, &
95                               global_all_min_onevar_2i, global_all_min_onevar_3i, &
96                               global_all_min_onevar_0r, global_all_min_onevar_1r, &
97                               global_all_min_onevar_2r, global_all_min_onevar_3r, &
98                               global_all_min_onevar_0d, global_all_min_onevar_1d, &
99                               global_all_min_onevar_2d, global_all_min_onevar_3d
100             end interface
101     
102             interface global_max
103             module  procedure global_max_0i, global_max_1i, global_max_2i, global_max_3i, &
104                               global_max_0r, global_max_1r, global_max_2r, global_max_3r, &
105                               global_max_0d, global_max_1d, global_max_2d, global_max_3d
106             end interface
107     
108             interface global_all_max
109             module  procedure &
110                               global_all_max_0i, global_all_max_1i, &
111                               global_all_max_2i, global_all_max_3i, &
112                               global_all_max_0r, global_all_max_1r, &
113                               global_all_max_2r, global_all_max_3r, &
114                               global_all_max_0d, global_all_max_1d, &
115                               global_all_max_2d, global_all_max_3d, &
116                               global_all_max_onevar_0i, global_all_max_onevar_1i, &
117                               global_all_max_onevar_2i, global_all_max_onevar_3i, &
118                               global_all_max_onevar_0r, global_all_max_onevar_1r, &
119                               global_all_max_onevar_2r, global_all_max_onevar_3r, &
120                               global_all_max_onevar_0d, global_all_max_onevar_1d, &
121                               global_all_max_onevar_2d, global_all_max_onevar_3d
122             end interface
123     
124             interface global_all_and
125             module procedure &
126                     global_all_and_0d, global_all_and_1d, &
127                     global_all_and_onevar_0d, global_all_and_onevar_1d
128             end interface
129     
130             interface global_all_or
131             module procedure &
132                     global_all_or_0d, global_all_or_1d, &
133                     global_all_or_onevar_0d, global_all_or_onevar_1d
134             end interface
135     
136             contains
137     
138     
139     !==============================================================================
140     !  JFD: Subroutines used for vtk file writting (Cartesian grid):
141     !==============================================================================
142     
143             subroutine allgather_1i( lbuf, gbuf, idebug )
144             integer, intent(in) :: lbuf
145             integer, intent(out), dimension(:) :: gbuf
146             integer, optional, intent(in) ::  idebug
147             integer :: sendtype,recvtype,sendcnt,recvcnt,ierr,lidebug,mpierr
148     
149             if (.not. present(idebug)) then
150                lidebug = 0
151             else
152                lidebug = idebug
153             endif
154     
155             recvtype = MPI_INTEGER
156             sendtype = recvtype
157     
158             sendcnt = 1
159             recvcnt = sendcnt
160     
161             CALL MPI_ALLGATHER(lbuf,sendcnt,sendtype,  &
162                                gbuf,recvcnt,recvtype,MPI_COMM_WORLD, IERR)
163     
164             return
165             end subroutine allgather_1i
166     
167             subroutine allgather_1d( lbuf, gbuf, idebug )
168             double precision, intent(in) :: lbuf
169             double precision, intent(out), dimension(:) :: gbuf
170             integer, optional, intent(in) ::  idebug
171             integer :: sendtype,recvtype,sendcnt,recvcnt,ierr,lidebug,mpierr
172     
173             if (.not. present(idebug)) then
174                lidebug = 0
175             else
176                lidebug = idebug
177             endif
178     
179             recvtype = MPI_DOUBLE_PRECISION
180             sendtype = MPI_DOUBLE_PRECISION
181     
182             sendcnt = 1
183             recvcnt = sendcnt
184     
185             CALL MPI_ALLGATHER(lbuf,sendcnt,sendtype,  &
186                                gbuf,recvcnt,recvtype,MPI_COMM_WORLD, IERR)
187     
188             return
189             end subroutine allgather_1d
190     
191             subroutine gatherv_1i( lbuf, sendcnt, gbuf, rcount, disp, mroot, idebug )
192             integer, intent(in), dimension(:) :: lbuf
193             integer, intent(in), dimension(:) :: rcount
194             integer, intent(in), dimension(:) :: disp
195             integer, intent(out), dimension(:) :: gbuf
196             integer, optional, intent(in) :: mroot, idebug
197             integer :: sendtype,recvtype,sendcnt,recvcnt,lroot,ierr,lidebug
198     
199     !       check to see whether there is root
200     
201             if (.not. present(mroot)) then
202                lroot = 0
203             else
204                lroot = mroot
205             endif
206     
207             if (.not. present(idebug)) then
208                lidebug = 0
209             else
210                lidebug = idebug
211             endif
212     
213             recvtype = MPI_INTEGER
214             sendtype = MPI_INTEGER
215     
216             CALL MPI_GATHERV(lbuf,sendcnt,sendtype,  &
217                              gbuf,rcount,disp,recvtype, &
218                              lroot,MPI_COMM_WORLD, IERR)
219     
220             return
221             end subroutine gatherv_1i
222     
223             subroutine gatherv_1d( lbuf, sendcnt, gbuf, rcount, disp, mroot, idebug )
224             double precision, intent(in), dimension(:) :: lbuf
225             integer, intent(in), dimension(:) :: rcount
226             integer, intent(in), dimension(:) :: disp
227             double precision, intent(out), dimension(:) :: gbuf
228             integer, optional, intent(in) :: mroot, idebug
229             integer :: sendtype,recvtype,sendcnt,recvcnt,lroot,ierr,lidebug
230     
231     !       check to see whether there is root
232     
233             if (.not. present(mroot)) then
234                lroot = 0
235             else
236                lroot = mroot
237             endif
238     
239             if (.not. present(idebug)) then
240                lidebug = 0
241             else
242                lidebug = idebug
243             endif
244     
245             recvtype = MPI_DOUBLE_PRECISION
246             sendtype = MPI_DOUBLE_PRECISION
247     
248             CALL MPI_GATHERV(lbuf,sendcnt,sendtype,  &
249                              gbuf,rcount,disp,recvtype, &
250                              lroot,MPI_COMM_WORLD, IERR)
251     
252             return
253             end subroutine gatherv_1d
254     
255     !==============================================================================
256     !  JFD: End of Subroutines used for vtk file writting (Cartesian grid):
257     !==============================================================================
258     
259     
260     !       Routine to scatter gbuf available on root to all the processors
261     
262             subroutine scatter_1i( lbuf, gbuf, mroot, idebug )
263     
264             use functions
265     
266             implicit none
267     
268             integer, intent(in), dimension(:) :: gbuf
269             integer, intent(out), dimension(:) :: lbuf
270             integer, optional, intent(in) :: mroot, idebug
271     
272             integer, allocatable, dimension(:) :: gbuf_pack
273     
274             integer :: sendtype, recvtype, ijk1, ijk2, recvcnt, ierr,lroot, lidebug
275             integer :: i,j,k,ibuffer,iproc, ioffset
276             integer :: ijk
277     
278     !       check to see whether there is root
279     
280             if (.not. present(mroot)) then
281                lroot = 0
282             else
283                lroot = mroot
284             endif
285     
286             if (.not. present(idebug)) then
287                lidebug = 0
288             else
289                lidebug = idebug
290             endif
291     
292             if(myPE.eq.lroot) then
293             allocate(gbuf_pack(sum(ijksize3_all(:))))
294             else
295             allocate(gbuf_pack(10))
296             endif
297     
298             if( myPE.eq.lroot) then
299             ioffset = 0
300               do iproc = 0,numPEs-1
301                 ibuffer = 0
302                 do k = kstart3_all(iproc), kend3_all(iproc)
303                   do j = jstart3_all(iproc), jend3_all(iproc)
304                     do i = istart3_all(iproc), iend3_all(iproc)
305     
306                       ibuffer = funijk_proc(i,j,k,iproc) + ioffset
307                       gbuf_pack(ibuffer) = gbuf(funijk_gl(i,j,k))
308     
309                     enddo
310                   enddo
311                 enddo
312                 ioffset = ibuffer
313               enddo
314             endif
315     
316             sendtype = MPI_INTEGER
317             recvtype = sendtype
318     
319             ijk1 = ijkstart3
320             ijk2 = ijkend3
321     
322             recvcnt = ijk2-ijk1+1
323     
324     !       Call MPI routines
325     
326             call MPI_Scatterv( gbuf_pack, ijksize3_all, displs, sendtype, &
327                               lbuf, recvcnt, recvtype,  &
328                               lroot, MPI_COMM_WORLD, ierr )
329             call MPI_Check( 'scatter_1i:MPI_Scatterv', ierr )
330     
331             deallocate(gbuf_pack)
332     
333             return
334             end subroutine scatter_1i
335     
336             subroutine scatter_2i( lbuf, gbuf, mroot, idebug )
337             integer, intent(in), dimension(:,:) :: gbuf
338             integer, intent(out), dimension(:,:) :: lbuf
339             integer, optional, intent(in) :: mroot, idebug
340     
341             integer :: i,j,lroot, lidebug
342     
343             if (.not. present(mroot)) then
344                lroot = 0
345             else
346                lroot = mroot
347             endif
348     
349             if (.not. present(idebug)) then
350                lidebug = 0
351             else
352                lidebug = idebug
353             endif
354     
355             if(myPE.eq.lroot) then
356             call assert( size(lbuf,2).eq.size(gbuf,2),  &
357                     '** scatter_2i: size(lbuf,2).ne.size(gbuf,2) ', &
358                     size(lbuf,2), size(gbuf,2) )
359             endif
360     
361             do j=lbound(lbuf,2),ubound(lbuf,2)
362               call scatter_1i( lbuf(:,j), gbuf(:,j), lroot, lidebug )
363             enddo
364     
365             return
366             end subroutine scatter_2i
367     
368             subroutine scatter_3i( lbuf, gbuf, mroot, idebug )
369             integer, intent(in), dimension(:,:,:) :: gbuf
370             integer, intent(out), dimension(:,:,:) :: lbuf
371             integer, optional, intent(in) :: mroot, idebug
372     
373             integer :: j,k,lroot, lidebug
374     
375             if (.not. present(mroot)) then
376                lroot = 0
377             else
378                lroot = mroot
379             endif
380     
381             if (.not. present(idebug)) then
382                lidebug = 0
383             else
384                lidebug = idebug
385             endif
386     
387             if(myPE.eq.lroot) then
388             call assert( size(lbuf,2).eq.size(gbuf,2),  &
389                     '** scatter_3i: size(lbuf,2).ne.size(gbuf,2) ', &
390                     size(lbuf,2), size(gbuf,2) )
391     
392             call assert( size(lbuf,3).eq.size(gbuf,3),  &
393                     '** scatter_3i: size(lbuf,3).ne.size(gbuf,3) ', &
394                     size(lbuf,3), size(gbuf,3) )
395             endif
396     
397             do k=lbound(lbuf,3),ubound(lbuf,3)
398             do j=lbound(lbuf,2),ubound(lbuf,2)
399               call scatter_1i( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
400             enddo
401             enddo
402     
403             return
404             end subroutine scatter_3i
405     
406             subroutine scatter_1r( lbuf, gbuf, mroot, idebug )
407     
408             use functions
409     
410             implicit none
411     
412             real, intent(in), dimension(:) :: gbuf
413             real, intent(out), dimension(:) :: lbuf
414             integer, optional, intent(in) :: mroot, idebug
415     
416             real, allocatable, dimension(:) :: gbuf_pack
417     
418             integer :: sendtype, recvtype, ijk1, ijk2, recvcnt, ierr,lroot, lidebug
419             integer :: i,j,k,ibuffer,iproc, ioffset
420             integer :: ijk
421     
422             if (.not. present(mroot)) then
423                lroot = 0
424             else
425                lroot = mroot
426             endif
427     
428             if (.not. present(idebug)) then
429                lidebug = 0
430             else
431                lidebug = idebug
432             endif
433     
434             if(myPE.eq.lroot) then
435             allocate(gbuf_pack(sum(ijksize3_all(:))))
436             else
437             allocate(gbuf_pack(10))
438             endif
439     
440             if( myPE.eq.lroot) then
441             ioffset = 0
442               do iproc = 0,numPEs-1
443                 ibuffer = 0
444                 do k = kstart3_all(iproc), kend3_all(iproc)
445                   do j = jstart3_all(iproc), jend3_all(iproc)
446                     do i = istart3_all(iproc), iend3_all(iproc)
447     
448                       ibuffer = funijk_proc(i,j,k,iproc) + ioffset
449                       gbuf_pack(ibuffer) = gbuf(funijk_gl(i,j,k))
450     
451                     enddo
452                   enddo
453                 enddo
454                 ioffset = ibuffer
455               enddo
456             endif
457     
458             sendtype = MPI_REAL
459             recvtype = sendtype
460     
461             ijk1 = ijkstart3
462             ijk2 = ijkend3
463     
464             recvcnt = ijk2-ijk1+1
465     
466             call MPI_Scatterv( gbuf_pack, ijksize3_all, displs, sendtype, &
467                               lbuf, recvcnt, recvtype,  &
468                               lroot, MPI_COMM_WORLD, ierr )
469             call MPI_Check( 'scatter_1r:MPI_Scatterv', ierr )
470     
471             deallocate(gbuf_pack)
472     
473             return
474             end subroutine scatter_1r
475     
476     
477             subroutine scatter_2r( lbuf, gbuf, mroot, idebug )
478             real, intent(in), dimension(:,:) :: gbuf
479             real, intent(out), dimension(:,:) :: lbuf
480             integer, optional, intent(in) :: mroot, idebug
481     
482             integer :: i,j,lroot, lidebug
483     
484             if (.not. present(mroot)) then
485                lroot = 0
486             else
487                lroot = mroot
488             endif
489     
490             if (.not. present(idebug)) then
491                lidebug = 0
492             else
493                lidebug = idebug
494             endif
495     
496             if(myPE.eq.lroot) then
497             call assert( size(lbuf,2).eq.size(gbuf,2),  &
498                     '** scatter_2r: size(lbuf,2).ne.size(gbuf,2) ', &
499                     size(lbuf,2), size(gbuf,2) )
500             endif
501     
502             do j=lbound(lbuf,2),ubound(lbuf,2)
503               call scatter_1r( lbuf(:,j), gbuf(:,j), lroot, lidebug )
504             enddo
505     
506             return
507             end subroutine scatter_2r
508     
509             subroutine scatter_3r( lbuf, gbuf, mroot, idebug )
510             real, intent(in), dimension(:,:,:) :: gbuf
511             real, intent(out), dimension(:,:,:) :: lbuf
512             integer, optional, intent(in) :: mroot, idebug
513     
514             integer :: j,k,lroot, lidebug
515     
516             if (.not. present(mroot)) then
517                lroot = 0
518             else
519                lroot = mroot
520             endif
521     
522             if (.not. present(idebug)) then
523                lidebug = 0
524             else
525                lidebug = idebug
526             endif
527     
528             if(myPE.eq.lroot) then
529             call assert( size(lbuf,2).eq.size(gbuf,2),  &
530                     '** scatter_3r: size(lbuf,2).ne.size(gbuf,2) ', &
531                     size(lbuf,2), size(gbuf,2) )
532     
533             call assert( size(lbuf,3).eq.size(gbuf,3),  &
534                     '** scatter_3r: size(lbuf,3).ne.size(gbuf,3) ', &
535                     size(lbuf,3), size(gbuf,3) )
536             endif
537     
538             do k=lbound(lbuf,3),ubound(lbuf,3)
539             do j=lbound(lbuf,2),ubound(lbuf,2)
540               call scatter_1r( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
541             enddo
542             enddo
543     
544             return
545             end subroutine scatter_3r
546     
547     
548             subroutine scatter_1d( lbuf, gbuf, mroot, idebug )
549     
550             use functions
551             implicit none
552     
553             double precision, intent(in), dimension(:) :: gbuf
554             double precision, intent(out), dimension(:) :: lbuf
555             integer, optional, intent(in) :: mroot, idebug
556     
557             double precision, allocatable, dimension(:) :: gbuf_pack
558     
559             integer :: sendtype, recvtype, ijk1,ijk2,recvcnt, ierr,lroot, lidebug
560             integer :: i,j,k,ibuffer,iproc, ioffset
561             integer :: ijk
562     
563             if (.not. present(mroot)) then
564                lroot = 0
565             else
566                lroot = mroot
567             endif
568     
569             if (.not. present(idebug)) then
570                lidebug = 0
571             else
572                lidebug = idebug
573             endif
574     
575             if(myPE.eq.lroot) then
576             allocate(gbuf_pack(sum(ijksize3_all(:))))
577             else
578             allocate(gbuf_pack(10))
579             endif
580     
581             if( myPE.eq.lroot) then
582             ioffset = 0
583               do iproc = 0,numPEs-1
584                 ibuffer = 0
585                 do k = kstart3_all(iproc), kend3_all(iproc)
586                   do j = jstart3_all(iproc), jend3_all(iproc)
587                     do i = istart3_all(iproc), iend3_all(iproc)
588     
589                       ibuffer = funijk_proc(i,j,k,iproc) + ioffset
590                       gbuf_pack(ibuffer) = gbuf(funijk_gl(i,j,k))
591     
592                     enddo
593                   enddo
594                 enddo
595                 ioffset = ibuffer
596               enddo
597             endif
598     
599             sendtype = MPI_DOUBLE_PRECISION
600             recvtype = sendtype
601     
602             ijk1 = ijkstart3
603             ijk2 = ijkend3
604     
605             recvcnt = ijk2-ijk1+1
606     
607             call MPI_Scatterv( gbuf_pack, ijksize3_all, displs, sendtype, &
608                               lbuf, recvcnt, recvtype,  &
609                               lroot, MPI_COMM_WORLD, ierr )
610             call MPI_Check( 'scatter_1d:MPI_Scatterv', ierr )
611     
612             deallocate(gbuf_pack)
613     
614             return
615             end subroutine scatter_1d
616     
617     
618             subroutine scatter_2d( lbuf, gbuf, mroot, idebug )
619             double precision, intent(in), dimension(:,:) :: gbuf
620             double precision, intent(out), dimension(:,:) :: lbuf
621             integer, optional, intent(in) :: mroot, idebug
622     
623             integer :: i,j,lroot, lidebug
624     
625             if (.not. present(mroot)) then
626                lroot = 0
627             else
628                lroot = mroot
629             endif
630     
631             if (.not. present(idebug)) then
632                lidebug = 0
633             else
634                lidebug = idebug
635             endif
636     
637             if(myPE.eq.lroot) then
638             call assert( size(lbuf,2).eq.size(gbuf,2),  &
639                     '** scatter_2d: size(lbuf,2).ne.size(gbuf,2) ', &
640                     size(lbuf,2), size(gbuf,2) )
641             endif
642     
643             do j=lbound(lbuf,2),ubound(lbuf,2)
644               call scatter_1d( lbuf(:,j), gbuf(:,j), lroot, lidebug )
645             enddo
646     
647             return
648             end subroutine scatter_2d
649     
650             subroutine scatter_3d( lbuf, gbuf, mroot, idebug )
651             double precision, intent(in), dimension(:,:,:) :: gbuf
652             double precision, intent(out), dimension(:,:,:) :: lbuf
653             integer, optional, intent(in) :: mroot, idebug
654     
655             integer :: j,k,lroot, lidebug
656     
657             if (.not. present(mroot)) then
658                lroot = 0
659             else
660                lroot = mroot
661             endif
662     
663             if (.not. present(idebug)) then
664                lidebug = 0
665             else
666                lidebug = idebug
667             endif
668     
669             if(myPE.eq.lroot) then
670             call assert( size(lbuf,2).eq.size(gbuf,2),  &
671                     '** scatter_3d: size(lbuf,2).ne.size(gbuf,2) ', &
672                     size(lbuf,2), size(gbuf,2) )
673     
674             call assert( size(lbuf,3).eq.size(gbuf,3),  &
675                     '** scatter_3d: size(lbuf,3).ne.size(gbuf,3) ', &
676                     size(lbuf,3), size(gbuf,3) )
677             endif
678     
679             do k=lbound(lbuf,3),ubound(lbuf,3)
680             do j=lbound(lbuf,2),ubound(lbuf,2)
681               call scatter_1d( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
682             enddo
683             enddo
684     
685             return
686             end subroutine scatter_3d
687     
688     
689             subroutine scatter_1c( lbuf, gbuf, mroot, idebug )
690     
691             use functions
692             implicit none
693     
694             character(len=*), intent(in), dimension(:) :: gbuf
695             character(len=*), intent(out), dimension(:) :: lbuf
696             integer, optional, intent(in) :: mroot, idebug
697     
698             integer, allocatable, dimension(:,:) :: gbuf_pack,lbuf1
699             character(len=80) :: string
700     
701             integer :: sendtype, recvtype, ijk1, ijk2, recvcnt, ierr,lroot, lidebug
702             integer :: i,j,k,ibuffer,iproc, ioffset
703             integer :: ijk
704             integer :: lenchar, icount
705     
706     !       check to see whether there is root
707     
708             if (.not. present(mroot)) then
709                lroot = 0
710             else
711                lroot = mroot
712             endif
713     
714             if (.not. present(idebug)) then
715                lidebug = 0
716             else
717                lidebug = idebug
718             endif
719     
720             ijk1 = ijkstart3
721             ijk2 = ijkend3
722     
723             lenchar = len(gbuf(1))
724     
725             if(myPE.eq.lroot) then
726               allocate(gbuf_pack(ijkmax3,lenchar))
727             else
728               allocate(gbuf_pack(10,lenchar))
729             endif
730     
731             allocate(lbuf1(ijk1:ijk2,lenchar))
732     
733             if(myPE.eq.lroot) then
734             do i = 1,ijkmax3
735               do j = 1,lenchar
736     
737                 string = gbuf(i)(1:lenchar)
738                 gbuf_pack(i,j) = ichar(string(j:j))
739     
740               enddo
741             enddo
742             endif
743     
744             call scatter_2i(lbuf1,gbuf_pack)
745     
746             do i = ijk1, ijk2
747               do j = 1,lenchar
748     
749                 lbuf(i)(j:j) = char(lbuf1(i,j))
750     
751               enddo
752             enddo
753     
754             deallocate(gbuf_pack)
755             deallocate(lbuf1)
756     
757             return
758             end subroutine scatter_1c
759     
760     
761             subroutine scatter_1l( lbuf, gbuf, mroot, idebug )
762     
763             use functions
764             implicit none
765     
766             logical, intent(in), dimension(:) :: gbuf
767             logical, intent(out), dimension(:) :: lbuf
768             integer, optional, intent(in) :: mroot, idebug
769     
770             logical, allocatable, dimension(:) :: gbuf_pack
771     
772             integer :: sendtype, recvtype, ijk1, ijk2, recvcnt, ierr,lroot, lidebug
773             integer :: i,j,k,ibuffer,iproc, ioffset
774             integer :: ijk
775     
776     !       check to see whether there is root
777     
778             if (.not. present(mroot)) then
779                lroot = 0
780             else
781                lroot = mroot
782             endif
783     
784             if (.not. present(idebug)) then
785                lidebug = 0
786             else
787                lidebug = idebug
788             endif
789     
790             if(myPE.eq.lroot) then
791             allocate(gbuf_pack(sum(ijksize3_all(:))))
792             else
793             allocate(gbuf_pack(10))
794             endif
795     
796             if( myPE.eq.lroot) then
797             ioffset = 0
798               do iproc = 0,numPEs-1
799                 ibuffer = 0
800                 do k = kstart3_all(iproc), kend3_all(iproc)
801                   do j = jstart3_all(iproc), jend3_all(iproc)
802                     do i = istart3_all(iproc), iend3_all(iproc)
803     
804                       ibuffer = funijk_proc(i,j,k,iproc) + ioffset
805                       gbuf_pack(ibuffer) = gbuf(funijk_gl(i,j,k))
806     
807                     enddo
808                   enddo
809                 enddo
810                 ioffset = ibuffer
811               enddo
812             endif
813     
814             sendtype = MPI_LOGICAL
815             recvtype = sendtype
816     
817             ijk1 = ijkstart3
818             ijk2 = ijkend3
819     
820             recvcnt = ijk2-ijk1+1
821     
822     !       Call MPI routines
823     
824             call MPI_Scatterv( gbuf_pack, ijksize3_all, displs, sendtype, &
825                               lbuf, recvcnt, recvtype,  &
826                               lroot, MPI_COMM_WORLD, ierr )
827             call MPI_Check( 'scatter_1l:MPI_Scatterv', ierr )
828     
829             deallocate(gbuf_pack)
830     
831             return
832             end subroutine scatter_1l
833     
834     
835     !       Routines to gather lbuf from individual processors and put it on
836     !       processor root in gbuf
837     !       Logic is similar to the scatter routines above.
838     
839             subroutine gather_1i( lbuf, gbuf, mroot, idebug )
840     
841             use functions
842             implicit none
843     
844             integer, intent(in), dimension(:) :: lbuf
845             integer, intent(out), dimension(:) :: gbuf
846             integer, optional, intent(in) :: mroot, idebug
847     
848             integer, allocatable, dimension(:) :: gbuf_pack
849     
850             integer :: recvtype, sendtype, ijk1,ijk2,sendcnt, ierr,lroot, lidebug
851             integer :: i,j,k,ibuffer,iproc, ioffset
852             integer :: ijk, ijk_gl
853             integer :: istartl, iendl, jstartl, jendl, kstartl, kendl
854             logical :: isok_k,isok_j,isok_i, isinterior
855             logical :: isbc_k,isbc_j,isbc_i, isboundary, need_copy
856     
857     !       check to see whether there is root
858     
859             if (.not. present(mroot)) then
860                lroot = 0
861             else
862                lroot = mroot
863             endif
864     
865             if (.not. present(idebug)) then
866                lidebug = 0
867             else
868                lidebug = idebug
869             endif
870     
871             if(myPE.eq.lroot) then
872               allocate(gbuf_pack(sum(ijksize3_all(:))))
873             else
874               allocate(gbuf_pack(10))
875             endif
876     
877             recvtype = MPI_INTEGER
878             sendtype = recvtype
879     
880             ijk1 = ijkstart3
881     !        ijk2 = ijkend3
882             ijk2 = max(ijkend3,BACKGROUND_IJKEND3)   !  For cell re-indexing
883     
884             sendcnt = ijk2-ijk1+1
885     
886             call MPI_Gatherv( lbuf, sendcnt, sendtype,  &
887                                gbuf_pack, ijksize3_all, displs, recvtype, &
888                               lroot, MPI_COMM_WORLD, ierr )
889             call MPI_Check( 'gather_1i:MPI_Gatherv', ierr )
890     
891             if( myPE.eq.lroot) then
892             ioffset = 0
893               do iproc = 0,numPEs-1
894                 ibuffer = 0
895                 istartl = istart1_all(iproc)
896                 iendl = iend1_all(iproc)
897                 jstartl = jstart1_all(iproc)
898                 jendl = jend1_all(iproc)
899                 kstartl = kstart1_all(iproc)
900                 kendl = kend1_all(iproc)
901     
902                 if(istart3_all(iproc).eq.imin3) istartl = istart3_all(iproc)
903                 if(iend3_all(iproc).eq.imax3) iendl = iend3_all(iproc)
904                 if(jstart3_all(iproc).eq.jmin3) jstartl = jstart3_all(iproc)
905                 if(jend3_all(iproc).eq.jmax3) jendl = jend3_all(iproc)
906                 if(kstart3_all(iproc).eq.kmin3) kstartl = kstart3_all(iproc)
907                 if(kend3_all(iproc).eq.kmax3) kendl = kend3_all(iproc)
908     
909                 do k = kstart3_all(iproc), kend3_all(iproc)
910                   do j = jstart3_all(iproc), jend3_all(iproc)
911                     do i = istart3_all(iproc), iend3_all(iproc)
912     
913                       ibuffer = funijk_proc(i,j,k,iproc) + ioffset
914                       isok_k = (kstartl <= k) .and. (k <=kendl)
915                       isok_j = (jstartl <= j) .and. (j <=jendl)
916                       isok_i = (istartl <= i) .and. (i <=iendl)
917     
918                       need_copy = isok_k .and. isok_j .and. isok_i
919     
920                       if (need_copy) then
921                           ijk_gl = funijk_gl(i,j,k)
922                           gbuf( ijk_gl ) = gbuf_pack(ibuffer)
923                       endif
924     
925                     enddo
926                   enddo
927                 enddo
928                 ioffset = ibuffer
929               enddo
930             endif
931     
932     
933             deallocate(gbuf_pack)
934     
935             return
936             end subroutine gather_1i
937     
938     
939             subroutine gather_2i( lbuf, gbuf, mroot, idebug )
940             integer, intent(in), dimension(:,:) :: lbuf
941             integer, intent(out), dimension(:,:) :: gbuf
942             integer, optional, intent(in) :: mroot, idebug
943     
944             integer :: i,j,lroot, lidebug
945     
946             if (.not. present(mroot)) then
947                lroot = 0
948             else
949                lroot = mroot
950             endif
951     
952             if (.not. present(idebug)) then
953                lidebug = 0
954             else
955                lidebug = idebug
956             endif
957     
958             if(myPE.eq.lroot) then
959             call assert( size(lbuf,2).eq.size(gbuf,2),  &
960                     '** gather_2i: size(lbuf,2).ne.size(gbuf,2) ', &
961                     size(lbuf,2), size(gbuf,2) )
962             endif
963     
964             do j=lbound(lbuf,2),ubound(lbuf,2)
965               call gather_1i( lbuf(:,j), gbuf(:,j), lroot, lidebug )
966             enddo
967     
968             return
969             end subroutine gather_2i
970     
971             subroutine gather_3i( lbuf, gbuf, mroot, idebug )
972             integer, intent(in), dimension(:,:,:) :: lbuf
973             integer, intent(out), dimension(:,:,:) :: gbuf
974             integer, optional, intent(in) :: mroot, idebug
975     
976             integer :: j,k,lroot, lidebug
977     
978             if (.not. present(mroot)) then
979                lroot = 0
980             else
981                lroot = mroot
982             endif
983     
984             if (.not. present(idebug)) then
985                lidebug = 0
986             else
987                lidebug = idebug
988             endif
989     
990             if(myPE.eq.lroot) then
991             call assert( size(lbuf,2).eq.size(gbuf,2),  &
992                     '** gather_3i: size(lbuf,2).ne.size(gbuf,2) ', &
993                     size(lbuf,2), size(gbuf,2) )
994     
995             call assert( size(lbuf,3).eq.size(gbuf,3),  &
996                     '** gather_3i: size(lbuf,3).ne.size(gbuf,3) ', &
997                     size(lbuf,3), size(gbuf,3) )
998             endif
999     
1000             do k=lbound(lbuf,3),ubound(lbuf,3)
1001             do j=lbound(lbuf,2),ubound(lbuf,2)
1002               call gather_1i( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
1003             enddo
1004             enddo
1005     
1006             return
1007             end subroutine gather_3i
1008     
1009             subroutine gather_1r( lbuf, gbuf, mroot, idebug )
1010     
1011             use functions
1012             implicit none
1013     
1014             real, intent(in), dimension(:) :: lbuf
1015             real, intent(out), dimension(:) :: gbuf
1016             integer, optional, intent(in) :: mroot, idebug
1017     
1018             real, allocatable, dimension(:) :: gbuf_pack
1019     
1020             integer :: recvtype, sendtype, ijk1,ijk2,sendcnt, ierr,lroot, lidebug
1021             integer :: i,j,k,ibuffer,iproc, ioffset
1022             integer :: ijk, ijk_gl
1023             integer :: istartl, iendl, jstartl, jendl, kstartl, kendl
1024             logical :: isok_k,isok_j,isok_i, isinterior
1025             logical :: isbc_k,isbc_j,isbc_i, isboundary, need_copy
1026     
1027             if (.not. present(mroot)) then
1028                lroot = 0
1029             else
1030                lroot = mroot
1031             endif
1032     
1033             if (.not. present(idebug)) then
1034                lidebug = 0
1035             else
1036                lidebug = idebug
1037             endif
1038     
1039             if(myPE.eq.lroot) then
1040               allocate(gbuf_pack(sum(ijksize3_all(:))))
1041             else
1042               allocate(gbuf_pack(10))
1043             endif
1044     
1045             recvtype = MPI_REAL
1046             sendtype = recvtype
1047     
1048             ijk1 = ijkstart3
1049     !        ijk2 = ijkend3
1050             ijk2 = max(ijkend3,BACKGROUND_IJKEND3)   !  For cell re-indexing
1051     
1052     
1053     
1054             sendcnt = ijk2-ijk1+1
1055     
1056             call MPI_Gatherv( lbuf, sendcnt, sendtype,  &
1057                                gbuf_pack, ijksize3_all, displs, recvtype, &
1058                               lroot, MPI_COMM_WORLD, ierr )
1059             call MPI_Check( 'gather_1r:MPI_Gatherv', ierr )
1060     
1061             if( myPE.eq.lroot) then
1062             ioffset = 0
1063               do iproc = 0,numPEs-1
1064                 ibuffer = 0
1065                 istartl = istart1_all(iproc)
1066                 iendl = iend1_all(iproc)
1067                 jstartl = jstart1_all(iproc)
1068                 jendl = jend1_all(iproc)
1069                 kstartl = kstart1_all(iproc)
1070                 kendl = kend1_all(iproc)
1071     
1072                 if(istart3_all(iproc).eq.imin3) istartl = istart3_all(iproc)
1073                 if(iend3_all(iproc).eq.imax3) iendl = iend3_all(iproc)
1074                 if(jstart3_all(iproc).eq.jmin3) jstartl = jstart3_all(iproc)
1075                 if(jend3_all(iproc).eq.jmax3) jendl = jend3_all(iproc)
1076                 if(kstart3_all(iproc).eq.kmin3) kstartl = kstart3_all(iproc)
1077                 if(kend3_all(iproc).eq.kmax3) kendl = kend3_all(iproc)
1078     
1079                 do k = kstart3_all(iproc), kend3_all(iproc)
1080                   do j = jstart3_all(iproc), jend3_all(iproc)
1081                     do i = istart3_all(iproc), iend3_all(iproc)
1082     
1083                       ibuffer = funijk_proc(i,j,k,iproc) + ioffset
1084                       isok_k = (kstartl <= k) .and. (k <=kendl)
1085                       isok_j = (jstartl <= j) .and. (j <=jendl)
1086                       isok_i = (istartl <= i) .and. (i <=iendl)
1087     
1088                       need_copy = isok_k .and. isok_j .and. isok_i
1089     
1090                       if (need_copy) then
1091                           ijk_gl = funijk_gl(i,j,k)
1092                           gbuf( ijk_gl ) = gbuf_pack(ibuffer)
1093                       endif
1094     
1095                     enddo
1096                   enddo
1097                 enddo
1098                 ioffset = ibuffer
1099               enddo
1100             endif
1101     
1102     
1103             deallocate(gbuf_pack)
1104     
1105             return
1106             end subroutine gather_1r
1107     
1108     
1109             subroutine gather_2r( lbuf, gbuf, mroot, idebug )
1110             real, intent(in), dimension(:,:) :: lbuf
1111             real, intent(out), dimension(:,:) :: gbuf
1112             integer, optional, intent(in) :: mroot, idebug
1113     
1114             integer :: i,j,lroot, lidebug
1115     
1116             if (.not. present(mroot)) then
1117                lroot = 0
1118             else
1119                lroot = mroot
1120             endif
1121     
1122             if (.not. present(idebug)) then
1123                lidebug = 0
1124             else
1125                lidebug = idebug
1126             endif
1127     
1128             if(myPE.eq.lroot) then
1129             call assert( size(lbuf,2).eq.size(gbuf,2),  &
1130                     '** gather_2r: size(lbuf,2).ne.size(gbuf,2) ', &
1131                     size(lbuf,2), size(gbuf,2) )
1132             endif
1133     
1134             do j=lbound(lbuf,2),ubound(lbuf,2)
1135               call gather_1r( lbuf(:,j), gbuf(:,j), lroot, lidebug )
1136             enddo
1137     
1138             return
1139             end subroutine gather_2r
1140     
1141             subroutine gather_3r( lbuf, gbuf, mroot, idebug )
1142             real, intent(in), dimension(:,:,:) :: lbuf
1143             real, intent(out), dimension(:,:,:) :: gbuf
1144             integer, optional, intent(in) :: mroot, idebug
1145     
1146             integer :: j,k,lroot, lidebug
1147     
1148             if (.not. present(mroot)) then
1149                lroot = 0
1150             else
1151                lroot = mroot
1152             endif
1153     
1154             if (.not. present(idebug)) then
1155                lidebug = 0
1156             else
1157                lidebug = idebug
1158             endif
1159     
1160             if(myPE.eq.lroot) then
1161             call assert( size(lbuf,2).eq.size(gbuf,2),  &
1162                     '** gather_3r: size(lbuf,2).ne.size(gbuf,2) ', &
1163                     size(lbuf,2), size(gbuf,2) )
1164     
1165             call assert( size(lbuf,3).eq.size(gbuf,3),  &
1166                     '** gather_3r: size(lbuf,3).ne.size(gbuf,3) ', &
1167                     size(lbuf,3), size(gbuf,3) )
1168             endif
1169     
1170             do k=lbound(lbuf,3),ubound(lbuf,3)
1171             do j=lbound(lbuf,2),ubound(lbuf,2)
1172               call gather_1r( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
1173             enddo
1174             enddo
1175     
1176             return
1177             end subroutine gather_3r
1178     
1179     
1180             subroutine gather_1d( lbuf, gbuf, mroot, idebug )
1181     
1182             use functions
1183             implicit none
1184     
1185             double precision, intent(in), dimension(:) :: lbuf
1186             double precision, intent(out), dimension(:) :: gbuf
1187             integer, optional, intent(in) :: mroot, idebug
1188     
1189             double precision, allocatable, dimension(:) :: gbuf_pack
1190     
1191             integer :: recvtype, sendtype, ijk1,ijk2,sendcnt, ierr,lroot, lidebug
1192             integer :: i,j,k,ibuffer,iproc, ioffset
1193             integer :: ijk, ijk_gl
1194             logical :: isok_k,isok_j,isok_i, isinterior
1195             logical :: isbc_k,isbc_j,isbc_i, isboundary, need_copy
1196             integer :: istartl, iendl, jstartl, jendl, kstartl, kendl
1197     
1198             if (.not. present(mroot)) then
1199                lroot = 0
1200             else
1201                lroot = mroot
1202             endif
1203     
1204             if (.not. present(idebug)) then
1205                lidebug = 0
1206             else
1207                lidebug = idebug
1208             endif
1209     
1210             if(myPE.eq.lroot) then
1211               allocate(gbuf_pack(sum(ijksize3_all(:))))
1212             else
1213               allocate(gbuf_pack(10))
1214             endif
1215     
1216             recvtype = MPI_DOUBLE_PRECISION
1217             sendtype = recvtype
1218     
1219             ijk1 = ijkstart3
1220     !        ijk2 = ijkend3
1221             ijk2 = max(ijkend3,BACKGROUND_IJKEND3)   !  For cell re-indexing
1222     
1223             sendcnt = ijk2-ijk1+1
1224     
1225             call MPI_Gatherv( lbuf, sendcnt, sendtype,  &
1226                                gbuf_pack, ijksize3_all, displs, recvtype, &
1227                               lroot, MPI_COMM_WORLD, ierr )
1228             call MPI_Check( 'gather_1d:MPI_Gatherv', ierr )
1229     
1230             if( myPE.eq.lroot) then
1231             ioffset = 0
1232               do iproc = 0,numPEs-1
1233                 ibuffer = 0
1234                 istartl = istart1_all(iproc)
1235                 iendl = iend1_all(iproc)
1236                 jstartl = jstart1_all(iproc)
1237                 jendl = jend1_all(iproc)
1238                 kstartl = kstart1_all(iproc)
1239                 kendl = kend1_all(iproc)
1240     
1241                 if(istart3_all(iproc).eq.imin3) istartl = istart3_all(iproc)
1242                 if(iend3_all(iproc).eq.imax3) iendl = iend3_all(iproc)
1243                 if(jstart3_all(iproc).eq.jmin3) jstartl = jstart3_all(iproc)
1244                 if(jend3_all(iproc).eq.jmax3) jendl = jend3_all(iproc)
1245                 if(kstart3_all(iproc).eq.kmin3) kstartl = kstart3_all(iproc)
1246                 if(kend3_all(iproc).eq.kmax3) kendl = kend3_all(iproc)
1247     
1248                 do k = kstart3_all(iproc), kend3_all(iproc)
1249                   do j = jstart3_all(iproc), jend3_all(iproc)
1250                     do i = istart3_all(iproc), iend3_all(iproc)
1251     
1252                       ibuffer = funijk_proc(i,j,k,iproc) + ioffset
1253                       isok_k = (kstartl <= k) .and. (k <=kendl)
1254                       isok_j = (jstartl <= j) .and. (j <=jendl)
1255                       isok_i = (istartl <= i) .and. (i <=iendl)
1256     
1257                       need_copy = isok_k .and. isok_j .and. isok_i
1258     
1259                       if (need_copy) then
1260                           ijk_gl = funijk_gl(i,j,k)
1261                           gbuf( ijk_gl ) = gbuf_pack(ibuffer)
1262                       endif
1263     
1264                     enddo
1265                   enddo
1266                 enddo
1267                 ioffset = ibuffer
1268               enddo
1269             endif
1270     
1271             deallocate(gbuf_pack)
1272     
1273             return
1274             end subroutine gather_1d
1275     
1276     
1277             subroutine gather_2d( lbuf, gbuf, mroot, idebug )
1278             double precision, intent(in), dimension(:,:) :: lbuf
1279             double precision, intent(out), dimension(:,:) :: gbuf
1280             integer, optional, intent(in) :: mroot, idebug
1281     
1282             integer :: i,j,lroot, lidebug
1283     
1284             if (.not. present(mroot)) then
1285                lroot = 0
1286             else
1287                lroot = mroot
1288             endif
1289     
1290             if (.not. present(idebug)) then
1291                lidebug = 0
1292             else
1293                lidebug = idebug
1294             endif
1295     
1296             if(myPE.eq.lroot) then
1297             call assert( size(lbuf,2).eq.size(gbuf,2),  &
1298                     '** gather_2d: size(lbuf,2).ne.size(gbuf,2) ', &
1299                     size(lbuf,2), size(gbuf,2) )
1300             endif
1301     
1302             do j=lbound(lbuf,2),ubound(lbuf,2)
1303               call gather_1d( lbuf(:,j), gbuf(:,j), lroot, lidebug )
1304             enddo
1305     
1306             return
1307             end subroutine gather_2d
1308     
1309             subroutine gather_3d( lbuf, gbuf, mroot, idebug )
1310             double precision, intent(in), dimension(:,:,:) :: lbuf
1311             double precision, intent(out), dimension(:,:,:) :: gbuf
1312             integer, optional, intent(in) :: mroot, idebug
1313     
1314             integer :: j,k,lroot, lidebug
1315     
1316             if (.not. present(mroot)) then
1317                lroot = 0
1318             else
1319                lroot = mroot
1320             endif
1321     
1322             if (.not. present(idebug)) then
1323                lidebug = 0
1324             else
1325                lidebug = idebug
1326             endif
1327     
1328             if(myPE.eq.lroot) then
1329             call assert( size(lbuf,2).eq.size(gbuf,2),  &
1330                     '** gather_3d: size(lbuf,2).ne.size(gbuf,2) ', &
1331                     size(lbuf,2), size(gbuf,2) )
1332     
1333             call assert( size(lbuf,3).eq.size(gbuf,3),  &
1334                     '** gather_3d: size(lbuf,3).ne.size(gbuf,3) ', &
1335                     size(lbuf,3), size(gbuf,3) )
1336             endif
1337     
1338             do k=lbound(lbuf,3),ubound(lbuf,3)
1339             do j=lbound(lbuf,2),ubound(lbuf,2)
1340               call gather_1d( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
1341             enddo
1342             enddo
1343     
1344             return
1345             end subroutine gather_3d
1346     
1347     
1348             subroutine gather_1c( lbuf, gbuf, mroot, idebug )
1349     
1350             use functions
1351             implicit none
1352     
1353             character(len=*), intent(in), dimension(:) :: lbuf
1354             character(len=*), intent(out), dimension(:) :: gbuf
1355             integer, optional, intent(in) :: mroot, idebug
1356     
1357             integer, allocatable, dimension(:,:) :: gbuf_pack,lbuf1
1358             character(len=80) :: string
1359     
1360             integer :: recvtype, sendtype, ijk1,ijk2,sendcnt, ierr,lroot, lidebug
1361             integer :: i,j,k,ibuffer,iproc, ioffset
1362             integer :: ijk, ijk_gl
1363             integer :: istartl, iendl, jstartl, jendl, kstartl, kendl
1364             integer :: lenchar, icount
1365             logical :: isok_k,isok_j,isok_i, isinterior
1366             logical :: isbc_k,isbc_j,isbc_i, isboundary, need_copy
1367     
1368     !       check to see whether there is root
1369     
1370             if (.not. present(mroot)) then
1371                lroot = 0
1372             else
1373                lroot = mroot
1374             endif
1375     
1376             if (.not. present(idebug)) then
1377                lidebug = 0
1378             else
1379                lidebug = idebug
1380             endif
1381     
1382     
1383             ijk1 = ijkstart3
1384     !        ijk2 = ijkend3
1385             ijk2 = max(ijkend3,BACKGROUND_IJKEND3)   !  For cell re-indexing
1386     
1387             lenchar = len(lbuf(1))
1388     
1389             if(myPE.eq.lroot) then
1390             allocate(gbuf_pack(ijkmax3,lenchar))
1391             else
1392             allocate(gbuf_pack(10,lenchar))
1393             endif
1394     
1395             allocate(lbuf1(ijk1:ijk2,lenchar))
1396     
1397             do i = ijk1,ijk2
1398                string = lbuf(i)(1:lenchar)
1399                do j = 1,lenchar
1400                lbuf1(i,j) = ichar(string(j:j))
1401                enddo
1402             enddo
1403     
1404             call gather_2i(lbuf1, gbuf_pack)
1405     
1406             if(myPE.eq.lroot) then
1407             do i = 1,ijkmax3
1408               do j = 1,lenchar
1409     
1410                 string(j:j) = char(gbuf_pack(i,j))
1411     
1412               enddo
1413               gbuf(i)(1:lenchar) = string(1:lenchar)
1414     
1415             enddo
1416             endif
1417     
1418             deallocate(gbuf_pack)
1419             deallocate(lbuf1)
1420     
1421     
1422             return
1423             end subroutine gather_1c
1424     
1425     
1426             subroutine gather_1l( lbuf, gbuf, mroot, idebug )
1427     
1428             use functions
1429             implicit none
1430     
1431             logical, intent(in), dimension(:) :: lbuf
1432             logical, intent(out), dimension(:) :: gbuf
1433             integer, optional, intent(in) :: mroot, idebug
1434     
1435             logical, allocatable, dimension(:) :: gbuf_pack
1436     
1437             integer :: recvtype, sendtype, ijk1,ijk2,sendcnt, ierr,lroot, lidebug
1438             integer :: i,j,k,ibuffer,iproc, ioffset
1439             integer :: ijk, ijk_gl
1440             integer :: istartl, iendl, jstartl, jendl, kstartl, kendl
1441             logical :: isok_k,isok_j,isok_i, isinterior
1442             logical :: isbc_k,isbc_j,isbc_i, isboundary, need_copy
1443     
1444     !       check to see whether there is root
1445     
1446             if (.not. present(mroot)) then
1447                lroot = 0
1448             else
1449                lroot = mroot
1450             endif
1451     
1452             if (.not. present(idebug)) then
1453                lidebug = 0
1454             else
1455                lidebug = idebug
1456             endif
1457     
1458             if(myPE.eq.lroot) then
1459             allocate(gbuf_pack(sum(ijksize3_all(:))))
1460             else
1461             allocate(gbuf_pack(10))
1462             endif
1463     
1464             recvtype = MPI_LOGICAL
1465             sendtype = recvtype
1466     
1467             ijk1 = ijkstart3
1468     !        ijk2 = ijkend3
1469             ijk2 = max(ijkend3,BACKGROUND_IJKEND3)   !  For cell re-indexing
1470     
1471             sendcnt = ijk2-ijk1+1
1472     
1473             call MPI_Gatherv( lbuf, sendcnt, sendtype,  &
1474                                gbuf_pack, ijksize3_all, displs, recvtype, &
1475                               lroot, MPI_COMM_WORLD, ierr )
1476             call MPI_Check( 'gather_1l:MPI_Gatherv', ierr )
1477     
1478             if( myPE.eq.lroot) then
1479             ioffset = 0
1480               do iproc = 0,numPEs-1
1481                 ibuffer = 0
1482                 istartl = istart1_all(iproc)
1483                 iendl = iend1_all(iproc)
1484                 jstartl = jstart1_all(iproc)
1485                 jendl = jend1_all(iproc)
1486                 kstartl = kstart1_all(iproc)
1487                 kendl = kend1_all(iproc)
1488     
1489                 if(istart3_all(iproc).eq.imin3) istartl = istart3_all(iproc)
1490                 if(iend3_all(iproc).eq.imax3) iendl = iend3_all(iproc)
1491                 if(jstart3_all(iproc).eq.jmin3) jstartl = jstart3_all(iproc)
1492                 if(jend3_all(iproc).eq.jmax3) jendl = jend3_all(iproc)
1493                 if(kstart3_all(iproc).eq.kmin3) kstartl = kstart3_all(iproc)
1494                 if(kend3_all(iproc).eq.kmax3) kendl = kend3_all(iproc)
1495     
1496                 do k = kstart3_all(iproc), kend3_all(iproc)
1497                   do j = jstart3_all(iproc), jend3_all(iproc)
1498                     do i = istart3_all(iproc), iend3_all(iproc)
1499     
1500                       ibuffer = funijk_proc(i,j,k,iproc) + ioffset
1501                       isok_k = (kstartl <= k) .and. (k <=kendl)
1502                       isok_j = (jstartl <= j) .and. (j <=jendl)
1503                       isok_i = (istartl <= i) .and. (i <=iendl)
1504     
1505                       need_copy = isok_k .and. isok_j .and. isok_i
1506     
1507                       if (need_copy) then
1508                           ijk_gl = funijk_gl(i,j,k)
1509                           gbuf( ijk_gl ) = gbuf_pack(ibuffer)
1510                       endif
1511     
1512                     enddo
1513                   enddo
1514                 enddo
1515                 ioffset = ibuffer
1516               enddo
1517             endif
1518     
1519             deallocate(gbuf_pack)
1520     
1521             return
1522             end subroutine gather_1l
1523     
1524     
1525     !       Routines to broadcast information from processor 0 in buffer to all
1526     !       the processors
1527     
1528             subroutine bcast_0i( buffer, mroot, idebug )
1529             integer, intent(inout) :: buffer
1530             integer, optional, intent(in) :: mroot, idebug
1531     
1532             integer :: datatype, count, ierr,lroot, lidebug
1533     
1534             if (.not. present(mroot)) then
1535                lroot = 0
1536             else
1537                lroot = mroot
1538             endif
1539     
1540             if (.not. present(idebug)) then
1541                lidebug = 0
1542             else
1543                lidebug = idebug
1544             endif
1545     
1546             datatype = MPI_INTEGER
1547     
1548             count = 1
1549     
1550             call MPI_Bcast( buffer, count, datatype, lroot, MPI_COMM_WORLD, ierr)
1551             call MPI_Check( 'bcast_0i:MPI_Bcast', ierr )
1552     
1553             return
1554             end subroutine bcast_0i
1555     
1556     
1557             subroutine bcast_1i( buffer, mroot, idebug )
1558             integer, intent(inout), dimension(:) :: buffer
1559             integer, optional, intent(in) :: mroot, idebug
1560     
1561             integer :: datatype, count, ierr,lroot, lidebug
1562     
1563             if (.not. present(mroot)) then
1564                lroot = 0
1565             else
1566                lroot = mroot
1567             endif
1568     
1569             if (.not. present(idebug)) then
1570                lidebug = 0
1571             else
1572                lidebug = idebug
1573             endif
1574     
1575             datatype = MPI_INTEGER
1576     
1577             count = size(buffer,1)
1578     
1579             call MPI_Bcast( buffer, count, datatype, lroot, MPI_COMM_WORLD, ierr)
1580             call MPI_Check( 'bcast_1i:MPI_Bcast', ierr )
1581     
1582             return
1583             end subroutine bcast_1i
1584     
1585     
1586             subroutine bcast_2i( buffer, mroot, idebug )
1587             integer, intent(inout), dimension(:,:) :: buffer
1588             integer, optional, intent(in) :: mroot, idebug
1589     
1590             integer :: i,j,lroot, lidebug
1591     
1592             if (.not. present(mroot)) then
1593                lroot = 0
1594             else
1595                lroot = mroot
1596             endif
1597     
1598             if (.not. present(idebug)) then
1599                lidebug = 0
1600             else
1601                lidebug = idebug
1602             endif
1603     
1604             do j=lbound(buffer,2),ubound(buffer,2)
1605               call bcast_1i( buffer(:,j), lroot, lidebug )
1606             enddo
1607     
1608             return
1609             end subroutine bcast_2i
1610     
1611             subroutine bcast_3i( buffer, mroot, idebug )
1612             integer, intent(inout), dimension(:,:,:) :: buffer
1613             integer, optional, intent(in) :: mroot, idebug
1614     
1615             integer :: j,k,lroot, lidebug
1616     
1617             if (.not. present(mroot)) then
1618                lroot = 0
1619             else
1620                lroot = mroot
1621             endif
1622     
1623             if (.not. present(idebug)) then
1624                lidebug = 0
1625             else
1626                lidebug = idebug
1627             endif
1628     
1629             do k=lbound(buffer,3),ubound(buffer,3)
1630             do j=lbound(buffer,2),ubound(buffer,2)
1631               call bcast_1i( buffer(:,j,k), lroot, lidebug )
1632             enddo
1633             enddo
1634     
1635             return
1636             end subroutine bcast_3i
1637     
1638             subroutine bcast_0r( buffer, mroot, idebug )
1639             real, intent(inout) :: buffer
1640             integer, optional, intent(in) :: mroot, idebug
1641     
1642             integer :: datatype, count, ierr,lroot, lidebug
1643     
1644             if (.not. present(mroot)) then
1645                lroot = 0
1646             else
1647                lroot = mroot
1648             endif
1649     
1650             if (.not. present(idebug)) then
1651                lidebug = 0
1652             else
1653                lidebug = idebug
1654             endif
1655     
1656             datatype = MPI_REAL
1657     
1658             count = 1
1659     
1660             call MPI_Bcast( buffer, count, datatype, lroot, MPI_COMM_WORLD, ierr)
1661             call MPI_Check( 'bcast_0r:MPI_Bcast', ierr )
1662     
1663             return
1664             end subroutine bcast_0r
1665     
1666     
1667             subroutine bcast_1r( buffer, mroot, idebug )
1668             real, intent(inout), dimension(:) :: buffer
1669             integer, optional, intent(in) :: mroot, idebug
1670     
1671             integer :: datatype, count, ierr,lroot, lidebug
1672     
1673             if (.not. present(mroot)) then
1674                lroot = 0
1675             else
1676                lroot = mroot
1677             endif
1678     
1679             if (.not. present(idebug)) then
1680                lidebug = 0
1681             else
1682                lidebug = idebug
1683             endif
1684     
1685             datatype = MPI_REAL
1686     
1687             count = size(buffer,1)
1688     
1689             call MPI_Bcast( buffer, count, datatype, lroot, MPI_COMM_WORLD, ierr)
1690             call MPI_Check( 'bcast_1r:MPI_Bcast', ierr )
1691     
1692             return
1693             end subroutine bcast_1r
1694     
1695     
1696             subroutine bcast_2r( buffer, mroot, idebug )
1697             real, intent(inout), dimension(:,:) :: buffer
1698             integer, optional, intent(in) :: mroot, idebug
1699     
1700             integer :: i,j,lroot, lidebug
1701     
1702             if (.not. present(mroot)) then
1703                lroot = 0
1704             else
1705                lroot = mroot
1706             endif
1707     
1708             if (.not. present(idebug)) then
1709                lidebug = 0
1710             else
1711                lidebug = idebug
1712             endif
1713     
1714             do j=lbound(buffer,2),ubound(buffer,2)
1715               call bcast_1r( buffer(:,j), lroot, lidebug )
1716             enddo
1717     
1718             return
1719             end subroutine bcast_2r
1720     
1721             subroutine bcast_3r( buffer, mroot, idebug )
1722             real, intent(inout), dimension(:,:,:) :: buffer
1723             integer, optional, intent(in) :: mroot, idebug
1724     
1725             integer :: j,k,lroot, lidebug
1726     
1727             if (.not. present(mroot)) then
1728                lroot = 0
1729             else
1730                lroot = mroot
1731             endif
1732     
1733             if (.not. present(idebug)) then
1734                lidebug = 0
1735             else
1736                lidebug = idebug
1737             endif
1738     
1739             do k=lbound(buffer,3),ubound(buffer,3)
1740             do j=lbound(buffer,2),ubound(buffer,2)
1741               call bcast_1r( buffer(:,j,k), lroot, lidebug )
1742             enddo
1743             enddo
1744     
1745             return
1746             end subroutine bcast_3r
1747     
1748             subroutine bcast_0d( buffer, mroot, idebug )
1749             double precision, intent(inout) :: buffer
1750             integer, optional, intent(in) :: mroot, idebug
1751     
1752             integer :: datatype, count, ierr,lroot, lidebug
1753     
1754             if (.not. present(mroot)) then
1755                lroot = 0
1756             else
1757                lroot = mroot
1758             endif
1759     
1760             if (.not. present(idebug)) then
1761                lidebug = 0
1762             else
1763                lidebug = idebug
1764             endif
1765     
1766             datatype = MPI_DOUBLE_PRECISION
1767     
1768             count = 1
1769     
1770             call MPI_Bcast( buffer, count, datatype, lroot, MPI_COMM_WORLD, ierr)
1771             call MPI_Check( 'bcast_0d:MPI_Bcast', ierr )
1772     
1773             return
1774             end subroutine bcast_0d
1775     
1776     
1777             subroutine bcast_1d( buffer, mroot, idebug )
1778             double precision, intent(inout), dimension(:) :: buffer
1779             integer, optional, intent(in) :: mroot, idebug
1780     
1781             integer :: datatype, count, ierr,lroot, lidebug
1782     
1783             if (.not. present(mroot)) then
1784                lroot = 0
1785             else
1786                lroot = mroot
1787             endif
1788     
1789             if (.not. present(idebug)) then
1790                lidebug = 0
1791             else
1792                lidebug = idebug
1793             endif
1794     
1795             datatype = MPI_DOUBLE_PRECISION
1796     
1797             count = size(buffer,1)
1798     
1799             call MPI_Bcast( buffer, count, datatype, lroot, MPI_COMM_WORLD, ierr)
1800             call MPI_Check( 'bcast_1d:MPI_Bcast', ierr )
1801     
1802             return
1803             end subroutine bcast_1d
1804     
1805     
1806             subroutine bcast_2d( buffer, mroot, idebug )
1807             double precision, intent(inout), dimension(:,:) :: buffer
1808             integer, optional, intent(in) :: mroot, idebug
1809     
1810             integer :: i,j,lroot, lidebug
1811     
1812             if (.not. present(mroot)) then
1813                lroot = 0
1814             else
1815                lroot = mroot
1816             endif
1817     
1818             if (.not. present(idebug)) then
1819                lidebug = 0
1820             else
1821                lidebug = idebug
1822             endif
1823     
1824             do j=lbound(buffer,2),ubound(buffer,2)
1825               call bcast_1d( buffer(:,j), lroot, lidebug )
1826             enddo
1827     
1828             return
1829             end subroutine bcast_2d
1830     
1831             subroutine bcast_3d( buffer, mroot, idebug )
1832             double precision, intent(inout), dimension(:,:,:) :: buffer
1833             integer, optional, intent(in) :: mroot, idebug
1834     
1835             integer :: j,k,lroot, lidebug
1836     
1837             if (.not. present(mroot)) then
1838                lroot = 0
1839             else
1840                lroot = mroot
1841             endif
1842     
1843             if (.not. present(idebug)) then
1844                lidebug = 0
1845             else
1846                lidebug = idebug
1847             endif
1848     
1849             do k=lbound(buffer,3),ubound(buffer,3)
1850             do j=lbound(buffer,2),ubound(buffer,2)
1851               call bcast_1d( buffer(:,j,k), lroot, lidebug )
1852             enddo
1853             enddo
1854     
1855             return
1856             end subroutine bcast_3d
1857     
1858             subroutine bcast_0c( buffer, mroot, idebug )
1859             character(len=*), intent(inout) :: buffer
1860             integer, optional, intent(in) :: mroot, idebug
1861             character, allocatable, dimension(:) :: buffer1
1862     
1863             integer :: datatype, count, ierr,lroot, lidebug
1864             integer :: lenchar,icount, i, j
1865     
1866             if (.not. present(mroot)) then
1867                lroot = 0
1868             else
1869                lroot = mroot
1870             endif
1871     
1872             if (.not. present(idebug)) then
1873                lidebug = 0
1874             else
1875                lidebug = idebug
1876             endif
1877     
1878             lenchar = len(buffer)
1879     
1880             allocate(buffer1(lenchar))
1881     
1882             icount = 0
1883             do j = 1,lenchar
1884     
1885               icount = icount+1
1886               buffer1(icount) = buffer(j:j)
1887     
1888             enddo
1889     
1890             datatype = MPI_CHARACTER
1891     
1892             count = 1
1893     
1894             call MPI_Bcast( buffer1, count*lenchar, datatype, lroot, MPI_COMM_WORLD, ierr)
1895             call MPI_Check( 'bcast_0c:MPI_Bcast', ierr )
1896     
1897             icount = 0
1898             do j = 1,lenchar
1899     
1900               icount = icount+1
1901               buffer(j:j) = buffer1(icount)
1902     
1903             enddo
1904     
1905             deallocate(buffer1)
1906     
1907             return
1908             end subroutine bcast_0c
1909     
1910     
1911             subroutine bcast_1c( buffer, mroot, idebug )
1912             character(len=*), intent(inout), dimension(:) :: buffer
1913             integer, optional, intent(in) :: mroot, idebug
1914             character, allocatable, dimension(:) :: buffer1
1915     
1916             integer :: datatype, count, ierr,lroot, lidebug
1917             integer :: lenchar,icount, i, j
1918             character(len=len(buffer(1))) :: string
1919     
1920             if (.not. present(mroot)) then
1921                lroot = 0
1922             else
1923                lroot = mroot
1924             endif
1925     
1926             if (.not. present(idebug)) then
1927                lidebug = 0
1928             else
1929                lidebug = idebug
1930             endif
1931     
1932             lenchar = len(buffer(1))
1933     
1934             allocate(buffer1(size(buffer)*lenchar))
1935     
1936             icount = 0
1937             do i = 1,size(buffer)
1938               string = buffer(i)(1:lenchar)
1939               do j = 1,lenchar
1940     
1941                 icount = icount+1
1942                 buffer1(icount) = string(j:j)
1943     
1944               enddo
1945             enddo
1946     
1947             datatype = MPI_CHARACTER
1948     
1949             count = size(buffer,1)
1950     
1951             call MPI_Bcast( buffer1, count*lenchar, datatype, lroot, MPI_COMM_WORLD, ierr)
1952             call MPI_Check( 'bcast_1c:MPI_Bcast', ierr )
1953     
1954             icount = 0
1955             do i = 1,size(buffer)
1956               do j = 1,lenchar
1957     
1958                 icount = icount+1
1959                 string(j:j) = buffer1(icount)
1960     
1961               enddo
1962                 buffer(i) = string
1963             enddo
1964     
1965             deallocate(buffer1)
1966     
1967             return
1968             end subroutine bcast_1c
1969     
1970             subroutine bcast_0l( buffer, mroot, idebug )
1971             logical, intent(inout) :: buffer
1972             integer, optional, intent(in) :: mroot, idebug
1973     
1974             integer :: datatype, count, ierr,lroot, lidebug
1975     
1976             if (.not. present(mroot)) then
1977                lroot = 0
1978             else
1979                lroot = mroot
1980             endif
1981     
1982             if (.not. present(idebug)) then
1983                lidebug = 0
1984             else
1985                lidebug = idebug
1986             endif
1987     
1988             datatype = MPI_LOGICAL
1989     
1990             count = 1
1991     
1992             call MPI_Bcast( buffer, count, datatype, lroot, MPI_COMM_WORLD, ierr)
1993             call MPI_Check( 'bcast_0l:MPI_Bcast', ierr )
1994     
1995             return
1996             end subroutine bcast_0l
1997     
1998     
1999             subroutine bcast_1l( buffer, mroot, idebug )
2000             logical, intent(inout), dimension(:) :: buffer
2001             integer, optional, intent(in) :: mroot, idebug
2002     
2003             integer :: datatype, count, ierr,lroot, lidebug
2004     
2005             if (.not. present(mroot)) then
2006                lroot = 0
2007             else
2008                lroot = mroot
2009             endif
2010     
2011             if (.not. present(idebug)) then
2012                lidebug = 0
2013             else
2014                lidebug = idebug
2015             endif
2016     
2017             datatype = MPI_LOGICAL
2018     
2019             count = size(buffer,1)
2020     
2021             call MPI_Bcast( buffer, count, datatype, lroot, MPI_COMM_WORLD, ierr)
2022             call MPI_Check( 'bcast_1l:MPI_Bcast', ierr )
2023     
2024             return
2025             end subroutine bcast_1l
2026     
2027     
2028     !       Procedures to do global operations (Sum, Min, Max). _all_ routines
2029     !       send the information to all the processors otherwise they are
2030     !       kept on processor 0.
2031     
2032             subroutine global_sum_0i( lbuf, gbuf, mroot, idebug )
2033             integer, intent(in) :: lbuf
2034             integer, intent(out) :: gbuf
2035             integer, optional, intent(in) :: mroot, idebug
2036     
2037             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2038     
2039             if (.not. present(mroot)) then
2040                lroot = 0
2041             else
2042                lroot = mroot
2043             endif
2044     
2045             if (.not. present(idebug)) then
2046                lidebug = 0
2047             else
2048                lidebug = idebug
2049             endif
2050     
2051             recvtype = MPI_INTEGER
2052             sendtype = recvtype
2053     
2054             sendcnt = 1
2055     
2056             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_SUM, &
2057                               lroot, MPI_COMM_WORLD, ierr )
2058             call MPI_Check( 'global_sum_0i:MPI_Reduce', ierr )
2059     
2060             return
2061             end subroutine global_sum_0i
2062     
2063     
2064             subroutine global_sum_1i( lbuf, gbuf, mroot, idebug )
2065             integer, intent(in), dimension(:) :: lbuf
2066             integer, intent(out), dimension(:) :: gbuf
2067             integer, optional, intent(in) :: mroot, idebug
2068     
2069             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2070     
2071             if (.not. present(mroot)) then
2072                lroot = 0
2073             else
2074                lroot = mroot
2075             endif
2076     
2077             if (.not. present(idebug)) then
2078                lidebug = 0
2079             else
2080                lidebug = idebug
2081             endif
2082     
2083             recvtype = MPI_INTEGER
2084             sendtype = recvtype
2085     
2086             sendcnt = size(lbuf)
2087     
2088             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_SUM, &
2089                               lroot, MPI_COMM_WORLD, ierr )
2090             call MPI_Check( 'global_sum_1i:MPI_Reduce', ierr )
2091     
2092             return
2093             end subroutine global_sum_1i
2094     
2095             subroutine global_sum_2i( lbuf, gbuf, mroot, idebug )
2096             integer, intent(in), dimension(:,:) :: lbuf
2097             integer, intent(out), dimension(:,:) :: gbuf
2098             integer, optional, intent(in) :: mroot, idebug
2099     
2100             integer :: i,j,lroot, lidebug
2101     
2102             if (.not. present(mroot)) then
2103                lroot = 0
2104             else
2105                lroot = mroot
2106             endif
2107     
2108             if (.not. present(idebug)) then
2109                lidebug = 0
2110             else
2111                lidebug = idebug
2112             endif
2113     
2114             if(myPE.eq.lroot) then
2115             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2116                     '** global_sum_2i: size(lbuf,2).ne.size(gbuf,2) ', &
2117                     size(lbuf,2), size(gbuf,2) )
2118             endif
2119     
2120             do j=lbound(lbuf,2),ubound(lbuf,2)
2121               call global_sum_1i( lbuf(:,j), gbuf(:,j), lroot, lidebug )
2122             enddo
2123     
2124             return
2125             end subroutine global_sum_2i
2126     
2127             subroutine global_sum_3i( lbuf, gbuf, mroot, idebug )
2128             integer, intent(in), dimension(:,:,:) :: lbuf
2129             integer, intent(out), dimension(:,:,:) :: gbuf
2130             integer, optional, intent(in) :: mroot, idebug
2131     
2132             integer :: j,k,lroot, lidebug
2133     
2134             if (.not. present(mroot)) then
2135                lroot = 0
2136             else
2137                lroot = mroot
2138             endif
2139     
2140             if (.not. present(idebug)) then
2141                lidebug = 0
2142             else
2143                lidebug = idebug
2144             endif
2145     
2146             if(myPE.eq.lroot) then
2147             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2148                     '** global_sum_3i: size(lbuf,2).ne.size(gbuf,2) ', &
2149                     size(lbuf,2), size(gbuf,2) )
2150     
2151             call assert( size(lbuf,3).eq.size(gbuf,3),  &
2152                     '** global_sum_3i: size(lbuf,3).ne.size(gbuf,3) ', &
2153                     size(lbuf,3), size(gbuf,3) )
2154             endif
2155     
2156             do k=lbound(lbuf,3),ubound(lbuf,3)
2157             do j=lbound(lbuf,2),ubound(lbuf,2)
2158               call global_sum_1i( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
2159             enddo
2160             enddo
2161     
2162             return
2163             end subroutine global_sum_3i
2164     
2165             subroutine global_sum_0r( lbuf, gbuf, mroot, idebug )
2166             real, intent(in) :: lbuf
2167             real, intent(out) :: gbuf
2168             integer, optional, intent(in) :: mroot, idebug
2169     
2170             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2171     
2172             if (.not. present(mroot)) then
2173                lroot = 0
2174             else
2175                lroot = mroot
2176             endif
2177     
2178             if (.not. present(idebug)) then
2179                lidebug = 0
2180             else
2181                lidebug = idebug
2182             endif
2183     
2184             recvtype = MPI_REAL
2185             sendtype = recvtype
2186     
2187             sendcnt = 1
2188     
2189             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_SUM, &
2190                               lroot, MPI_COMM_WORLD, ierr )
2191             call MPI_Check( 'global_sum_0r:MPI_Reduce', ierr )
2192     
2193             return
2194             end subroutine global_sum_0r
2195     
2196     
2197             subroutine global_sum_1r( lbuf, gbuf, mroot, idebug )
2198             real, intent(in), dimension(:) :: lbuf
2199             real, intent(out), dimension(:) :: gbuf
2200             integer, optional, intent(in) :: mroot, idebug
2201     
2202             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2203     
2204             if (.not. present(mroot)) then
2205                lroot = 0
2206             else
2207                lroot = mroot
2208             endif
2209     
2210             if (.not. present(idebug)) then
2211                lidebug = 0
2212             else
2213                lidebug = idebug
2214             endif
2215     
2216             recvtype = MPI_REAL
2217             sendtype = recvtype
2218     
2219             sendcnt = size(lbuf)
2220     
2221             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_SUM, &
2222                               lroot, MPI_COMM_WORLD, ierr )
2223             call MPI_Check( 'global_sum_1r:MPI_Reduce', ierr )
2224     
2225             return
2226             end subroutine global_sum_1r
2227     
2228             subroutine global_sum_2r( lbuf, gbuf, mroot, idebug )
2229             real, intent(in), dimension(:,:) :: lbuf
2230             real, intent(out), dimension(:,:) :: gbuf
2231             integer, optional, intent(in) :: mroot, idebug
2232     
2233             integer :: i,j,lroot, lidebug
2234     
2235             if (.not. present(mroot)) then
2236                lroot = 0
2237             else
2238                lroot = mroot
2239             endif
2240     
2241             if (.not. present(idebug)) then
2242                lidebug = 0
2243             else
2244                lidebug = idebug
2245             endif
2246     
2247             if(myPE.eq.lroot) then
2248             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2249                     '** global_sum_2r: size(lbuf,2).ne.size(gbuf,2) ', &
2250                     size(lbuf,2), size(gbuf,2) )
2251             endif
2252     
2253             do j=lbound(lbuf,2),ubound(lbuf,2)
2254               call global_sum_1r( lbuf(:,j), gbuf(:,j), lroot, lidebug )
2255             enddo
2256     
2257             return
2258             end subroutine global_sum_2r
2259     
2260             subroutine global_sum_3r( lbuf, gbuf, mroot, idebug )
2261             real, intent(in), dimension(:,:,:) :: lbuf
2262             real, intent(out), dimension(:,:,:) :: gbuf
2263             integer, optional, intent(in) :: mroot, idebug
2264     
2265             integer :: j,k,lroot, lidebug
2266     
2267             if (.not. present(mroot)) then
2268                lroot = 0
2269             else
2270                lroot = mroot
2271             endif
2272     
2273             if (.not. present(idebug)) then
2274                lidebug = 0
2275             else
2276                lidebug = idebug
2277             endif
2278     
2279             if(myPE.eq.lroot) then
2280             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2281                     '** global_sum_3i: size(lbuf,2).ne.size(gbuf,2) ', &
2282                     size(lbuf,2), size(gbuf,2) )
2283     
2284             call assert( size(lbuf,3).eq.size(gbuf,3),  &
2285                     '** global_sum_3i: size(lbuf,3).ne.size(gbuf,3) ', &
2286                     size(lbuf,3), size(gbuf,3) )
2287             endif
2288     
2289             do k=lbound(lbuf,3),ubound(lbuf,3)
2290             do j=lbound(lbuf,2),ubound(lbuf,2)
2291               call global_sum_1r( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
2292             enddo
2293             enddo
2294     
2295             return
2296             end subroutine global_sum_3r
2297     
2298             subroutine global_sum_0d( lbuf, gbuf, mroot, idebug )
2299             double precision, intent(in) :: lbuf
2300             double precision, intent(out) :: gbuf
2301             integer, optional, intent(in) :: mroot, idebug
2302     
2303             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2304     
2305             if (.not. present(mroot)) then
2306                lroot = 0
2307             else
2308                lroot = mroot
2309             endif
2310     
2311             if (.not. present(idebug)) then
2312                lidebug = 0
2313             else
2314                lidebug = idebug
2315             endif
2316     
2317             recvtype = MPI_DOUBLE_PRECISION
2318             sendtype = recvtype
2319     
2320             sendcnt = 1
2321     
2322             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_SUM, &
2323                               lroot, MPI_COMM_WORLD, ierr )
2324             call MPI_Check( 'global_sum_0d:MPI_Reduce', ierr )
2325     
2326             return
2327             end subroutine global_sum_0d
2328     
2329     
2330             subroutine global_sum_1d( lbuf, gbuf, mroot, idebug )
2331             double precision, intent(in), dimension(:) :: lbuf
2332             double precision, intent(out), dimension(:) :: gbuf
2333             integer, optional, intent(in) :: mroot, idebug
2334     
2335             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2336     
2337             if (.not. present(mroot)) then
2338                lroot = 0
2339             else
2340                lroot = mroot
2341             endif
2342     
2343             if (.not. present(idebug)) then
2344                lidebug = 0
2345             else
2346                lidebug = idebug
2347             endif
2348     
2349             recvtype = MPI_DOUBLE_PRECISION
2350             sendtype = recvtype
2351     
2352             sendcnt = size(lbuf)
2353     
2354             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_SUM, &
2355                               lroot, MPI_COMM_WORLD, ierr )
2356             call MPI_Check( 'global_sum_1d:MPI_Reduce', ierr )
2357     
2358             return
2359             end subroutine global_sum_1d
2360     
2361             subroutine global_sum_2d( lbuf, gbuf, mroot, idebug )
2362             double precision, intent(in), dimension(:,:) :: lbuf
2363             double precision, intent(out), dimension(:,:) :: gbuf
2364             integer, optional, intent(in) :: mroot, idebug
2365     
2366             integer :: i,j,lroot, lidebug
2367     
2368             if (.not. present(mroot)) then
2369                lroot = 0
2370             else
2371                lroot = mroot
2372             endif
2373     
2374             if (.not. present(idebug)) then
2375                lidebug = 0
2376             else
2377                lidebug = idebug
2378             endif
2379     
2380             if(myPE.eq.lroot) then
2381             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2382                     '** global_sum_2d: size(lbuf,2).ne.size(gbuf,2) ', &
2383                     size(lbuf,2), size(gbuf,2) )
2384             endif
2385     
2386             do j=lbound(lbuf,2),ubound(lbuf,2)
2387               call global_sum_1d( lbuf(:,j), gbuf(:,j), lroot, lidebug )
2388             enddo
2389     
2390             return
2391             end subroutine global_sum_2d
2392     
2393             subroutine global_sum_3d( lbuf, gbuf, mroot, idebug )
2394             double precision, intent(in), dimension(:,:,:) :: lbuf
2395             double precision, intent(out), dimension(:,:,:) :: gbuf
2396             integer, optional, intent(in) :: mroot, idebug
2397     
2398             integer :: j,k,lroot, lidebug
2399     
2400             if (.not. present(mroot)) then
2401                lroot = 0
2402             else
2403                lroot = mroot
2404             endif
2405     
2406             if (.not. present(idebug)) then
2407                lidebug = 0
2408             else
2409                lidebug = idebug
2410             endif
2411     
2412             if(myPE.eq.lroot) then
2413             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2414                     '** global_sum_3i: size(lbuf,2).ne.size(gbuf,2) ', &
2415                     size(lbuf,2), size(gbuf,2) )
2416     
2417             call assert( size(lbuf,3).eq.size(gbuf,3),  &
2418                     '** global_sum_3i: size(lbuf,3).ne.size(gbuf,3) ', &
2419                     size(lbuf,3), size(gbuf,3) )
2420             endif
2421     
2422             do k=lbound(lbuf,3),ubound(lbuf,3)
2423             do j=lbound(lbuf,2),ubound(lbuf,2)
2424               call global_sum_1d( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
2425             enddo
2426             enddo
2427     
2428             return
2429             end subroutine global_sum_3d
2430     
2431             subroutine global_all_sum_onevar_0d( gbuf )
2432             doubleprecision, intent(inout) :: gbuf
2433             doubleprecision :: lbuf
2434     
2435             lbuf = gbuf
2436             call global_all_sum_0d( lbuf, gbuf )
2437             return
2438             end subroutine global_all_sum_onevar_0d
2439     
2440     
2441             subroutine global_all_sum_onevar_1d( gbuf )
2442             doubleprecision, dimension(:), intent(inout) :: gbuf
2443             doubleprecision, dimension(size(gbuf)) :: lbuf
2444     
2445             lbuf = gbuf
2446             call global_all_sum_1d( lbuf, gbuf )
2447             return
2448             end subroutine global_all_sum_onevar_1d
2449     
2450             subroutine global_all_sum_onevar_2d( gbuf )
2451             doubleprecision, dimension(:,:), intent(inout) :: gbuf
2452             doubleprecision, dimension(size(gbuf,1),size(gbuf,2)) :: lbuf
2453     
2454             lbuf = gbuf
2455             call global_all_sum_2d( lbuf, gbuf )
2456             return
2457             end subroutine global_all_sum_onevar_2d
2458     
2459     
2460             subroutine global_all_sum_onevar_3d( gbuf )
2461             doubleprecision, dimension(:,:,:), intent(inout) :: gbuf
2462             doubleprecision, dimension(size(gbuf,1),size(gbuf,2),size(gbuf,3)) :: lbuf
2463     
2464             lbuf = gbuf
2465             call global_all_sum_3d( lbuf, gbuf )
2466             return
2467             end subroutine global_all_sum_onevar_3d
2468     
2469     
2470     
2471             subroutine global_all_sum_onevar_0i( gbuf )
2472             integer, intent(inout) :: gbuf
2473             integer :: lbuf
2474     
2475             lbuf = gbuf
2476             call global_all_sum_0i( lbuf, gbuf )
2477             return
2478             end subroutine global_all_sum_onevar_0i
2479     
2480             subroutine global_all_sum_onevar_1i( gbuf )
2481             integer, dimension(:), intent(inout) :: gbuf
2482             integer, dimension(size(gbuf)) :: lbuf
2483     
2484             lbuf = gbuf
2485             call global_all_sum_1i( lbuf, gbuf )
2486             return
2487             end subroutine global_all_sum_onevar_1i
2488     
2489             subroutine global_all_sum_onevar_2i( gbuf )
2490             integer, dimension(:,:), intent(inout) :: gbuf
2491             integer, dimension(size(gbuf,1),size(gbuf,2)) :: lbuf
2492     
2493             lbuf = gbuf
2494             call global_all_sum_2i( lbuf, gbuf )
2495             return
2496             end subroutine global_all_sum_onevar_2i
2497     
2498     
2499             subroutine global_all_sum_onevar_3i( gbuf )
2500             integer, dimension(:,:,:), intent(inout) :: gbuf
2501             integer, dimension(size(gbuf,1),size(gbuf,2),size(gbuf,3)) :: lbuf
2502     
2503             lbuf = gbuf
2504             call global_all_sum_3i( lbuf, gbuf )
2505             return
2506             end subroutine global_all_sum_onevar_3i
2507     
2508             subroutine global_all_sum_onevar_0r( gbuf )
2509             real, intent(inout) :: gbuf
2510             real :: lbuf
2511     
2512             lbuf = gbuf
2513             call global_all_sum_0r( lbuf, gbuf )
2514             return
2515             end subroutine global_all_sum_onevar_0r
2516     
2517     
2518             subroutine global_all_sum_onevar_1r( gbuf )
2519             real, dimension(:), intent(inout) :: gbuf
2520             real, dimension(size(gbuf)) :: lbuf
2521     
2522             lbuf = gbuf
2523             call global_all_sum_1r( lbuf, gbuf )
2524             return
2525             end subroutine global_all_sum_onevar_1r
2526     
2527             subroutine global_all_sum_onevar_2r( gbuf )
2528             real, dimension(:,:), intent(inout) :: gbuf
2529             real, dimension(size(gbuf,1),size(gbuf,2)) :: lbuf
2530     
2531             lbuf = gbuf
2532             call global_all_sum_2r( lbuf, gbuf )
2533             return
2534             end subroutine global_all_sum_onevar_2r
2535     
2536     
2537             subroutine global_all_sum_onevar_3r( gbuf )
2538             real, dimension(:,:,:), intent(inout) :: gbuf
2539             real, dimension(size(gbuf,1),size(gbuf,2),size(gbuf,3)) :: lbuf
2540     
2541             lbuf = gbuf
2542             call global_all_sum_3r( lbuf, gbuf )
2543             return
2544             end subroutine global_all_sum_onevar_3r
2545     
2546     
2547             subroutine global_all_sum_0i( lbuf, gbuf, mroot, idebug )
2548             integer, intent(in) :: lbuf
2549             integer, intent(out) :: gbuf
2550             integer, optional, intent(in) :: mroot, idebug
2551     
2552             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2553     
2554             if (.not. present(mroot)) then
2555                lroot = 0
2556             else
2557                lroot = mroot
2558             endif
2559     
2560             if (.not. present(idebug)) then
2561                lidebug = 0
2562             else
2563                lidebug = idebug
2564             endif
2565     
2566             recvtype = MPI_INTEGER
2567             sendtype = recvtype
2568     
2569             sendcnt = 1
2570     
2571             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_SUM, &
2572                               MPI_COMM_WORLD, ierr )
2573             call MPI_Check( 'global_all_sum_0i:MPI_Allreduce', ierr )
2574     
2575             return
2576             end subroutine global_all_sum_0i
2577     
2578     
2579             subroutine global_all_sum_1i( lbuf, gbuf, mroot, idebug )
2580             integer, intent(in), dimension(:) :: lbuf
2581             integer, intent(out), dimension(:) :: gbuf
2582             integer, optional, intent(in) :: mroot, idebug
2583     
2584             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2585     
2586             if (.not. present(mroot)) then
2587                lroot = 0
2588             else
2589                lroot = mroot
2590             endif
2591     
2592             if (.not. present(idebug)) then
2593                lidebug = 0
2594             else
2595                lidebug = idebug
2596             endif
2597     
2598             recvtype = MPI_INTEGER
2599             sendtype = recvtype
2600     
2601             sendcnt = size(lbuf)
2602     
2603             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_SUM, &
2604                               MPI_COMM_WORLD, ierr )
2605             call MPI_Check( 'global_all_sum_1i:MPI_Allreduce', ierr )
2606     
2607             return
2608             end subroutine global_all_sum_1i
2609     
2610             subroutine global_all_sum_2i( lbuf, gbuf, mroot, idebug )
2611             integer, intent(in), dimension(:,:) :: lbuf
2612             integer, intent(out), dimension(:,:) :: gbuf
2613             integer, optional, intent(in) :: mroot, idebug
2614     
2615             integer :: i,j,lroot, lidebug
2616     
2617             if (.not. present(mroot)) then
2618                lroot = 0
2619             else
2620                lroot = mroot
2621             endif
2622     
2623             if (.not. present(idebug)) then
2624                lidebug = 0
2625             else
2626                lidebug = idebug
2627             endif
2628     
2629             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2630                     '** global_all_sum_2i: size(lbuf,2).ne.size(gbuf,2) ', &
2631                     size(lbuf,2), size(gbuf,2) )
2632     
2633             do j=lbound(lbuf,2),ubound(lbuf,2)
2634               call global_all_sum_1i( lbuf(:,j), gbuf(:,j), lroot, lidebug )
2635             enddo
2636     
2637             return
2638             end subroutine global_all_sum_2i
2639     
2640             subroutine global_all_sum_3i( lbuf, gbuf, mroot, idebug )
2641             integer, intent(in), dimension(:,:,:) :: lbuf
2642             integer, intent(out), dimension(:,:,:) :: gbuf
2643             integer, optional, intent(in) :: mroot, idebug
2644     
2645             integer :: j,k,lroot, lidebug
2646     
2647             if (.not. present(mroot)) then
2648                lroot = 0
2649             else
2650                lroot = mroot
2651             endif
2652     
2653             if (.not. present(idebug)) then
2654                lidebug = 0
2655             else
2656                lidebug = idebug
2657             endif
2658     
2659             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2660                     '** global_all_sum_3i: size(lbuf,2).ne.size(gbuf,2) ', &
2661                     size(lbuf,2), size(gbuf,2) )
2662     
2663             call assert( size(lbuf,3).eq.size(gbuf,3),  &
2664                     '** global_all_sum_3i: size(lbuf,3).ne.size(gbuf,3) ', &
2665                     size(lbuf,3), size(gbuf,3) )
2666     
2667             do k=lbound(lbuf,3),ubound(lbuf,3)
2668             do j=lbound(lbuf,2),ubound(lbuf,2)
2669               call global_all_sum_1i( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
2670             enddo
2671             enddo
2672     
2673             return
2674             end subroutine global_all_sum_3i
2675     
2676             subroutine global_all_sum_0r( lbuf, gbuf, mroot, idebug )
2677             real, intent(in) :: lbuf
2678             real, intent(out) :: gbuf
2679             integer, optional, intent(in) :: mroot, idebug
2680     
2681             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2682     
2683             if (.not. present(mroot)) then
2684                lroot = 0
2685             else
2686                lroot = mroot
2687             endif
2688     
2689             if (.not. present(idebug)) then
2690                lidebug = 0
2691             else
2692                lidebug = idebug
2693             endif
2694     
2695             recvtype = MPI_REAL
2696             sendtype = recvtype
2697     
2698             sendcnt = 1
2699     
2700             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_SUM, &
2701                               MPI_COMM_WORLD, ierr )
2702             call MPI_Check( 'global_all_sum_0r:MPI_Allreduce', ierr )
2703     
2704     
2705             return
2706             end subroutine global_all_sum_0r
2707     
2708     
2709             subroutine global_all_sum_1r( lbuf, gbuf, mroot, idebug )
2710             real, intent(in), dimension(:) :: lbuf
2711             real, intent(out), dimension(:) :: gbuf
2712             integer, optional, intent(in) :: mroot, idebug
2713     
2714             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2715     
2716             if (.not. present(mroot)) then
2717                lroot = 0
2718             else
2719                lroot = mroot
2720             endif
2721     
2722             if (.not. present(idebug)) then
2723                lidebug = 0
2724             else
2725                lidebug = idebug
2726             endif
2727     
2728             recvtype = MPI_REAL
2729             sendtype = recvtype
2730     
2731             sendcnt = size(lbuf)
2732     
2733             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_SUM, &
2734                                 MPI_COMM_WORLD, ierr )
2735             call MPI_Check( 'global_all_sum_1r:MPI_Allreduce', ierr )
2736     
2737             return
2738             end subroutine global_all_sum_1r
2739     
2740             subroutine global_all_sum_2r( lbuf, gbuf, mroot, idebug )
2741             real, intent(in), dimension(:,:) :: lbuf
2742             real, intent(out), dimension(:,:) :: gbuf
2743             integer, optional, intent(in) :: mroot, idebug
2744     
2745             integer :: i,j,lroot, lidebug
2746     
2747             if (.not. present(mroot)) then
2748                lroot = 0
2749             else
2750                lroot = mroot
2751             endif
2752     
2753             if (.not. present(idebug)) then
2754                lidebug = 0
2755             else
2756                lidebug = idebug
2757             endif
2758     
2759             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2760                     '** global_all_sum_2r: size(lbuf,2).ne.size(gbuf,2) ', &
2761                     size(lbuf,2), size(gbuf,2) )
2762     
2763             do j=lbound(lbuf,2),ubound(lbuf,2)
2764               call global_all_sum_1r( lbuf(:,j), gbuf(:,j), lroot, lidebug )
2765             enddo
2766     
2767             return
2768             end subroutine global_all_sum_2r
2769     
2770             subroutine global_all_sum_3r( lbuf, gbuf, mroot, idebug )
2771             real, intent(in), dimension(:,:,:) :: lbuf
2772             real, intent(out), dimension(:,:,:) :: gbuf
2773             integer, optional, intent(in) :: mroot, idebug
2774     
2775             integer :: j,k,lroot, lidebug
2776     
2777             if (.not. present(mroot)) then
2778                lroot = 0
2779             else
2780                lroot = mroot
2781             endif
2782     
2783             if (.not. present(idebug)) then
2784                lidebug = 0
2785             else
2786                lidebug = idebug
2787             endif
2788     
2789             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2790                     '** global_all_sum_3i: size(lbuf,2).ne.size(gbuf,2) ', &
2791                     size(lbuf,2), size(gbuf,2) )
2792     
2793             call assert( size(lbuf,3).eq.size(gbuf,3),  &
2794                     '** global_all_sum_3i: size(lbuf,3).ne.size(gbuf,3) ', &
2795                     size(lbuf,3), size(gbuf,3) )
2796     
2797             do k=lbound(lbuf,3),ubound(lbuf,3)
2798             do j=lbound(lbuf,2),ubound(lbuf,2)
2799               call global_all_sum_1r( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
2800             enddo
2801             enddo
2802     
2803             return
2804             end subroutine global_all_sum_3r
2805     
2806             subroutine global_all_sum_0d( lbuf, gbuf, mroot, idebug )
2807             double precision, intent(in) :: lbuf
2808             double precision, intent(out) :: gbuf
2809             integer, optional, intent(in) :: mroot, idebug
2810     
2811             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2812     
2813             if (.not. present(mroot)) then
2814                lroot = 0
2815             else
2816                lroot = mroot
2817             endif
2818     
2819             if (.not. present(idebug)) then
2820                lidebug = 0
2821             else
2822                lidebug = idebug
2823             endif
2824     
2825             recvtype = MPI_DOUBLE_PRECISION
2826             sendtype = recvtype
2827     
2828             sendcnt = 1
2829     
2830             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_SUM, &
2831                               MPI_COMM_WORLD, ierr )
2832             call MPI_Check( 'global_all_sum_0d:MPI_Allreduce', ierr )
2833     
2834             return
2835             end subroutine global_all_sum_0d
2836     
2837     
2838             subroutine global_all_sum_1d( lbuf, gbuf, mroot, idebug )
2839             double precision, intent(in), dimension(:) :: lbuf
2840             double precision, intent(out), dimension(:) :: gbuf
2841             integer, optional, intent(in) :: mroot, idebug
2842     
2843             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2844     
2845             if (.not. present(mroot)) then
2846                lroot = 0
2847             else
2848                lroot = mroot
2849             endif
2850     
2851             if (.not. present(idebug)) then
2852                lidebug = 0
2853             else
2854                lidebug = idebug
2855             endif
2856     
2857             recvtype = MPI_DOUBLE_PRECISION
2858             sendtype = recvtype
2859     
2860             sendcnt = size(lbuf)
2861     
2862             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype,  MPI_SUM, &
2863                               MPI_COMM_WORLD, ierr )
2864             call MPI_Check( 'global_all_sum_1d:MPI_Allreduce', ierr )
2865     
2866             return
2867             end subroutine global_all_sum_1d
2868     
2869             subroutine global_all_sum_2d( lbuf, gbuf, mroot, idebug )
2870             double precision, intent(in), dimension(:,:) :: lbuf
2871             double precision, intent(out), dimension(:,:) :: gbuf
2872             integer, optional, intent(in) :: mroot, idebug
2873     
2874             integer :: i,j,lroot, lidebug
2875     
2876             if (.not. present(mroot)) then
2877                lroot = 0
2878             else
2879                lroot = mroot
2880             endif
2881     
2882             if (.not. present(idebug)) then
2883                lidebug = 0
2884             else
2885                lidebug = idebug
2886             endif
2887     
2888             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2889                     '** global_all_sum_2d: size(lbuf,2).ne.size(gbuf,2) ', &
2890                     size(lbuf,2), size(gbuf,2) )
2891     
2892             do j=lbound(lbuf,2),ubound(lbuf,2)
2893               call global_all_sum_1d( lbuf(:,j), gbuf(:,j), lroot, lidebug )
2894             enddo
2895     
2896             return
2897             end subroutine global_all_sum_2d
2898     
2899             subroutine global_all_sum_3d( lbuf, gbuf, mroot, idebug )
2900             double precision, intent(in), dimension(:,:,:) :: lbuf
2901             double precision, intent(out), dimension(:,:,:) :: gbuf
2902             integer, optional, intent(in) :: mroot, idebug
2903     
2904             integer :: j,k,lroot, lidebug
2905     
2906             if (.not. present(mroot)) then
2907                lroot = 0
2908             else
2909                lroot = mroot
2910             endif
2911     
2912             if (.not. present(idebug)) then
2913                lidebug = 0
2914             else
2915                lidebug = idebug
2916             endif
2917     
2918             call assert( size(lbuf,2).eq.size(gbuf,2),  &
2919                     '** global_all_sum_3i: size(lbuf,2).ne.size(gbuf,2) ', &
2920                     size(lbuf,2), size(gbuf,2) )
2921     
2922             call assert( size(lbuf,3).eq.size(gbuf,3),  &
2923                     '** global_all_sum_3i: size(lbuf,3).ne.size(gbuf,3) ', &
2924                     size(lbuf,3), size(gbuf,3) )
2925     
2926             do k=lbound(lbuf,3),ubound(lbuf,3)
2927             do j=lbound(lbuf,2),ubound(lbuf,2)
2928               call global_all_sum_1d( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
2929             enddo
2930             enddo
2931     
2932             return
2933             end subroutine global_all_sum_3d
2934     
2935             subroutine global_min_0i( lbuf, gbuf, mroot, idebug )
2936             integer, intent(in) :: lbuf
2937             integer, intent(out) :: gbuf
2938             integer, optional, intent(in) :: mroot, idebug
2939     
2940             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2941     
2942             if (.not. present(mroot)) then
2943                lroot = 0
2944             else
2945                lroot = mroot
2946             endif
2947     
2948             if (.not. present(idebug)) then
2949                lidebug = 0
2950             else
2951                lidebug = idebug
2952             endif
2953     
2954             recvtype = MPI_INTEGER
2955             sendtype = recvtype
2956     
2957             sendcnt = 1
2958     
2959             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MIN, &
2960                               lroot, MPI_COMM_WORLD, ierr )
2961             call MPI_Check( 'global_min_0i:MPI_Reduce', ierr )
2962     
2963             return
2964             end subroutine global_min_0i
2965     
2966     
2967             subroutine global_min_1i( lbuf, gbuf, mroot, idebug )
2968             integer, intent(in), dimension(:) :: lbuf
2969             integer, intent(out), dimension(:) :: gbuf
2970             integer, optional, intent(in) :: mroot, idebug
2971     
2972             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
2973     
2974             if (.not. present(mroot)) then
2975                lroot = 0
2976             else
2977                lroot = mroot
2978             endif
2979     
2980             if (.not. present(idebug)) then
2981                lidebug = 0
2982             else
2983                lidebug = idebug
2984             endif
2985     
2986             recvtype = MPI_INTEGER
2987             sendtype = recvtype
2988     
2989             sendcnt = size(lbuf)
2990     
2991             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MIN, &
2992                               lroot, MPI_COMM_WORLD, ierr )
2993             call MPI_Check( 'global_min_1i:MPI_Reduce', ierr )
2994     
2995             return
2996             end subroutine global_min_1i
2997     
2998             subroutine global_min_2i( lbuf, gbuf, mroot, idebug )
2999             integer, intent(in), dimension(:,:) :: lbuf
3000             integer, intent(out), dimension(:,:) :: gbuf
3001             integer, optional, intent(in) :: mroot, idebug
3002     
3003             integer :: i,j,lroot, lidebug
3004     
3005             if (.not. present(mroot)) then
3006                lroot = 0
3007             else
3008                lroot = mroot
3009             endif
3010     
3011             if (.not. present(idebug)) then
3012                lidebug = 0
3013             else
3014                lidebug = idebug
3015             endif
3016     
3017             if(myPE.eq.lroot) then
3018             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3019                     '** global_min_2i: size(lbuf,2).ne.size(gbuf,2) ', &
3020                     size(lbuf,2), size(gbuf,2) )
3021             endif
3022     
3023             do j=lbound(lbuf,2),ubound(lbuf,2)
3024               call global_min_1i( lbuf(:,j), gbuf(:,j), lroot, lidebug )
3025             enddo
3026     
3027             return
3028             end subroutine global_min_2i
3029     
3030             subroutine global_min_3i( lbuf, gbuf, mroot, idebug )
3031             integer, intent(in), dimension(:,:,:) :: lbuf
3032             integer, intent(out), dimension(:,:,:) :: gbuf
3033             integer, optional, intent(in) :: mroot, idebug
3034     
3035             integer :: j,k,lroot, lidebug
3036     
3037             if (.not. present(mroot)) then
3038                lroot = 0
3039             else
3040                lroot = mroot
3041             endif
3042     
3043             if (.not. present(idebug)) then
3044                lidebug = 0
3045             else
3046                lidebug = idebug
3047             endif
3048     
3049             if(myPE.eq.lroot) then
3050             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3051                     '** global_min_3i: size(lbuf,2).ne.size(gbuf,2) ', &
3052                     size(lbuf,2), size(gbuf,2) )
3053     
3054             call assert( size(lbuf,3).eq.size(gbuf,3),  &
3055                     '** global_min_3i: size(lbuf,3).ne.size(gbuf,3) ', &
3056                     size(lbuf,3), size(gbuf,3) )
3057             endif
3058     
3059             do k=lbound(lbuf,3),ubound(lbuf,3)
3060             do j=lbound(lbuf,2),ubound(lbuf,2)
3061               call global_min_1i( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
3062             enddo
3063             enddo
3064     
3065             return
3066             end subroutine global_min_3i
3067     
3068             subroutine global_min_0r( lbuf, gbuf, mroot, idebug )
3069             real, intent(in) :: lbuf
3070             real, intent(out) :: gbuf
3071             integer, optional, intent(in) :: mroot, idebug
3072     
3073             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3074     
3075             if (.not. present(mroot)) then
3076                lroot = 0
3077             else
3078                lroot = mroot
3079             endif
3080     
3081             if (.not. present(idebug)) then
3082                lidebug = 0
3083             else
3084                lidebug = idebug
3085             endif
3086     
3087             recvtype = MPI_REAL
3088             sendtype = recvtype
3089     
3090             sendcnt = 1
3091     
3092             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MIN, &
3093                               lroot, MPI_COMM_WORLD, ierr )
3094             call MPI_Check( 'global_min_0r:MPI_Reduce', ierr )
3095     
3096             return
3097             end subroutine global_min_0r
3098     
3099     
3100             subroutine global_min_1r( lbuf, gbuf, mroot, idebug )
3101             real, intent(in), dimension(:) :: lbuf
3102             real, intent(out), dimension(:) :: gbuf
3103             integer, optional, intent(in) :: mroot, idebug
3104     
3105             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3106     
3107             if (.not. present(mroot)) then
3108                lroot = 0
3109             else
3110                lroot = mroot
3111             endif
3112     
3113             if (.not. present(idebug)) then
3114                lidebug = 0
3115             else
3116                lidebug = idebug
3117             endif
3118     
3119             recvtype = MPI_REAL
3120             sendtype = recvtype
3121     
3122             sendcnt = size(lbuf)
3123     
3124             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MIN, &
3125                               lroot, MPI_COMM_WORLD, ierr )
3126             call MPI_Check( 'global_min_1r:MPI_Reduce', ierr )
3127     
3128             return
3129             end subroutine global_min_1r
3130     
3131             subroutine global_min_2r( lbuf, gbuf, mroot, idebug )
3132             real, intent(in), dimension(:,:) :: lbuf
3133             real, intent(out), dimension(:,:) :: gbuf
3134             integer, optional, intent(in) :: mroot, idebug
3135     
3136             integer :: i,j,lroot, lidebug
3137     
3138             if (.not. present(mroot)) then
3139                lroot = 0
3140             else
3141                lroot = mroot
3142             endif
3143     
3144             if (.not. present(idebug)) then
3145                lidebug = 0
3146             else
3147                lidebug = idebug
3148             endif
3149     
3150             if(myPE.eq.lroot) then
3151             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3152                     '** global_min_2r: size(lbuf,2).ne.size(gbuf,2) ', &
3153                     size(lbuf,2), size(gbuf,2) )
3154             endif
3155     
3156             do j=lbound(lbuf,2),ubound(lbuf,2)
3157               call global_min_1r( lbuf(:,j), gbuf(:,j), lroot, lidebug )
3158             enddo
3159     
3160             return
3161             end subroutine global_min_2r
3162     
3163             subroutine global_min_3r( lbuf, gbuf, mroot, idebug )
3164             real, intent(in), dimension(:,:,:) :: lbuf
3165             real, intent(out), dimension(:,:,:) :: gbuf
3166             integer, optional, intent(in) :: mroot, idebug
3167     
3168             integer :: j,k,lroot, lidebug
3169     
3170             if (.not. present(mroot)) then
3171                lroot = 0
3172             else
3173                lroot = mroot
3174             endif
3175     
3176             if (.not. present(idebug)) then
3177                lidebug = 0
3178             else
3179                lidebug = idebug
3180             endif
3181     
3182             if(myPE.eq.lroot) then
3183             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3184                     '** global_min_3i: size(lbuf,2).ne.size(gbuf,2) ', &
3185                     size(lbuf,2), size(gbuf,2) )
3186     
3187             call assert( size(lbuf,3).eq.size(gbuf,3),  &
3188                     '** global_min_3i: size(lbuf,3).ne.size(gbuf,3) ', &
3189                     size(lbuf,3), size(gbuf,3) )
3190             endif
3191     
3192             do k=lbound(lbuf,3),ubound(lbuf,3)
3193             do j=lbound(lbuf,2),ubound(lbuf,2)
3194               call global_min_1r( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
3195             enddo
3196             enddo
3197     
3198             return
3199             end subroutine global_min_3r
3200     
3201             subroutine global_min_0d( lbuf, gbuf, mroot, idebug )
3202             double precision, intent(in) :: lbuf
3203             double precision, intent(out) :: gbuf
3204             integer, optional, intent(in) :: mroot, idebug
3205     
3206             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3207     
3208             if (.not. present(mroot)) then
3209                lroot = 0
3210             else
3211                lroot = mroot
3212             endif
3213     
3214             if (.not. present(idebug)) then
3215                lidebug = 0
3216             else
3217                lidebug = idebug
3218             endif
3219     
3220             recvtype = MPI_DOUBLE_PRECISION
3221             sendtype = recvtype
3222     
3223             sendcnt = 1
3224     
3225             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MIN, &
3226                               lroot, MPI_COMM_WORLD, ierr )
3227             call MPI_Check( 'global_min_0d:MPI_Reduce', ierr )
3228     
3229             return
3230             end subroutine global_min_0d
3231     
3232     
3233             subroutine global_min_1d( lbuf, gbuf, mroot, idebug )
3234             double precision, intent(in), dimension(:) :: lbuf
3235             double precision, intent(out), dimension(:) :: gbuf
3236             integer, optional, intent(in) :: mroot, idebug
3237     
3238             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3239     
3240             if (.not. present(mroot)) then
3241                lroot = 0
3242             else
3243                lroot = mroot
3244             endif
3245     
3246             if (.not. present(idebug)) then
3247                lidebug = 0
3248             else
3249                lidebug = idebug
3250             endif
3251     
3252             recvtype = MPI_DOUBLE_PRECISION
3253             sendtype = recvtype
3254     
3255             sendcnt = size(lbuf)
3256     
3257             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MIN, &
3258                               lroot, MPI_COMM_WORLD, ierr )
3259             call MPI_Check( 'global_min_1d:MPI_Reduce', ierr )
3260     
3261             return
3262             end subroutine global_min_1d
3263     
3264             subroutine global_min_2d( lbuf, gbuf, mroot, idebug )
3265             double precision, intent(in), dimension(:,:) :: lbuf
3266             double precision, intent(out), dimension(:,:) :: gbuf
3267             integer, optional, intent(in) :: mroot, idebug
3268     
3269             integer :: i,j,lroot, lidebug
3270     
3271             if (.not. present(mroot)) then
3272                lroot = 0
3273             else
3274                lroot = mroot
3275             endif
3276     
3277             if (.not. present(idebug)) then
3278                lidebug = 0
3279             else
3280                lidebug = idebug
3281             endif
3282     
3283             if(myPE.eq.lroot) then
3284             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3285                     '** global_min_2d: size(lbuf,2).ne.size(gbuf,2) ', &
3286                     size(lbuf,2), size(gbuf,2) )
3287             endif
3288     
3289             do j=lbound(lbuf,2),ubound(lbuf,2)
3290               call global_min_1d( lbuf(:,j), gbuf(:,j), lroot, lidebug )
3291             enddo
3292     
3293             return
3294             end subroutine global_min_2d
3295     
3296             subroutine global_min_3d( lbuf, gbuf, mroot, idebug )
3297             double precision, intent(in), dimension(:,:,:) :: lbuf
3298             double precision, intent(out), dimension(:,:,:) :: gbuf
3299             integer, optional, intent(in) :: mroot, idebug
3300     
3301             integer :: j,k,lroot, lidebug
3302     
3303             if (.not. present(mroot)) then
3304                lroot = 0
3305             else
3306                lroot = mroot
3307             endif
3308     
3309             if (.not. present(idebug)) then
3310                lidebug = 0
3311             else
3312                lidebug = idebug
3313             endif
3314     
3315             if(myPE.eq.lroot) then
3316             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3317                     '** global_min_3i: size(lbuf,2).ne.size(gbuf,2) ', &
3318                     size(lbuf,2), size(gbuf,2) )
3319     
3320             call assert( size(lbuf,3).eq.size(gbuf,3),  &
3321                     '** global_min_3i: size(lbuf,3).ne.size(gbuf,3) ', &
3322                     size(lbuf,3), size(gbuf,3) )
3323             endif
3324     
3325             do k=lbound(lbuf,3),ubound(lbuf,3)
3326             do j=lbound(lbuf,2),ubound(lbuf,2)
3327               call global_min_1d( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
3328             enddo
3329             enddo
3330     
3331             return
3332             end subroutine global_min_3d
3333     
3334             subroutine global_all_min_onevar_0d( gbuf )
3335             doubleprecision, intent(inout) :: gbuf
3336             doubleprecision :: lbuf
3337     
3338             lbuf = gbuf
3339             call global_all_min_0d( lbuf, gbuf )
3340             return
3341             end subroutine global_all_min_onevar_0d
3342     
3343     
3344             subroutine global_all_min_onevar_1d( gbuf )
3345             doubleprecision, dimension(:), intent(inout) :: gbuf
3346             doubleprecision, dimension(size(gbuf)) :: lbuf
3347     
3348             lbuf = gbuf
3349             call global_all_min_1d( lbuf, gbuf )
3350             return
3351             end subroutine global_all_min_onevar_1d
3352     
3353             subroutine global_all_min_onevar_2d( gbuf )
3354             doubleprecision, dimension(:,:), intent(inout) :: gbuf
3355             doubleprecision, dimension(size(gbuf,1),size(gbuf,2)) :: lbuf
3356     
3357             lbuf = gbuf
3358             call global_all_min_2d( lbuf, gbuf )
3359             return
3360             end subroutine global_all_min_onevar_2d
3361     
3362     
3363             subroutine global_all_min_onevar_3d( gbuf )
3364             doubleprecision, dimension(:,:,:), intent(inout) :: gbuf
3365             doubleprecision, dimension(size(gbuf,1),size(gbuf,2),size(gbuf,3)) :: lbuf
3366     
3367             lbuf = gbuf
3368             call global_all_min_3d( lbuf, gbuf )
3369             return
3370             end subroutine global_all_min_onevar_3d
3371     
3372     
3373     
3374     
3375             subroutine global_all_min_onevar_0i( gbuf )
3376             integer, intent(inout) :: gbuf
3377             integer :: lbuf
3378     
3379             lbuf = gbuf
3380             call global_all_min_0i( lbuf, gbuf )
3381             return
3382             end subroutine global_all_min_onevar_0i
3383     
3384     
3385             subroutine global_all_min_onevar_1i( gbuf )
3386             integer, dimension(:), intent(inout) :: gbuf
3387             integer, dimension(size(gbuf)) :: lbuf
3388     
3389             lbuf = gbuf
3390             call global_all_min_1i( lbuf, gbuf )
3391             return
3392             end subroutine global_all_min_onevar_1i
3393     
3394             subroutine global_all_min_onevar_2i( gbuf )
3395             integer, dimension(:,:), intent(inout) :: gbuf
3396             integer, dimension(size(gbuf,1),size(gbuf,2)) :: lbuf
3397     
3398             lbuf = gbuf
3399             call global_all_min_2i( lbuf, gbuf )
3400             return
3401             end subroutine global_all_min_onevar_2i
3402     
3403     
3404             subroutine global_all_min_onevar_3i( gbuf )
3405             integer, dimension(:,:,:), intent(inout) :: gbuf
3406             integer, dimension(size(gbuf,1),size(gbuf,2),size(gbuf,3)) :: lbuf
3407     
3408             lbuf = gbuf
3409             call global_all_min_3i( lbuf, gbuf )
3410             return
3411             end subroutine global_all_min_onevar_3i
3412     
3413             subroutine global_all_min_onevar_0r( gbuf )
3414             real, intent(inout) :: gbuf
3415             real :: lbuf
3416     
3417             lbuf = gbuf
3418             call global_all_min_0r( lbuf, gbuf )
3419             return
3420             end subroutine global_all_min_onevar_0r
3421     
3422     
3423             subroutine global_all_min_onevar_1r( gbuf )
3424             real, dimension(:), intent(inout) :: gbuf
3425             real, dimension(size(gbuf)) :: lbuf
3426     
3427             lbuf = gbuf
3428             call global_all_min_1r( lbuf, gbuf )
3429             return
3430             end subroutine global_all_min_onevar_1r
3431     
3432             subroutine global_all_min_onevar_2r( gbuf )
3433             real, dimension(:,:), intent(inout) :: gbuf
3434             real, dimension(size(gbuf,1),size(gbuf,2)) :: lbuf
3435     
3436             lbuf = gbuf
3437             call global_all_min_2r( lbuf, gbuf )
3438             return
3439             end subroutine global_all_min_onevar_2r
3440     
3441     
3442     
3443             subroutine global_all_min_onevar_3r( gbuf )
3444             real, dimension(:,:,:), intent(inout) :: gbuf
3445             real, dimension(size(gbuf,1),size(gbuf,2),size(gbuf,3)) :: lbuf
3446     
3447             lbuf = gbuf
3448             call global_all_min_3r( lbuf, gbuf )
3449             return
3450             end subroutine global_all_min_onevar_3r
3451     
3452     
3453             subroutine global_all_min_0i( lbuf, gbuf, mroot, idebug )
3454             integer, intent(in) :: lbuf
3455             integer, intent(out) :: gbuf
3456             integer, optional, intent(in) :: mroot, idebug
3457     
3458             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3459     
3460             if (.not. present(mroot)) then
3461                lroot = 0
3462             else
3463                lroot = mroot
3464             endif
3465     
3466             if (.not. present(idebug)) then
3467                lidebug = 0
3468             else
3469                lidebug = idebug
3470             endif
3471     
3472             recvtype = MPI_INTEGER
3473             sendtype = recvtype
3474     
3475             sendcnt = 1
3476     
3477             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_MIN, &
3478                               MPI_COMM_WORLD, ierr )
3479             call MPI_Check( 'global_all_min_0i:MPI_Allreduce', ierr )
3480     
3481             return
3482             end subroutine global_all_min_0i
3483     
3484     
3485             subroutine global_all_min_1i( lbuf, gbuf, mroot, idebug )
3486             integer, intent(in), dimension(:) :: lbuf
3487             integer, intent(out), dimension(:) :: gbuf
3488             integer, optional, intent(in) :: mroot, idebug
3489     
3490             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3491     
3492             if (.not. present(mroot)) then
3493                lroot = 0
3494             else
3495                lroot = mroot
3496             endif
3497     
3498             if (.not. present(idebug)) then
3499                lidebug = 0
3500             else
3501                lidebug = idebug
3502             endif
3503     
3504             recvtype = MPI_INTEGER
3505             sendtype = recvtype
3506     
3507             sendcnt = size(lbuf)
3508     
3509             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_MIN, &
3510                               MPI_COMM_WORLD, ierr )
3511             call MPI_Check( 'global_all_min_1i:MPI_Allreduce', ierr )
3512     
3513             return
3514             end subroutine global_all_min_1i
3515     
3516             subroutine global_all_min_2i( lbuf, gbuf, mroot, idebug )
3517             integer, intent(in), dimension(:,:) :: lbuf
3518             integer, intent(out), dimension(:,:) :: gbuf
3519             integer, optional, intent(in) :: mroot, idebug
3520     
3521             integer :: i,j,lroot, lidebug
3522     
3523             if (.not. present(mroot)) then
3524                lroot = 0
3525             else
3526                lroot = mroot
3527             endif
3528     
3529             if (.not. present(idebug)) then
3530                lidebug = 0
3531             else
3532                lidebug = idebug
3533             endif
3534     
3535             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3536                     '** global_all_min_2i: size(lbuf,2).ne.size(gbuf,2) ', &
3537                     size(lbuf,2), size(gbuf,2) )
3538     
3539             do j=lbound(lbuf,2),ubound(lbuf,2)
3540               call global_all_min_1i( lbuf(:,j), gbuf(:,j), lroot, lidebug )
3541             enddo
3542     
3543             return
3544             end subroutine global_all_min_2i
3545     
3546             subroutine global_all_min_3i( lbuf, gbuf, mroot, idebug )
3547             integer, intent(in), dimension(:,:,:) :: lbuf
3548             integer, intent(out), dimension(:,:,:) :: gbuf
3549             integer, optional, intent(in) :: mroot, idebug
3550     
3551             integer :: j,k,lroot, lidebug
3552     
3553             if (.not. present(mroot)) then
3554                lroot = 0
3555             else
3556                lroot = mroot
3557             endif
3558     
3559             if (.not. present(idebug)) then
3560                lidebug = 0
3561             else
3562                lidebug = idebug
3563             endif
3564     
3565             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3566                     '** global_all_min_3i: size(lbuf,2).ne.size(gbuf,2) ', &
3567                     size(lbuf,2), size(gbuf,2) )
3568     
3569             call assert( size(lbuf,3).eq.size(gbuf,3),  &
3570                     '** global_all_min_3i: size(lbuf,3).ne.size(gbuf,3) ', &
3571                     size(lbuf,3), size(gbuf,3) )
3572     
3573             do k=lbound(lbuf,3),ubound(lbuf,3)
3574             do j=lbound(lbuf,2),ubound(lbuf,2)
3575               call global_all_min_1i( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
3576             enddo
3577             enddo
3578     
3579             return
3580             end subroutine global_all_min_3i
3581     
3582             subroutine global_all_min_0r( lbuf, gbuf, mroot, idebug )
3583             real, intent(in) :: lbuf
3584             real, intent(out) :: gbuf
3585             integer, optional, intent(in) :: mroot, idebug
3586     
3587             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3588     
3589             if (.not. present(mroot)) then
3590                lroot = 0
3591             else
3592                lroot = mroot
3593             endif
3594     
3595             if (.not. present(idebug)) then
3596                lidebug = 0
3597             else
3598                lidebug = idebug
3599             endif
3600     
3601             recvtype = MPI_REAL
3602             sendtype = recvtype
3603     
3604             sendcnt = 1
3605     
3606             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_MIN, &
3607                               MPI_COMM_WORLD, ierr )
3608             call MPI_Check( 'global_all_min_0r:MPI_Allreduce', ierr )
3609     
3610     
3611             return
3612             end subroutine global_all_min_0r
3613     
3614     
3615             subroutine global_all_min_1r( lbuf, gbuf, mroot, idebug )
3616             real, intent(in), dimension(:) :: lbuf
3617             real, intent(out), dimension(:) :: gbuf
3618             integer, optional, intent(in) :: mroot, idebug
3619     
3620             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3621     
3622             if (.not. present(mroot)) then
3623                lroot = 0
3624             else
3625                lroot = mroot
3626             endif
3627     
3628             if (.not. present(idebug)) then
3629                lidebug = 0
3630             else
3631                lidebug = idebug
3632             endif
3633     
3634             recvtype = MPI_REAL
3635             sendtype = recvtype
3636     
3637             sendcnt = size(lbuf)
3638     
3639             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_MIN, &
3640                                 MPI_COMM_WORLD, ierr )
3641             call MPI_Check( 'global_all_min_1r:MPI_Allreduce', ierr )
3642     
3643             return
3644             end subroutine global_all_min_1r
3645     
3646             subroutine global_all_min_2r( lbuf, gbuf, mroot, idebug )
3647             real, intent(in), dimension(:,:) :: lbuf
3648             real, intent(out), dimension(:,:) :: gbuf
3649             integer, optional, intent(in) :: mroot, idebug
3650     
3651             integer :: i,j,lroot, lidebug
3652     
3653             if (.not. present(mroot)) then
3654                lroot = 0
3655             else
3656                lroot = mroot
3657             endif
3658     
3659             if (.not. present(idebug)) then
3660                lidebug = 0
3661             else
3662                lidebug = idebug
3663             endif
3664     
3665             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3666                     '** global_all_min_2r: size(lbuf,2).ne.size(gbuf,2) ', &
3667                     size(lbuf,2), size(gbuf,2) )
3668     
3669             do j=lbound(lbuf,2),ubound(lbuf,2)
3670               call global_all_min_1r( lbuf(:,j), gbuf(:,j), lroot, lidebug )
3671             enddo
3672     
3673             return
3674             end subroutine global_all_min_2r
3675     
3676             subroutine global_all_min_3r( lbuf, gbuf, mroot, idebug )
3677             real, intent(in), dimension(:,:,:) :: lbuf
3678             real, intent(out), dimension(:,:,:) :: gbuf
3679             integer, optional, intent(in) :: mroot, idebug
3680     
3681             integer :: j,k,lroot, lidebug
3682     
3683             if (.not. present(mroot)) then
3684                lroot = 0
3685             else
3686                lroot = mroot
3687             endif
3688     
3689             if (.not. present(idebug)) then
3690                lidebug = 0
3691             else
3692                lidebug = idebug
3693             endif
3694     
3695             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3696                     '** global_all_min_3i: size(lbuf,2).ne.size(gbuf,2) ', &
3697                     size(lbuf,2), size(gbuf,2) )
3698     
3699             call assert( size(lbuf,3).eq.size(gbuf,3),  &
3700                     '** global_all_min_3i: size(lbuf,3).ne.size(gbuf,3) ', &
3701                     size(lbuf,3), size(gbuf,3) )
3702     
3703             do k=lbound(lbuf,3),ubound(lbuf,3)
3704             do j=lbound(lbuf,2),ubound(lbuf,2)
3705               call global_all_min_1r( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
3706             enddo
3707             enddo
3708     
3709             return
3710             end subroutine global_all_min_3r
3711     
3712             subroutine global_all_min_0d( lbuf, gbuf, mroot, idebug )
3713             double precision, intent(in) :: lbuf
3714             double precision, intent(out) :: gbuf
3715             integer, optional, intent(in) :: mroot, idebug
3716     
3717             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3718     
3719             if (.not. present(mroot)) then
3720                lroot = 0
3721             else
3722                lroot = mroot
3723             endif
3724     
3725             if (.not. present(idebug)) then
3726                lidebug = 0
3727             else
3728                lidebug = idebug
3729             endif
3730     
3731             recvtype = MPI_DOUBLE_PRECISION
3732             sendtype = recvtype
3733     
3734             sendcnt = 1
3735     
3736             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_MIN, &
3737                               MPI_COMM_WORLD, ierr )
3738             call MPI_Check( 'global_all_min_0d:MPI_Allreduce', ierr )
3739     
3740             return
3741             end subroutine global_all_min_0d
3742     
3743     
3744             subroutine global_all_min_1d( lbuf, gbuf, mroot, idebug )
3745             double precision, intent(in), dimension(:) :: lbuf
3746             double precision, intent(out), dimension(:) :: gbuf
3747             integer, optional, intent(in) :: mroot, idebug
3748     
3749             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3750     
3751             if (.not. present(mroot)) then
3752                lroot = 0
3753             else
3754                lroot = mroot
3755             endif
3756     
3757             if (.not. present(idebug)) then
3758                lidebug = 0
3759             else
3760                lidebug = idebug
3761             endif
3762     
3763             recvtype = MPI_DOUBLE_PRECISION
3764             sendtype = recvtype
3765     
3766             sendcnt = size(lbuf)
3767     
3768             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MIN, &
3769                               MPI_COMM_WORLD, ierr )
3770             call MPI_Check( 'global_all_min_1d:MPI_Allreduce', ierr )
3771     
3772             return
3773             end subroutine global_all_min_1d
3774     
3775             subroutine global_all_min_2d( lbuf, gbuf, mroot, idebug )
3776             double precision, intent(in), dimension(:,:) :: lbuf
3777             double precision, intent(out), dimension(:,:) :: gbuf
3778             integer, optional, intent(in) :: mroot, idebug
3779     
3780             integer :: i,j,lroot, lidebug
3781     
3782             if (.not. present(mroot)) then
3783                lroot = 0
3784             else
3785                lroot = mroot
3786             endif
3787     
3788             if (.not. present(idebug)) then
3789                lidebug = 0
3790             else
3791                lidebug = idebug
3792             endif
3793     
3794             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3795                     '** global_all_min_2d: size(lbuf,2).ne.size(gbuf,2) ', &
3796                     size(lbuf,2), size(gbuf,2) )
3797     
3798             do j=lbound(lbuf,2),ubound(lbuf,2)
3799               call global_all_min_1d( lbuf(:,j), gbuf(:,j), lroot, lidebug )
3800             enddo
3801     
3802             return
3803             end subroutine global_all_min_2d
3804     
3805             subroutine global_all_min_3d( lbuf, gbuf, mroot, idebug )
3806             double precision, intent(in), dimension(:,:,:) :: lbuf
3807             double precision, intent(out), dimension(:,:,:) :: gbuf
3808             integer, optional, intent(in) :: mroot, idebug
3809     
3810             integer :: j,k,lroot, lidebug
3811     
3812             if (.not. present(mroot)) then
3813                lroot = 0
3814             else
3815                lroot = mroot
3816             endif
3817     
3818             if (.not. present(idebug)) then
3819                lidebug = 0
3820             else
3821                lidebug = idebug
3822             endif
3823     
3824             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3825                     '** global_all_min_3i: size(lbuf,2).ne.size(gbuf,2) ', &
3826                     size(lbuf,2), size(gbuf,2) )
3827     
3828             call assert( size(lbuf,3).eq.size(gbuf,3),  &
3829                     '** global_all_min_3i: size(lbuf,3).ne.size(gbuf,3) ', &
3830                     size(lbuf,3), size(gbuf,3) )
3831     
3832             do k=lbound(lbuf,3),ubound(lbuf,3)
3833             do j=lbound(lbuf,2),ubound(lbuf,2)
3834               call global_all_min_1d( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
3835             enddo
3836             enddo
3837     
3838             return
3839             end subroutine global_all_min_3d
3840     
3841             subroutine global_max_0i( lbuf, gbuf, mroot, idebug )
3842             integer, intent(in) :: lbuf
3843             integer, intent(out) :: gbuf
3844             integer, optional, intent(in) :: mroot, idebug
3845     
3846             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3847     
3848             if (.not. present(mroot)) then
3849                lroot = 0
3850             else
3851                lroot = mroot
3852             endif
3853     
3854             if (.not. present(idebug)) then
3855                lidebug = 0
3856             else
3857                lidebug = idebug
3858             endif
3859     
3860             recvtype = MPI_INTEGER
3861             sendtype = recvtype
3862     
3863             sendcnt = 1
3864     
3865             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MAX, &
3866                               lroot, MPI_COMM_WORLD, ierr )
3867             call MPI_Check( 'global_max_0i:MPI_Reduce', ierr )
3868     
3869             return
3870             end subroutine global_max_0i
3871     
3872     
3873             subroutine global_max_1i( lbuf, gbuf, mroot, idebug )
3874             integer, intent(in), dimension(:) :: lbuf
3875             integer, intent(out), dimension(:) :: gbuf
3876             integer, optional, intent(in) :: mroot, idebug
3877     
3878             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3879     
3880             if (.not. present(mroot)) then
3881                lroot = 0
3882             else
3883                lroot = mroot
3884             endif
3885     
3886             if (.not. present(idebug)) then
3887                lidebug = 0
3888             else
3889                lidebug = idebug
3890             endif
3891     
3892             recvtype = MPI_INTEGER
3893             sendtype = recvtype
3894     
3895             sendcnt = size(lbuf)
3896     
3897             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MAX, &
3898                               lroot, MPI_COMM_WORLD, ierr )
3899             call MPI_Check( 'global_max_1i:MPI_Reduce', ierr )
3900     
3901             return
3902             end subroutine global_max_1i
3903     
3904             subroutine global_max_2i( lbuf, gbuf, mroot, idebug )
3905             integer, intent(in), dimension(:,:) :: lbuf
3906             integer, intent(out), dimension(:,:) :: gbuf
3907             integer, optional, intent(in) :: mroot, idebug
3908     
3909             integer :: i,j,lroot, lidebug
3910     
3911             if (.not. present(mroot)) then
3912                lroot = 0
3913             else
3914                lroot = mroot
3915             endif
3916     
3917             if (.not. present(idebug)) then
3918                lidebug = 0
3919             else
3920                lidebug = idebug
3921             endif
3922     
3923             if(myPE.eq.lroot) then
3924             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3925                     '** global_max_2i: size(lbuf,2).ne.size(gbuf,2) ', &
3926                     size(lbuf,2), size(gbuf,2) )
3927             endif
3928     
3929             do j=lbound(lbuf,2),ubound(lbuf,2)
3930               call global_max_1i( lbuf(:,j), gbuf(:,j), lroot, lidebug )
3931             enddo
3932     
3933             return
3934             end subroutine global_max_2i
3935     
3936             subroutine global_max_3i( lbuf, gbuf, mroot, idebug )
3937             integer, intent(in), dimension(:,:,:) :: lbuf
3938             integer, intent(out), dimension(:,:,:) :: gbuf
3939             integer, optional, intent(in) :: mroot, idebug
3940     
3941             integer :: j,k,lroot, lidebug
3942     
3943             if (.not. present(mroot)) then
3944                lroot = 0
3945             else
3946                lroot = mroot
3947             endif
3948     
3949             if (.not. present(idebug)) then
3950                lidebug = 0
3951             else
3952                lidebug = idebug
3953             endif
3954     
3955             if(myPE.eq.lroot) then
3956             call assert( size(lbuf,2).eq.size(gbuf,2),  &
3957                     '** global_max_3i: size(lbuf,2).ne.size(gbuf,2) ', &
3958                     size(lbuf,2), size(gbuf,2) )
3959     
3960             call assert( size(lbuf,3).eq.size(gbuf,3),  &
3961                     '** global_max_3i: size(lbuf,3).ne.size(gbuf,3) ', &
3962                     size(lbuf,3), size(gbuf,3) )
3963             endif
3964     
3965             do k=lbound(lbuf,3),ubound(lbuf,3)
3966             do j=lbound(lbuf,2),ubound(lbuf,2)
3967               call global_max_1i( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
3968             enddo
3969             enddo
3970     
3971             return
3972             end subroutine global_max_3i
3973     
3974             subroutine global_max_0r( lbuf, gbuf, mroot, idebug )
3975             real, intent(in) :: lbuf
3976             real, intent(out) :: gbuf
3977             integer, optional, intent(in) :: mroot, idebug
3978     
3979             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
3980     
3981             if (.not. present(mroot)) then
3982                lroot = 0
3983             else
3984                lroot = mroot
3985             endif
3986     
3987             if (.not. present(idebug)) then
3988                lidebug = 0
3989             else
3990                lidebug = idebug
3991             endif
3992     
3993             recvtype = MPI_REAL
3994             sendtype = recvtype
3995     
3996             sendcnt = 1
3997     
3998             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MAX, &
3999                               lroot, MPI_COMM_WORLD, ierr )
4000             call MPI_Check( 'global_max_0r:MPI_Reduce', ierr )
4001     
4002             return
4003             end subroutine global_max_0r
4004     
4005     
4006             subroutine global_max_1r( lbuf, gbuf, mroot, idebug )
4007             real, intent(in), dimension(:) :: lbuf
4008             real, intent(out), dimension(:) :: gbuf
4009             integer, optional, intent(in) :: mroot, idebug
4010     
4011             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
4012     
4013             if (.not. present(mroot)) then
4014                lroot = 0
4015             else
4016                lroot = mroot
4017             endif
4018     
4019             if (.not. present(idebug)) then
4020                lidebug = 0
4021             else
4022                lidebug = idebug
4023             endif
4024     
4025             recvtype = MPI_REAL
4026             sendtype = recvtype
4027     
4028             sendcnt = size(lbuf)
4029     
4030             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MAX, &
4031                               lroot, MPI_COMM_WORLD, ierr )
4032             call MPI_Check( 'global_max_1r:MPI_Reduce', ierr )
4033     
4034             return
4035             end subroutine global_max_1r
4036     
4037             subroutine global_max_2r( lbuf, gbuf, mroot, idebug )
4038             real, intent(in), dimension(:,:) :: lbuf
4039             real, intent(out), dimension(:,:) :: gbuf
4040             integer, optional, intent(in) :: mroot, idebug
4041     
4042             integer :: i,j,lroot, lidebug
4043     
4044             if (.not. present(mroot)) then
4045                lroot = 0
4046             else
4047                lroot = mroot
4048             endif
4049     
4050             if (.not. present(idebug)) then
4051                lidebug = 0
4052             else
4053                lidebug = idebug
4054             endif
4055     
4056             if(myPE.eq.lroot) then
4057             call assert( size(lbuf,2).eq.size(gbuf,2),  &
4058                     '** global_max_2r: size(lbuf,2).ne.size(gbuf,2) ', &
4059                     size(lbuf,2), size(gbuf,2) )
4060             endif
4061     
4062             do j=lbound(lbuf,2),ubound(lbuf,2)
4063               call global_max_1r( lbuf(:,j), gbuf(:,j), lroot, lidebug )
4064             enddo
4065     
4066             return
4067             end subroutine global_max_2r
4068     
4069             subroutine global_max_3r( lbuf, gbuf, mroot, idebug )
4070             real, intent(in), dimension(:,:,:) :: lbuf
4071             real, intent(out), dimension(:,:,:) :: gbuf
4072             integer, optional, intent(in) :: mroot, idebug
4073     
4074             integer :: j,k,lroot, lidebug
4075     
4076             if (.not. present(mroot)) then
4077                lroot = 0
4078             else
4079                lroot = mroot
4080             endif
4081     
4082             if (.not. present(idebug)) then
4083                lidebug = 0
4084             else
4085                lidebug = idebug
4086             endif
4087     
4088             if(myPE.eq.lroot) then
4089             call assert( size(lbuf,2).eq.size(gbuf,2),  &
4090                     '** global_max_3i: size(lbuf,2).ne.size(gbuf,2) ', &
4091                     size(lbuf,2), size(gbuf,2) )
4092     
4093             call assert( size(lbuf,3).eq.size(gbuf,3),  &
4094                     '** global_max_3i: size(lbuf,3).ne.size(gbuf,3) ', &
4095                     size(lbuf,3), size(gbuf,3) )
4096             endif
4097     
4098             do k=lbound(lbuf,3),ubound(lbuf,3)
4099             do j=lbound(lbuf,2),ubound(lbuf,2)
4100               call global_max_1r( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
4101             enddo
4102             enddo
4103     
4104             return
4105             end subroutine global_max_3r
4106     
4107             subroutine global_max_0d( lbuf, gbuf, mroot, idebug )
4108             double precision, intent(in) :: lbuf
4109             double precision, intent(out) :: gbuf
4110             integer, optional, intent(in) :: mroot, idebug
4111     
4112             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
4113     
4114             if (.not. present(mroot)) then
4115                lroot = 0
4116             else
4117                lroot = mroot
4118             endif
4119     
4120             if (.not. present(idebug)) then
4121                lidebug = 0
4122             else
4123                lidebug = idebug
4124             endif
4125     
4126             recvtype = MPI_DOUBLE_PRECISION
4127             sendtype = recvtype
4128     
4129             sendcnt = 1
4130     
4131             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MAX, &
4132                               lroot, MPI_COMM_WORLD, ierr )
4133             call MPI_Check( 'global_max_0d:MPI_Reduce', ierr )
4134     
4135             return
4136             end subroutine global_max_0d
4137     
4138     
4139             subroutine global_max_1d( lbuf, gbuf, mroot, idebug )
4140             double precision, intent(in), dimension(:) :: lbuf
4141             double precision, intent(out), dimension(:) :: gbuf
4142             integer, optional, intent(in) :: mroot, idebug
4143     
4144             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
4145     
4146             if (.not. present(mroot)) then
4147                lroot = 0
4148             else
4149                lroot = mroot
4150             endif
4151     
4152             if (.not. present(idebug)) then
4153                lidebug = 0
4154             else
4155                lidebug = idebug
4156             endif
4157     
4158             recvtype = MPI_DOUBLE_PRECISION
4159             sendtype = recvtype
4160     
4161             sendcnt = size(lbuf)
4162     
4163             call MPI_Reduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MAX, &
4164                               lroot, MPI_COMM_WORLD, ierr )
4165             call MPI_Check( 'global_max_1d:MPI_Reduce', ierr )
4166     
4167             return
4168             end subroutine global_max_1d
4169     
4170             subroutine global_max_2d( lbuf, gbuf, mroot, idebug )
4171             double precision, intent(in), dimension(:,:) :: lbuf
4172             double precision, intent(out), dimension(:,:) :: gbuf
4173             integer, optional, intent(in) :: mroot, idebug
4174     
4175             integer :: i,j,lroot, lidebug
4176     
4177             if (.not. present(mroot)) then
4178                lroot = 0
4179             else
4180                lroot = mroot
4181             endif
4182     
4183             if (.not. present(idebug)) then
4184                lidebug = 0
4185             else
4186                lidebug = idebug
4187             endif
4188     
4189             if(myPE.eq.lroot) then
4190             call assert( size(lbuf,2).eq.size(gbuf,2),  &
4191                     '** global_max_2d: size(lbuf,2).ne.size(gbuf,2) ', &
4192                     size(lbuf,2), size(gbuf,2) )
4193             endif
4194     
4195             do j=lbound(lbuf,2),ubound(lbuf,2)
4196               call global_max_1d( lbuf(:,j), gbuf(:,j), lroot, lidebug )
4197             enddo
4198     
4199             return
4200             end subroutine global_max_2d
4201     
4202             subroutine global_max_3d( lbuf, gbuf, mroot, idebug )
4203             double precision, intent(in), dimension(:,:,:) :: lbuf
4204             double precision, intent(out), dimension(:,:,:) :: gbuf
4205             integer, optional, intent(in) :: mroot, idebug
4206     
4207             integer :: j,k,lroot, lidebug
4208     
4209             if (.not. present(mroot)) then
4210                lroot = 0
4211             else
4212                lroot = mroot
4213             endif
4214     
4215             if (.not. present(idebug)) then
4216                lidebug = 0
4217             else
4218                lidebug = idebug
4219             endif
4220     
4221             if(myPE.eq.lroot) then
4222             call assert( size(lbuf,2).eq.size(gbuf,2),  &
4223                     '** global_max_3i: size(lbuf,2).ne.size(gbuf,2) ', &
4224                     size(lbuf,2), size(gbuf,2) )
4225     
4226             call assert( size(lbuf,3).eq.size(gbuf,3),  &
4227                     '** global_max_3i: size(lbuf,3).ne.size(gbuf,3) ', &
4228                     size(lbuf,3), size(gbuf,3) )
4229             endif
4230     
4231             do k=lbound(lbuf,3),ubound(lbuf,3)
4232             do j=lbound(lbuf,2),ubound(lbuf,2)
4233               call global_max_1d( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
4234             enddo
4235             enddo
4236     
4237             return
4238             end subroutine global_max_3d
4239     
4240             subroutine global_all_max_onevar_0d( gbuf )
4241             doubleprecision, intent(inout) :: gbuf
4242             doubleprecision :: lbuf
4243     
4244             lbuf = gbuf
4245             call global_all_max_0d( lbuf, gbuf )
4246             return
4247             end subroutine global_all_max_onevar_0d
4248     
4249     
4250             subroutine global_all_max_onevar_1d( gbuf )
4251             doubleprecision, dimension(:), intent(inout) :: gbuf
4252             doubleprecision, dimension(size(gbuf)) :: lbuf
4253     
4254             lbuf = gbuf
4255             call global_all_max_1d( lbuf, gbuf )
4256             return
4257             end subroutine global_all_max_onevar_1d
4258     
4259             subroutine global_all_max_onevar_2d( gbuf )
4260             doubleprecision, dimension(:,:), intent(inout) :: gbuf
4261             doubleprecision, dimension(size(gbuf,1),size(gbuf,2)) :: lbuf
4262     
4263             lbuf = gbuf
4264             call global_all_max_2d( lbuf, gbuf )
4265             return
4266             end subroutine global_all_max_onevar_2d
4267     
4268     
4269             subroutine global_all_max_onevar_3d( gbuf )
4270             doubleprecision, dimension(:,:,:), intent(inout) :: gbuf
4271             doubleprecision, dimension(size(gbuf,1),size(gbuf,2),size(gbuf,3)) :: lbuf
4272     
4273             lbuf = gbuf
4274             call global_all_max_3d( lbuf, gbuf )
4275             return
4276             end subroutine global_all_max_onevar_3d
4277     
4278     
4279     
4280     
4281             subroutine global_all_max_onevar_0i( gbuf )
4282             integer, intent(inout) :: gbuf
4283             integer :: lbuf
4284     
4285             lbuf = gbuf
4286             call global_all_max_0i( lbuf, gbuf )
4287             return
4288             end subroutine global_all_max_onevar_0i
4289     
4290     
4291             subroutine global_all_max_onevar_1i( gbuf )
4292             integer, dimension(:), intent(inout) :: gbuf
4293             integer, dimension(size(gbuf)) :: lbuf
4294     
4295             lbuf = gbuf
4296             call global_all_max_1i( lbuf, gbuf )
4297             return
4298             end subroutine global_all_max_onevar_1i
4299     
4300             subroutine global_all_max_onevar_2i( gbuf )
4301             integer, dimension(:,:), intent(inout) :: gbuf
4302             integer, dimension(size(gbuf,1),size(gbuf,2)) :: lbuf
4303     
4304             lbuf = gbuf
4305             call global_all_max_2i( lbuf, gbuf )
4306             return
4307             end subroutine global_all_max_onevar_2i
4308     
4309     
4310             subroutine global_all_max_onevar_3i( gbuf )
4311             integer, dimension(:,:,:), intent(inout) :: gbuf
4312             integer, dimension(size(gbuf,1),size(gbuf,2),size(gbuf,3)) :: lbuf
4313     
4314             lbuf = gbuf
4315             call global_all_max_3i( lbuf, gbuf )
4316             return
4317             end subroutine global_all_max_onevar_3i
4318     
4319             subroutine global_all_max_onevar_0r( gbuf )
4320             real, intent(inout) :: gbuf
4321             real :: lbuf
4322     
4323             lbuf = gbuf
4324             call global_all_max_0r( lbuf, gbuf )
4325             return
4326             end subroutine global_all_max_onevar_0r
4327     
4328             subroutine global_all_max_onevar_1r( gbuf )
4329             real, dimension(:), intent(inout) :: gbuf
4330             real, dimension(size(gbuf)) :: lbuf
4331     
4332             lbuf = gbuf
4333             call global_all_max_1r( lbuf, gbuf )
4334             return
4335             end subroutine global_all_max_onevar_1r
4336     
4337             subroutine global_all_max_onevar_2r( gbuf )
4338             real, dimension(:,:), intent(inout) :: gbuf
4339             real, dimension(size(gbuf,1),size(gbuf,2)) :: lbuf
4340     
4341             lbuf = gbuf
4342             call global_all_max_2r( lbuf, gbuf )
4343             return
4344             end subroutine global_all_max_onevar_2r
4345     
4346     
4347             subroutine global_all_max_onevar_3r( gbuf )
4348             real, dimension(:,:,:), intent(inout) :: gbuf
4349             real, dimension(size(gbuf,1),size(gbuf,2),size(gbuf,3)) :: lbuf
4350     
4351             lbuf = gbuf
4352             call global_all_max_3r( lbuf, gbuf )
4353             return
4354             end subroutine global_all_max_onevar_3r
4355     
4356     
4357     
4358             subroutine global_all_max_0i( lbuf, gbuf, mroot, idebug )
4359             integer, intent(in) :: lbuf
4360             integer, intent(out) :: gbuf
4361             integer, optional, intent(in) :: mroot, idebug
4362     
4363             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
4364     
4365             if (.not. present(mroot)) then
4366                lroot = 0
4367             else
4368                lroot = mroot
4369             endif
4370     
4371             if (.not. present(idebug)) then
4372                lidebug = 0
4373             else
4374                lidebug = idebug
4375             endif
4376     
4377             recvtype = MPI_INTEGER
4378             sendtype = recvtype
4379     
4380             sendcnt = 1
4381     
4382             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_MAX, &
4383                               MPI_COMM_WORLD, ierr )
4384             call MPI_Check( 'global_all_max_0i:MPI_Allreduce', ierr )
4385     
4386             return
4387             end subroutine global_all_max_0i
4388     
4389     
4390             subroutine global_all_max_1i( lbuf, gbuf, mroot, idebug )
4391             integer, intent(in), dimension(:) :: lbuf
4392             integer, intent(out), dimension(:) :: gbuf
4393             integer, optional, intent(in) :: mroot, idebug
4394     
4395             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
4396     
4397             if (.not. present(mroot)) then
4398                lroot = 0
4399             else
4400                lroot = mroot
4401             endif
4402     
4403             if (.not. present(idebug)) then
4404                lidebug = 0
4405             else
4406                lidebug = idebug
4407             endif
4408     
4409             recvtype = MPI_INTEGER
4410             sendtype = recvtype
4411     
4412             sendcnt = size(lbuf)
4413     
4414             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_MAX, &
4415                               MPI_COMM_WORLD, ierr )
4416             call MPI_Check( 'global_all_max_1i:MPI_Allreduce', ierr )
4417     
4418             return
4419             end subroutine global_all_max_1i
4420     
4421             subroutine global_all_max_2i( lbuf, gbuf, mroot, idebug )
4422             integer, intent(in), dimension(:,:) :: lbuf
4423             integer, intent(out), dimension(:,:) :: gbuf
4424             integer, optional, intent(in) :: mroot, idebug
4425     
4426             integer :: i,j,lroot, lidebug
4427     
4428             if (.not. present(mroot)) then
4429                lroot = 0
4430             else
4431                lroot = mroot
4432             endif
4433     
4434             if (.not. present(idebug)) then
4435                lidebug = 0
4436             else
4437                lidebug = idebug
4438             endif
4439     
4440             call assert( size(lbuf,2).eq.size(gbuf,2),  &
4441                     '** global_all_max_2i: size(lbuf,2).ne.size(gbuf,2) ', &
4442                     size(lbuf,2), size(gbuf,2) )
4443     
4444             do j=lbound(lbuf,2),ubound(lbuf,2)
4445               call global_all_max_1i( lbuf(:,j), gbuf(:,j), lroot, lidebug )
4446             enddo
4447     
4448             return
4449             end subroutine global_all_max_2i
4450     
4451             subroutine global_all_max_3i( lbuf, gbuf, mroot, idebug )
4452             integer, intent(in), dimension(:,:,:) :: lbuf
4453             integer, intent(out), dimension(:,:,:) :: gbuf
4454             integer, optional, intent(in) :: mroot, idebug
4455     
4456             integer :: j,k,lroot, lidebug
4457     
4458             if (.not. present(mroot)) then
4459                lroot = 0
4460             else
4461                lroot = mroot
4462             endif
4463     
4464             if (.not. present(idebug)) then
4465                lidebug = 0
4466             else
4467                lidebug = idebug
4468             endif
4469     
4470             call assert( size(lbuf,2).eq.size(gbuf,2),  &
4471                     '** global_all_max_3i: size(lbuf,2).ne.size(gbuf,2) ', &
4472                     size(lbuf,2), size(gbuf,2) )
4473     
4474             call assert( size(lbuf,3).eq.size(gbuf,3),  &
4475                     '** global_all_max_3i: size(lbuf,3).ne.size(gbuf,3) ', &
4476                     size(lbuf,3), size(gbuf,3) )
4477     
4478             do k=lbound(lbuf,3),ubound(lbuf,3)
4479             do j=lbound(lbuf,2),ubound(lbuf,2)
4480               call global_all_max_1i( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
4481             enddo
4482             enddo
4483     
4484             return
4485             end subroutine global_all_max_3i
4486     
4487             subroutine global_all_max_0r( lbuf, gbuf, mroot, idebug )
4488             real, intent(in) :: lbuf
4489             real, intent(out) :: gbuf
4490             integer, optional, intent(in) :: mroot, idebug
4491     
4492             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
4493     
4494             if (.not. present(mroot)) then
4495                lroot = 0
4496             else
4497                lroot = mroot
4498             endif
4499     
4500             if (.not. present(idebug)) then
4501                lidebug = 0
4502             else
4503                lidebug = idebug
4504             endif
4505     
4506             recvtype = MPI_REAL
4507             sendtype = recvtype
4508     
4509             sendcnt = 1
4510     
4511             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_MAX, &
4512                               MPI_COMM_WORLD, ierr )
4513             call MPI_Check( 'global_all_max_0r:MPI_Allreduce', ierr )
4514     
4515     
4516             return
4517             end subroutine global_all_max_0r
4518     
4519     
4520             subroutine global_all_max_1r( lbuf, gbuf, mroot, idebug )
4521             real, intent(in), dimension(:) :: lbuf
4522             real, intent(out), dimension(:) :: gbuf
4523             integer, optional, intent(in) :: mroot, idebug
4524     
4525             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
4526     
4527             if (.not. present(mroot)) then
4528                lroot = 0
4529             else
4530                lroot = mroot
4531             endif
4532     
4533             if (.not. present(idebug)) then
4534                lidebug = 0
4535             else
4536                lidebug = idebug
4537             endif
4538     
4539             recvtype = MPI_REAL
4540             sendtype = recvtype
4541     
4542             sendcnt = size(lbuf)
4543     
4544             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_MAX, &
4545                                 MPI_COMM_WORLD, ierr )
4546             call MPI_Check( 'global_all_max_1r:MPI_Allreduce', ierr )
4547     
4548             return
4549             end subroutine global_all_max_1r
4550     
4551             subroutine global_all_max_2r( lbuf, gbuf, mroot, idebug )
4552             real, intent(in), dimension(:,:) :: lbuf
4553             real, intent(out), dimension(:,:) :: gbuf
4554             integer, optional, intent(in) :: mroot, idebug
4555     
4556             integer :: i,j,lroot, lidebug
4557     
4558             if (.not. present(mroot)) then
4559                lroot = 0
4560             else
4561                lroot = mroot
4562             endif
4563     
4564             if (.not. present(idebug)) then
4565                lidebug = 0
4566             else
4567                lidebug = idebug
4568             endif
4569     
4570             call assert( size(lbuf,2).eq.size(gbuf,2),  &
4571                     '** global_all_max_2r: size(lbuf,2).ne.size(gbuf,2) ', &
4572                     size(lbuf,2), size(gbuf,2) )
4573     
4574             do j=lbound(lbuf,2),ubound(lbuf,2)
4575               call global_all_max_1r( lbuf(:,j), gbuf(:,j), lroot, lidebug )
4576             enddo
4577     
4578             return
4579             end subroutine global_all_max_2r
4580     
4581             subroutine global_all_max_3r( lbuf, gbuf, mroot, idebug )
4582             real, intent(in), dimension(:,:,:) :: lbuf
4583             real, intent(out), dimension(:,:,:) :: gbuf
4584             integer, optional, intent(in) :: mroot, idebug
4585     
4586             integer :: j,k,lroot, lidebug
4587     
4588             if (.not. present(mroot)) then
4589                lroot = 0
4590             else
4591                lroot = mroot
4592             endif
4593     
4594             if (.not. present(idebug)) then
4595                lidebug = 0
4596             else
4597                lidebug = idebug
4598             endif
4599     
4600             call assert( size(lbuf,2).eq.size(gbuf,2),  &
4601                     '** global_all_max_3i: size(lbuf,2).ne.size(gbuf,2) ', &
4602                     size(lbuf,2), size(gbuf,2) )
4603     
4604             call assert( size(lbuf,3).eq.size(gbuf,3),  &
4605                     '** global_all_max_3i: size(lbuf,3).ne.size(gbuf,3) ', &
4606                     size(lbuf,3), size(gbuf,3) )
4607     
4608             do k=lbound(lbuf,3),ubound(lbuf,3)
4609             do j=lbound(lbuf,2),ubound(lbuf,2)
4610               call global_all_max_1r( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
4611             enddo
4612             enddo
4613     
4614             return
4615             end subroutine global_all_max_3r
4616     
4617             subroutine global_all_max_0d( lbuf, gbuf, mroot, idebug )
4618             double precision, intent(in) :: lbuf
4619             double precision, intent(out) :: gbuf
4620             integer, optional, intent(in) :: mroot, idebug
4621     
4622             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
4623     
4624             if (.not. present(mroot)) then
4625                lroot = 0
4626             else
4627                lroot = mroot
4628             endif
4629     
4630             if (.not. present(idebug)) then
4631                lidebug = 0
4632             else
4633                lidebug = idebug
4634             endif
4635     
4636             recvtype = MPI_DOUBLE_PRECISION
4637             sendtype = recvtype
4638     
4639             sendcnt = 1
4640     
4641             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype, MPI_MAX, &
4642                               MPI_COMM_WORLD, ierr )
4643             call MPI_Check( 'global_all_max_0d:MPI_Allreduce', ierr )
4644     
4645             return
4646             end subroutine global_all_max_0d
4647     
4648     
4649             subroutine global_all_max_1d( lbuf, gbuf, mroot, idebug )
4650             double precision, intent(in), dimension(:) :: lbuf
4651             double precision, intent(out), dimension(:) :: gbuf
4652             integer, optional, intent(in) :: mroot, idebug
4653     
4654             integer :: recvtype, sendtype, sendcnt, ierr,lroot, lidebug
4655     
4656             if (.not. present(mroot)) then
4657                lroot = 0
4658             else
4659                lroot = mroot
4660             endif
4661     
4662             if (.not. present(idebug)) then
4663                lidebug = 0
4664             else
4665                lidebug = idebug
4666             endif
4667     
4668             recvtype = MPI_DOUBLE_PRECISION
4669             sendtype = recvtype
4670     
4671             sendcnt = size(lbuf)
4672     
4673             call MPI_Allreduce( lbuf, gbuf, sendcnt, sendtype,  MPI_MAX, &
4674                               MPI_COMM_WORLD, ierr )
4675             call MPI_Check( 'global_all_max_1d:MPI_Allreduce', ierr )
4676     
4677             return
4678             end subroutine global_all_max_1d
4679     
4680             subroutine global_all_max_2d( lbuf, gbuf, mroot, idebug )
4681             double precision, intent(in), dimension(:,:) :: lbuf
4682             double precision, intent(out), dimension(:,:) :: gbuf
4683             integer, optional, intent(in) :: mroot, idebug
4684     
4685             integer :: i,j,lroot, lidebug
4686     
4687             if (.not. present(mroot)) then
4688                lroot = 0
4689             else
4690                lroot = mroot
4691             endif
4692     
4693             if (.not. present(idebug)) then
4694                lidebug = 0
4695             else
4696                lidebug = idebug
4697             endif
4698     
4699             call assert( size(lbuf,2).eq.size(gbuf,2),  &
4700                     '** global_all_max_2d: size(lbuf,2).ne.size(gbuf,2) ', &
4701                     size(lbuf,2), size(gbuf,2) )
4702     
4703             do j=lbound(lbuf,2),ubound(lbuf,2)
4704               call global_all_max_1d( lbuf(:,j), gbuf(:,j), lroot, lidebug )
4705             enddo
4706     
4707             return
4708             end subroutine global_all_max_2d
4709     
4710             subroutine global_all_max_3d( lbuf, gbuf, mroot, idebug )
4711             double precision, intent(in), dimension(:,:,:) :: lbuf
4712             double precision, intent(out), dimension(:,:,:) :: gbuf
4713             integer, optional, intent(in) :: mroot, idebug
4714     
4715             integer :: j,k,lroot, lidebug
4716     
4717             if (.not. present(mroot)) then
4718                lroot = 0
4719             else
4720                lroot = mroot
4721             endif
4722     
4723             if (.not. present(idebug)) then
4724                lidebug = 0
4725             else
4726                lidebug = idebug
4727             endif
4728     
4729             call assert( size(lbuf,2).eq.size(gbuf,2),  &
4730                     '** global_all_max_3i: size(lbuf,2).ne.size(gbuf,2) ', &
4731                     size(lbuf,2), size(gbuf,2) )
4732     
4733             call assert( size(lbuf,3).eq.size(gbuf,3),  &
4734                     '** global_all_max_3i: size(lbuf,3).ne.size(gbuf,3) ', &
4735                     size(lbuf,3), size(gbuf,3) )
4736     
4737             do k=lbound(lbuf,3),ubound(lbuf,3)
4738             do j=lbound(lbuf,2),ubound(lbuf,2)
4739               call global_all_max_1d( lbuf(:,j,k), gbuf(:,j,k), lroot, lidebug )
4740             enddo
4741             enddo
4742     
4743             return
4744             end subroutine global_all_max_3d
4745     
4746     
4747     
4748             subroutine global_all_or_onevar_0d( gbuf )
4749             logical, intent(inout) :: gbuf
4750             logical :: lbuf
4751     
4752             lbuf = gbuf
4753             call global_all_or_0d( lbuf, gbuf )
4754             return
4755             end subroutine global_all_or_onevar_0d
4756     
4757             subroutine global_all_or_onevar_1d( gbuf )
4758             logical, dimension(:), intent(inout) :: gbuf
4759             logical, dimension(size(gbuf)) :: lbuf
4760     
4761             lbuf = gbuf
4762             call global_all_or_1d( lbuf, gbuf )
4763             return
4764             end subroutine global_all_or_onevar_1d
4765     
4766             subroutine global_all_and_onevar_0d( gbuf )
4767             logical, intent(inout) :: gbuf
4768             logical :: lbuf
4769     
4770             lbuf = gbuf
4771             call global_all_and_0d( lbuf, gbuf )
4772             return
4773             end subroutine global_all_and_onevar_0d
4774     
4775             subroutine global_all_and_onevar_1d( gbuf )
4776             logical, dimension(:), intent(inout) :: gbuf
4777             logical, dimension(size(gbuf)) :: lbuf
4778     
4779             lbuf = gbuf
4780             call global_all_and_1d( lbuf, gbuf )
4781             return
4782             end subroutine global_all_and_onevar_1d
4783     
4784     
4785             subroutine global_all_and_0d( lvalue, gvalue, mroot, idebug )
4786             logical, intent(in) :: lvalue
4787             logical, intent(out) :: gvalue
4788             integer, optional, intent(in) :: mroot, idebug
4789     
4790     !       ---------------
4791     !       local variables
4792     !       ---------------
4793             integer :: ierror, icount
4794             integer :: lroot, lidebug
4795     
4796             if (.not. present(mroot)) then
4797                lroot = 0
4798             else
4799                lroot = mroot
4800             endif
4801     
4802             if (.not. present(idebug)) then
4803                lidebug = 0
4804             else
4805                lidebug = idebug
4806             endif
4807     
4808             icount = 1
4809     
4810             call MPI_Allreduce( lvalue, gvalue, icount, MPI_LOGICAL, &
4811                             MPI_LAND, MPI_COMM_WORLD, ierror )
4812     
4813             call MPI_Check( 'global_all_and_0d ', ierror )
4814             return
4815             end subroutine  global_all_and_0d
4816     
4817     
4818             subroutine global_all_and_1d( lvalue, gvalue, mroot, idebug )
4819             logical, intent(in), dimension(:) :: lvalue
4820             logical, intent(out), dimension(:) :: gvalue
4821             integer, optional, intent(in) :: mroot, idebug
4822     
4823     !       ---------------
4824     !       local variables
4825     !       ---------------
4826             integer :: ierror, icount
4827             integer :: lroot, lidebug
4828     
4829             if (.not. present(mroot)) then
4830                lroot = 0
4831             else
4832                lroot = mroot
4833             endif
4834     
4835             if (.not. present(idebug)) then
4836                lidebug = 0
4837             else
4838                lidebug = idebug
4839             endif
4840     
4841     
4842             icount = size( lvalue )
4843     
4844             call MPI_Allreduce( lvalue, gvalue, icount, MPI_LOGICAL, &
4845                             MPI_LAND, MPI_COMM_WORLD, ierror )
4846     
4847             call MPI_Check( 'global_all_and_1d ', ierror )
4848             return
4849             end subroutine global_all_and_1d
4850     
4851     
4852     
4853             subroutine global_all_or_0d( lvalue, gvalue, mroot, idebug )
4854             logical, intent(in) :: lvalue
4855             logical, intent(out) :: gvalue
4856             integer, optional, intent(in) :: mroot, idebug
4857     
4858     !       ---------------
4859     !       local variables
4860     !       ---------------
4861             integer :: ierror, icount
4862             integer :: lroot, lidebug
4863     
4864             if (.not. present(mroot)) then
4865                lroot = 0
4866             else
4867                lroot = mroot
4868             endif
4869     
4870             if (.not. present(idebug)) then
4871                lidebug = 0
4872             else
4873                lidebug = idebug
4874             endif
4875     
4876     
4877             icount = 1
4878     
4879             call MPI_Allreduce( lvalue, gvalue, icount, MPI_LOGICAL, &
4880                             MPI_LOR, MPI_COMM_WORLD, ierror )
4881     
4882             call MPI_Check( 'global_all_or_0d ', ierror )
4883             return
4884             end subroutine global_all_or_0d
4885     
4886     
4887             subroutine global_all_or_1d( lvalue, gvalue, mroot, idebug )
4888             logical, intent(in), dimension(:) :: lvalue
4889             logical, intent(out), dimension(:) :: gvalue
4890             integer, optional, intent(in) :: mroot, idebug
4891     
4892     !       ---------------
4893     !       local variables
4894     !       ---------------
4895             integer :: ierror, icount
4896             integer :: lroot, lidebug
4897     
4898             if (.not. present(mroot)) then
4899                lroot = 0
4900             else
4901                lroot = mroot
4902             endif
4903     
4904             if (.not. present(idebug)) then
4905                lidebug = 0
4906             else
4907                lidebug = idebug
4908             endif
4909     
4910     
4911             icount = size( lvalue )
4912     
4913             call MPI_Allreduce( lvalue, gvalue, icount, MPI_LOGICAL, &
4914                             MPI_LOR, MPI_COMM_WORLD, ierror )
4915     
4916             call MPI_Check( 'global_all_or_1d ', ierror )
4917             return
4918             end subroutine global_all_or_1d
4919     
4920     
4921     !``````````````````````````````````````````````````````````````````````!
4922     ! Subroutine: ExitMPI                                                  !
4923     !                                                                      !
4924     ! Purpose: Clean abort from a parallel run. This routine is invoked by !
4925     ! by calling MFIX_EXIT                                                 !
4926     !......................................................................!
4927           SUBROUTINE ExitMPI(myid)
4928     
4929           USE funits, only: UNIT_LOG
4930           USE funits, only: DMP_LOG
4931     
4932           implicit none
4933     
4934           INTEGER, optional, intent(in) :: MyID
4935     
4936           INTEGER :: MyID_l
4937           INTEGER :: ERRORCODE
4938     
4939     ! Flag to call MPI_ABORT and bypass the call to MPI_Finalize.
4940     ! This is only needed if debugging a 'deadlocked' run.
4941           LOGICAL, PARAMETER :: FORCED_ABORT = .FALSE.
4942     
4943     ! Process ID (myPE) converted to a character string.
4944           CHARACTER(len=64) :: myID_c
4945     
4946     
4947     ! Set the ID of the caller.
4948           myID_l= merge(MyID, myPE, PRESENT(MyID))
4949           myID_c=''; WRITE(myID_c,*) myID_l
4950     
4951     ! Hard abort. If you need this functionality, then you need to figure
4952     ! out why the code has deadlocked. Most likely, a call to MFIX_EXIT
4953     ! was put inside of a logical branch that only a few ranks execute.
4954     ! DON'T JUST USE A FORCED ABORT --> FIX THE CODE CAUSE DEADLOCK <--
4955           IF(FORCED_ABORT) THEN
4956              ERRORCODE = 100 + myPE
4957              CALL MPI_ABORT(MPI_COMM_WORLD, ERRORCODE, MPIERR)
4958              WRITE(*,2000) myID_c, MPIERR
4959     
4960     ! Calls to ExitMPI (via MFIX_EXIT) should be made by all processes
4961     ! and therefore calling MPI_Finalize should be sufficient to exit
4962     ! a failed run. However, a FORCED_ABORT can be issued if deadlock
4963     ! is an issue.
4964           ELSE
4965              CALL MPI_BARRIER(MPI_COMM_WORLD, MPIERR)
4966              CALL MPI_Finalize(MPIERR)
4967           ENDIF
4968     
4969     ! Notify that MPI was cleanly terminated. This point will not be
4970     ! reached if MPI is aborted.
4971           IF(myPE == PE_IO) WRITE(*,1000)
4972     
4973           RETURN
4974     
4975      1000 FORMAT(2/,1X,'MPI Terminated.')
4976      2000 FORMAT(2/,1X,'Rank ',A,' :: MPI_ABORT CODE = ',I4)
4977     
4978           END SUBROUTINE exitMPI
4979     
4980     
4981             end module mpi_utility
4982     
4983     
4984