xref: /phasta/phSolver/common/mpitools.f (revision 1e99f302ca5103688ae35115c2fefb7cfa6714f1) 
1c
2c--------------
3c     drvAllreduce
4c--------------
5c
6      subroutine drvAllreduce ( eachproc, result, m )
7c
8      include "common.h"
9      include "mpif.h"
10c
11      dimension eachproc(m), result(m)
12c
13      if (numpe > 1) then
14         if(impistat.eq.1) then
15           iAllR = iAllR+1
16         elseif(impistat.eq.2) then
17           iAllRScal = iAllRScal+1
18         endif
19         if(impistat2.eq.1) call MPI_BARRIER (MPI_COMM_WORLD, ierr)
20         if(impistat.gt.0) rmpitmr = TMRC()
21         call MPI_ALLREDUCE ( eachproc, result, m,
22     &        MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
23         if(impistat.eq.1) then
24           rAllR = rAllR+TMRC()-rmpitmr
25         elseif(impistat.eq.2) then
26           rAllRScal = rAllRScal+TMRC()-rmpitmr
27         endif
28      else
29         result = eachproc
30      endif
31c
32      return
33      end
34c
35c------------------
36c     drvAllreducesclr
37c------------------
38c
39      subroutine drvAllreducesclr ( eachproc, result )
40c
41      include "common.h"
42      include "mpif.h"
43c
44      if (numpe > 1) then
45         if(impistat.eq.1) then
46           iAllR = iAllR+1
47         elseif(impistat.eq.2) then
48           iAllRScal = iAllRScal+1
49         endif
50         if(impistat2.eq.1) call MPI_BARRIER (MPI_COMM_WORLD, ierr)
51         if(impistat.gt.0) rmpitmr = TMRC()
52         call MPI_ALLREDUCE ( eachproc, result, 1,
53     &        MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr )
54         if(impistat.eq.1) then
55           rAllR = rAllR+TMRC()-rmpitmr
56         elseif(impistat.eq.2) then
57           rAllRScal = rAllRScal+TMRC()-rmpitmr
58         endif
59      else
60         result = eachproc
61      endif
62c
63      return
64      end
65
66c------------------------------------------------------------------------
67c
68c   sum real*8 array over all processors
69c
70c------------------------------------------------------------------------
71      subroutine sumgat (u, n, summed)
72
73      include "common.h"
74      include "mpif.h"
75      include "auxmpi.h"
76
77      dimension u(nshg,n), ilwork(nlwork)
78!SCATTER      dimension sumvec(numpe), irecvcount(numpe)
79
80      summed = sum(u)
81
82      if (numpe > 1) then
83         irecvcount = 1
84         sumvec = summed
85         if(impistat.eq.1) then
86           iAllR = iAllR+1
87         elseif(impistat.eq.2) then
88            iAllRScal = iAllRScal+1
89         endif
90         if(impistat2.eq.1) call MPI_BARRIER (MPI_COMM_WORLD, ierr)
91         if(impistat.gt.0) rmpitmr = TMRC()
92         call MPI_ALLREDUCE (sumvec, summed, irecvcount,
93     &        MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)
94         if(impistat.eq.1) then
95           rAllR = rAllR+TMRC()-rmpitmr
96         elseif(impistat.eq.2) then
97           rAllRScal = rAllRScal+TMRC()-rmpitmr
98         endif
99c         call MPI_REDUCE_SCATTER (sumvec, summed, irecvcount,
100c     &        MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)
101
102      endif
103
104      return
105      end
106
107c------------------------------------------------------------------------
108c
109c   sum real*8 array of length nnp over all processors
110c
111c------------------------------------------------------------------------
112      subroutine sumgatN (u, n, summed, nnp)
113
114      include "common.h"
115      include "mpif.h"
116      include "auxmpi.h"
117
118      dimension u(nnp,n), ilwork(nlwork)
119!      dimension sumvec(numpe), irecvcount(numpe)
120
121c protect against underflow
122c     summed = sum(u)
123      summed = sum(u) + 1.e-20
124
125      if (numpe > 1) then
126         irecvcount = 1
127         sumvec = summed
128
129         if(impistat.eq.1) then
130           iAllR = iAllR+1
131         elseif(impistat.eq.2) then
132            iAllRScal = iAllRScal+1
133         endif
134         if(impistat2.eq.1) call MPI_BARRIER (MPI_COMM_WORLD, ierr)
135         if(impistat.gt.0) rmpitmr = TMRC()
136         call MPI_ALLREDUCE (sumvec, summed, irecvcount,
137     &        MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)
138         if(impistat.eq.1) then
139           rAllR = rAllR+TMRC()-rmpitmr
140         elseif(impistat.eq.2) then
141           rAllRScal = rAllRScal+TMRC()-rmpitmr
142         endif
143c         call MPI_REDUCE_SCATTER (sumvec, summed, irecvcount,
144c     &        MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)
145
146      endif
147
148      return
149      end
150
151c------------------------------------------------------------------------
152c
153c   sum integer array over all processors
154c
155c------------------------------------------------------------------------
156      subroutine sumgatInt (u, n, summed )
157
158      include "common.h"
159      include "mpif.h"
160      include "auxmpi.h"
161
162      integer u(n), summed, sumvec
163!SCATTER      integer sumvec(numpe), irecvcount(numpe)
164
165c$$$      ttim(62) = ttim(62) - tmr()
166
167      summed = sum(u)
168
169      if (numpe > 1) then
170         irecvcount = 1
171         sumvec = summed
172         if(impistat.eq.1) then
173           iAllR = iAllR+1
174         elseif(impistat.eq.2) then
175           iAllRScal = iAllRScal+1
176         endif
177         if(impistat2.eq.1) call MPI_BARRIER (MPI_COMM_WORLD, ierr)
178         if(impistat.gt.0) rmpitmr = TMRC()
179         call MPI_ALLREDUCE (sumvec, summed, irecvcount,
180     &        MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr)
181         if(impistat.eq.1) then
182           rAllR = rAllR+TMRC()-rmpitmr
183         elseif(impistat.eq.2) then
184           rAllRScal = rAllRScal+TMRC()-rmpitmr
185         endif
186c         call MPI_REDUCE_SCATTER (sumvec, summed, irecvcount,
187c     &        MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr)
188
189      endif
190c$$$      ttim(62) = ttim(62) + tmr()
191
192      return
193      end
194
195