-
Notifications
You must be signed in to change notification settings - Fork 3
/
global_mpi.f90
164 lines (86 loc) · 2.7 KB
/
global_mpi.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
MODULE global_mpi_module
USE definitions_module
!USE MPI
IMPLICIT NONE
include "mpif.h"
CONTAINS
SUBROUTINE tea_sum(value)
! Only sums to the master
IMPLICIT NONE
REAL(KIND=8) :: value
REAL(KIND=8) :: total
INTEGER :: err
total=value
CALL MPI_REDUCE(value,total,1,MPI_DOUBLE_PRECISION,MPI_SUM,0,mpi_cart_comm,err)
value=total
END SUBROUTINE tea_sum
SUBROUTINE tea_allsum(value)
! Global reduction for CG solver
IMPLICIT NONE
REAL(KIND=8) :: value
REAL(KIND=8) :: total, dot_product_time, timer
INTEGER :: err
total=value
IF (profiler_on) dot_product_time=timer()
CALL MPI_ALLREDUCE(value,total,1,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_cart_comm,err)
IF (profiler_on) profiler%dot_product= profiler%dot_product+ (timer() - dot_product_time)
value=total
END SUBROUTINE tea_allsum
SUBROUTINE tea_allsum2(value1,value2)
! Global reduction for CG solver
IMPLICIT NONE
REAL(KIND=8) :: value1,value2
REAL(KIND=8), DIMENSION(2) :: values,totals
REAL(KIND=8) :: dot_product_time, timer
INTEGER :: err
values=(/ value1, value2 /)
totals=values
IF (profiler_on) dot_product_time=timer()
CALL MPI_ALLREDUCE(values,totals,2,MPI_DOUBLE_PRECISION,MPI_SUM,mpi_cart_comm,err)
IF (profiler_on) profiler%dot_product= profiler%dot_product+ (timer() - dot_product_time)
value1=totals(1); value2=totals(2)
END SUBROUTINE tea_allsum2
SUBROUTINE tea_min(value)
IMPLICIT NONE
REAL(KIND=8) :: value
REAL(KIND=8) :: minimum
INTEGER :: err
minimum=value
CALL MPI_ALLREDUCE(value,minimum,1,MPI_DOUBLE_PRECISION,MPI_MIN,mpi_cart_comm,err)
value=minimum
END SUBROUTINE tea_min
SUBROUTINE tea_max(value)
IMPLICIT NONE
REAL(KIND=8) :: value
REAL(KIND=8) :: maximum
INTEGER :: err
maximum=value
CALL MPI_ALLREDUCE(value,maximum,1,MPI_DOUBLE_PRECISION,MPI_MAX,mpi_cart_comm,err)
value=maximum
END SUBROUTINE tea_max
SUBROUTINE tea_allgather(value,values)
IMPLICIT NONE
REAL(KIND=8) :: value
REAL(KIND=8) :: values(parallel%max_task)
INTEGER :: err
values(1)=value ! Just to ensure it will work in serial
CALL MPI_ALLGATHER(value,1,MPI_DOUBLE_PRECISION,values,1,MPI_DOUBLE_PRECISION,mpi_cart_comm,err)
END SUBROUTINE tea_allgather
SUBROUTINE tea_check_error(error)
IMPLICIT NONE
INTEGER :: error
INTEGER :: maximum
INTEGER :: err
maximum=error
CALL MPI_ALLREDUCE(error,maximum,1,MPI_INTEGER,MPI_MAX,mpi_cart_comm,err)
error=maximum
END SUBROUTINE tea_check_error
SUBROUTINE tea_barrier
INTEGER :: err
CALL MPI_BARRIER(mpi_cart_comm,err)
END SUBROUTINE tea_barrier
SUBROUTINE tea_abort
INTEGER :: ierr,err
CALL MPI_ABORT(mpi_cart_comm,ierr,err)
END SUBROUTINE tea_abort
END MODULE global_mpi_module