1 |
chuckv |
4 |
|
2 |
|
|
module mpi_module |
3 |
|
|
#ifdef MPI |
4 |
|
|
use parameter |
5 |
|
|
use simulation |
6 |
|
|
#ifndef LAM |
7 |
|
|
use mpi |
8 |
|
|
#endif |
9 |
|
|
implicit none |
10 |
|
|
PRIVATE |
11 |
|
|
|
12 |
|
|
#ifdef LAM |
13 |
|
|
include mpif.h |
14 |
|
|
#endif |
15 |
|
|
|
16 |
|
|
!!PUBLIC Subroutines contained in this module |
17 |
|
|
public :: gather, scatter, init_mpi |
18 |
|
|
public :: setup_parallel_mol, setup_parallel_mpi |
19 |
|
|
public :: mpi_handle_atypes |
20 |
|
|
public :: mpi_dist_params |
21 |
|
|
|
22 |
|
|
!!PUBLIC Subroutines contained in MPI module |
23 |
|
|
public :: mpi_bcast |
24 |
|
|
public :: mpi_allreduce |
25 |
|
|
public :: mpi_reduce |
26 |
|
|
public :: mpi_send |
27 |
|
|
public :: mpi_recv |
28 |
|
|
public :: mpi_get_processor_name |
29 |
|
|
public :: mpi_finalize |
30 |
|
|
|
31 |
|
|
!!PUBLIC mpi variables |
32 |
|
|
public :: mpi_comm_world |
33 |
|
|
public :: mpi_character |
34 |
|
|
public :: mpi_integer |
35 |
|
|
public :: mpi_double_precision |
36 |
|
|
public :: mpi_sum |
37 |
|
|
public :: mpi_max |
38 |
|
|
public :: mpi_status_size |
39 |
|
|
! public :: mpi_recv_char |
40 |
|
|
public :: mpi_any_source |
41 |
|
|
|
42 |
|
|
!! public variables |
43 |
|
|
integer,public :: mpi_err |
44 |
|
|
integer,public :: node |
45 |
|
|
integer,public :: nprocs |
46 |
|
|
integer,public :: row_comm,col_comm |
47 |
|
|
integer,public :: nstart,nend,nrow,ncol |
48 |
|
|
integer,public :: nmol_start,nmol_end |
49 |
|
|
integer,public :: max_local,max_row,max_col |
50 |
|
|
integer,public :: maxmol_local |
51 |
|
|
integer,public :: number_of_cols,number_of_rows |
52 |
|
|
|
53 |
|
|
integer,public, allocatable, dimension(:,:) :: node_atype_index |
54 |
|
|
type, public :: gs_plan |
55 |
|
|
! private |
56 |
|
|
integer :: me, nprocs, n_datum,full_size !n = # of datums on local proc |
57 |
|
|
integer, dimension(:), pointer :: displs |
58 |
|
|
integer, dimension(:), pointer :: counts |
59 |
|
|
integer :: comm |
60 |
|
|
end type gs_plan |
61 |
|
|
|
62 |
|
|
type (gs_plan), public :: plan_row |
63 |
|
|
type (gs_plan), public :: plan_row3 |
64 |
|
|
type (gs_plan), public :: plan_col |
65 |
|
|
type (gs_plan), public :: plan_col3 |
66 |
|
|
|
67 |
|
|
|
68 |
|
|
interface gather |
69 |
|
|
module procedure gather_double |
70 |
|
|
module procedure gather_double_dim |
71 |
|
|
end interface |
72 |
|
|
|
73 |
|
|
interface scatter |
74 |
|
|
module procedure scatter_double |
75 |
|
|
module procedure scatter_double_dim |
76 |
|
|
end interface |
77 |
|
|
|
78 |
|
|
#ifdef LAM |
79 |
|
|
!! MPI f90 interfaces for LAM |
80 |
|
|
|
81 |
|
|
!! non type communication interface from MPICH mpi1.f90 |
82 |
|
|
interface |
83 |
|
|
SUBROUTINE MPI_INIT(IERROR) |
84 |
|
|
INTEGER IERROR |
85 |
|
|
END SUBROUTINE MPI_INIT |
86 |
|
|
|
87 |
|
|
SUBROUTINE MPI_FINALIZE(IERROR) |
88 |
|
|
INTEGER IERROR |
89 |
|
|
END SUBROUTINE MPI_FINALIZE |
90 |
|
|
|
91 |
|
|
SUBROUTINE MPI_BARRIER(COMM, IERROR) |
92 |
|
|
INTEGER COMM, IERROR |
93 |
|
|
END SUBROUTINE MPI_BARRIER |
94 |
|
|
|
95 |
|
|
SUBROUTINE MPI_COMM_RANK(COMM, RANK, IERROR) |
96 |
|
|
INTEGER COMM, RANK, IERROR |
97 |
|
|
END SUBROUTINE MPI_COMM_RANK |
98 |
|
|
|
99 |
|
|
SUBROUTINE MPI_COMM_SIZE(COMM, SIZE, IERROR) |
100 |
|
|
INTEGER COMM, SIZE, IERROR |
101 |
|
|
END SUBROUTINE MPI_COMM_SIZE |
102 |
|
|
! |
103 |
|
|
SUBROUTINE MPI_COMM_SPLIT(COMM, COLOR, KEY, NEWCOMM, IERROR) |
104 |
|
|
INTEGER COMM, COLOR, KEY, NEWCOMM, IERROR |
105 |
|
|
END SUBROUTINE MPI_COMM_SPLIT |
106 |
|
|
|
107 |
|
|
SUBROUTINE MPI_GET_PROCESSOR_NAME( NAME, RESULTLEN, IERROR) |
108 |
|
|
CHARACTER*(*) NAME |
109 |
|
|
INTEGER RESULTLEN,IERROR |
110 |
|
|
END SUBROUTINE MPI_GET_PROCESSOR_NAME |
111 |
|
|
|
112 |
|
|
FUNCTION MPI_WTIME() |
113 |
|
|
DOUBLE PRECISION MPI_WTIME |
114 |
|
|
END FUNCTION MPI_WTIME |
115 |
|
|
! |
116 |
|
|
FUNCTION MPI_WTICK() |
117 |
|
|
DOUBLE PRECISION MPI_WTICK |
118 |
|
|
END FUNCTION MPI_WTICK |
119 |
|
|
end interface |
120 |
|
|
|
121 |
|
|
interface mpi_allreduce |
122 |
|
|
module procedure mpi_allreduce_t |
123 |
|
|
end interface |
124 |
|
|
|
125 |
|
|
interface mpi_reduce |
126 |
|
|
module procedure mpi_reduce_t |
127 |
|
|
end interface |
128 |
|
|
|
129 |
|
|
interface mpi_reduce_scatter |
130 |
|
|
module procedure mpi_reduce_scatter_t |
131 |
|
|
end interface |
132 |
|
|
|
133 |
|
|
interface mpi_allgatherv |
134 |
|
|
module procedure mpi_allgatherv_t |
135 |
|
|
end interface |
136 |
|
|
|
137 |
|
|
interface mpi_allgather |
138 |
|
|
module procedure mpi_allgather_t |
139 |
|
|
end interface |
140 |
|
|
|
141 |
|
|
interface mpi_bcast |
142 |
|
|
module procedure mpi_bcast_t |
143 |
|
|
end interface |
144 |
|
|
|
145 |
|
|
interface mpi_send |
146 |
|
|
module procedure mpi_send_t |
147 |
|
|
module procedure mpi_send_char |
148 |
|
|
end interface |
149 |
|
|
|
150 |
|
|
interface mpi_recv |
151 |
|
|
module procedure mpi_recv_t |
152 |
|
|
module procedure mpi_recv_char |
153 |
|
|
end interface |
154 |
|
|
|
155 |
|
|
#else |
156 |
|
|
!! MPI interfaces for MPICH types not defined |
157 |
|
|
! interface mpi_bcast |
158 |
|
|
! module procedure mpi_bcast_t |
159 |
|
|
! end interface |
160 |
|
|
|
161 |
|
|
! interface mpi_send |
162 |
|
|
! module procedure mpi_send_t |
163 |
|
|
! module procedure mpi_send_char |
164 |
|
|
! end interface |
165 |
|
|
|
166 |
|
|
! interface mpi_recv |
167 |
|
|
! module procedure mpi_recv_t |
168 |
|
|
! module procedure mpi_recv_char |
169 |
|
|
! end interface |
170 |
|
|
#endif |
171 |
|
|
|
172 |
|
|
|
173 |
|
|
contains |
174 |
|
|
|
175 |
|
|
|
176 |
|
|
subroutine init_mpi() |
177 |
|
|
|
178 |
|
|
call mpi_init( mpi_err ) |
179 |
|
|
call mpi_comm_rank( MPI_COMM_WORLD, node, mpi_err) |
180 |
|
|
call mpi_comm_size( MPI_COMM_WORLD, nprocs, mpi_err ) |
181 |
|
|
|
182 |
|
|
end subroutine init_mpi |
183 |
|
|
|
184 |
|
|
|
185 |
|
|
subroutine setup_parallel_mol(nmol,status) |
186 |
|
|
integer, intent(in) :: nmol |
187 |
|
|
integer, intent(out), optional :: status |
188 |
|
|
|
189 |
|
|
if (present(status)) status = 0 |
190 |
|
|
nmol_start = nint(float(node)/nprocs*nmol) + 1 |
191 |
|
|
nmol_end = nint(float(node + 1)/nprocs*nmol) |
192 |
|
|
nmol_local = nmol_end - nmol_start + 1 |
193 |
|
|
|
194 |
|
|
call mpi_allreduce(nmol_local,maxmol_local,1,mpi_integer, & |
195 |
|
|
mpi_max, mpi_comm_world,mpi_err) |
196 |
|
|
if (mpi_err /= 0) then |
197 |
|
|
if (present(status)) status = -1 |
198 |
|
|
endif |
199 |
|
|
|
200 |
|
|
|
201 |
|
|
end subroutine setup_parallel_mol |
202 |
|
|
|
203 |
|
|
|
204 |
|
|
|
205 |
|
|
|
206 |
|
|
|
207 |
|
|
subroutine setup_parallel_mpi(status) |
208 |
|
|
|
209 |
|
|
integer, intent(out), optional :: status |
210 |
|
|
integer :: i,junk,junk1 |
211 |
|
|
integer :: numcolmax,row_indx,col_indx |
212 |
|
|
character(len=80) msg |
213 |
|
|
|
214 |
|
|
if (present(status)) status = 0 |
215 |
|
|
|
216 |
|
|
call mpi_allreduce(nlocal,natoms,1,mpi_integer, & |
217 |
|
|
mpi_sum,mpi_comm_world,mpi_err) |
218 |
|
|
if (mpi_err /= 0) then |
219 |
|
|
if (present(status)) status = -1 |
220 |
|
|
endif |
221 |
|
|
|
222 |
|
|
! nlocal = nend - nstart + 1 |
223 |
|
|
nend = nlocal + nstart - 1 |
224 |
|
|
|
225 |
|
|
|
226 |
|
|
!! force decomp gives proc_atoms = natoms/dsqrt(nprocs) to form |
227 |
|
|
!! a square matrix of length dsqrt(nprocs) |
228 |
|
|
|
229 |
|
|
numcolmax = nint(dsqrt(dble(nprocs))) |
230 |
|
|
do i = 1, numcolmax |
231 |
|
|
if (mod(nprocs,i).eq.0) number_of_cols = i |
232 |
|
|
end do |
233 |
|
|
|
234 |
|
|
number_of_rows = nprocs/number_of_cols |
235 |
|
|
|
236 |
|
|
|
237 |
|
|
|
238 |
|
|
row_indx = node/number_of_cols |
239 |
|
|
call mpi_comm_split(mpi_comm_world,row_indx,0,row_comm,mpi_err) |
240 |
|
|
|
241 |
|
|
col_indx = mod(node,number_of_cols) |
242 |
|
|
call mpi_comm_split(mpi_comm_world,col_indx,0,col_comm,mpi_err) |
243 |
|
|
|
244 |
|
|
call mpi_comm_size(row_comm,junk,mpi_err) |
245 |
|
|
call mpi_comm_size(col_comm,junk1,mpi_err) |
246 |
|
|
|
247 |
|
|
|
248 |
|
|
!! figure out natoms_row, number of atoms owned by my row |
249 |
|
|
!! figure out natoms_col, number of atoms owned by my col |
250 |
|
|
|
251 |
|
|
call mpi_allreduce(nlocal,nrow,1,mpi_integer,mpi_sum,row_comm,mpi_err) |
252 |
|
|
if (mpi_err /= 0) then |
253 |
|
|
if (present(status)) status = -1 |
254 |
|
|
endif |
255 |
|
|
|
256 |
|
|
call mpi_allreduce(nlocal,ncol,1,mpi_integer,mpi_sum,col_comm,mpi_err) |
257 |
|
|
|
258 |
|
|
|
259 |
|
|
if (mpi_err /= 0) then |
260 |
|
|
if (present(status)) status = -1 |
261 |
|
|
endif |
262 |
|
|
|
263 |
|
|
|
264 |
|
|
! Init gather scatter plans ala plimpton... |
265 |
|
|
|
266 |
|
|
call plan_gather_scatter(nlocal,row_comm,plan_row) |
267 |
|
|
call plan_gather_scatter(3*nlocal,row_comm,plan_row3) |
268 |
|
|
call plan_gather_scatter(nlocal,col_comm,plan_col) |
269 |
|
|
call plan_gather_scatter(3*nlocal,col_comm,plan_col3) |
270 |
|
|
|
271 |
|
|
|
272 |
|
|
|
273 |
|
|
! compute current bounds mpi_max will return the largest value |
274 |
|
|
|
275 |
|
|
|
276 |
|
|
call mpi_allreduce(nlocal,max_local,1,mpi_integer,mpi_max, & |
277 |
|
|
mpi_comm_world,mpi_err) |
278 |
|
|
if (mpi_err /= 0) then |
279 |
|
|
if (present(status)) status = -1 |
280 |
|
|
endif |
281 |
|
|
|
282 |
|
|
call mpi_allreduce(nrow,max_row,1,mpi_integer,mpi_max, & |
283 |
|
|
mpi_comm_world,mpi_err) |
284 |
|
|
if (mpi_err /= 0) then |
285 |
|
|
if (present(status)) status = -1 |
286 |
|
|
endif |
287 |
|
|
|
288 |
|
|
call mpi_allreduce(ncol,max_col,1,mpi_integer,mpi_max, & |
289 |
|
|
mpi_comm_world,mpi_err) |
290 |
|
|
if (mpi_err /= 0) then |
291 |
|
|
if (present(status)) status = -1 |
292 |
|
|
endif |
293 |
|
|
|
294 |
|
|
|
295 |
|
|
!! allocate mpi row and col arrays... |
296 |
|
|
! call allocate_mpi_row_arrays(max_row) |
297 |
|
|
! call allocate_mpi_col_arrays(max_col) |
298 |
|
|
!! allocate mpi row and col arrays... |
299 |
|
|
call allocate_mpi_row_arrays(nrow) |
300 |
|
|
call allocate_mpi_col_arrays(ncol) |
301 |
|
|
|
302 |
|
|
|
303 |
|
|
|
304 |
|
|
end subroutine setup_parallel_mpi |
305 |
|
|
|
306 |
|
|
#ifdef MPI |
307 |
|
|
!! distributes params from node 0 to other nodes.... |
308 |
|
|
subroutine mpi_dist_params() |
309 |
|
|
|
310 |
|
|
!! parameters for every sim that each node needs to know |
311 |
|
|
|
312 |
|
|
call mpi_bcast(command,80,mpi_character,0, & |
313 |
|
|
mpi_comm_world,mpi_err) |
314 |
|
|
call mpi_bcast(ensemble,80,mpi_character,0, & |
315 |
|
|
mpi_comm_world,mpi_err) |
316 |
|
|
call mpi_bcast(sim_type,80,mpi_character,0, & |
317 |
|
|
mpi_comm_world,mpi_err) |
318 |
|
|
call mpi_bcast(force_field,80,mpi_character,0, & |
319 |
|
|
mpi_comm_world,mpi_err) |
320 |
|
|
call mpi_bcast(target_temp,1,mpi_double_precision,0, & |
321 |
|
|
mpi_comm_world,mpi_err) |
322 |
|
|
call mpi_bcast(checktemp,1,mpi_logical,0, & |
323 |
|
|
mpi_comm_world,mpi_err) |
324 |
|
|
call mpi_bcast(run_time,1,mpi_double_precision,0, & |
325 |
|
|
mpi_comm_world,mpi_err) |
326 |
|
|
call mpi_bcast(dt,1,mpi_double_precision,0, & |
327 |
|
|
mpi_comm_world,mpi_err) |
328 |
|
|
call mpi_bcast(rcut,1,mpi_double_precision,0, & |
329 |
|
|
mpi_comm_world,mpi_err) |
330 |
|
|
call mpi_bcast(skin_thickness,1,mpi_double_precision,0, & |
331 |
|
|
mpi_comm_world,mpi_err) |
332 |
|
|
call mpi_bcast(therm_variance,1,mpi_double_precision,0, & |
333 |
|
|
mpi_comm_world,mpi_err) |
334 |
|
|
call mpi_bcast(iseed,1,mpi_integer,0, & |
335 |
|
|
mpi_comm_world,mpi_err) |
336 |
|
|
call mpi_bcast(check_temp_steps,1,mpi_integer,0, & |
337 |
|
|
mpi_comm_world,mpi_err) |
338 |
|
|
call mpi_bcast(write_config_steps,1,mpi_integer,0, & |
339 |
|
|
mpi_comm_world,mpi_err) |
340 |
|
|
|
341 |
|
|
|
342 |
|
|
|
343 |
|
|
!! cluster parameters |
344 |
|
|
call mpi_bcast(core_model,80,mpi_character,0, & |
345 |
|
|
mpi_comm_world,mpi_err) |
346 |
|
|
call mpi_bcast(shell_model,80,mpi_character,0, & |
347 |
|
|
mpi_comm_world,mpi_err) |
348 |
|
|
call mpi_bcast(r_core,1,mpi_double_precision,0, & |
349 |
|
|
mpi_comm_world,mpi_err) |
350 |
|
|
call mpi_bcast(r_shell,1,mpi_double_precision,0, & |
351 |
|
|
mpi_comm_world,mpi_err) |
352 |
|
|
call mpi_bcast(cell, 1,mpi_double_precision,0, & |
353 |
|
|
mpi_comm_world,mpi_err) |
354 |
|
|
call mpi_bcast(vacancy_radius, 1,mpi_double_precision,0, & |
355 |
|
|
mpi_comm_world,mpi_err) |
356 |
|
|
call mpi_bcast(vacancy_fraction, 1,mpi_double_precision,0, & |
357 |
|
|
mpi_comm_world,mpi_err) |
358 |
|
|
|
359 |
|
|
|
360 |
|
|
|
361 |
|
|
!! liquid paramters |
362 |
|
|
call mpi_bcast(solute_model,80,mpi_character,0, & |
363 |
|
|
mpi_comm_world,mpi_err) |
364 |
|
|
call mpi_bcast(solvent_model,80,mpi_character,0, & |
365 |
|
|
mpi_comm_world,mpi_err) |
366 |
|
|
call mpi_bcast(solute_x,1,mpi_double_precision,0, & |
367 |
|
|
mpi_comm_world,mpi_err) |
368 |
|
|
call mpi_bcast(density,1,mpi_double_precision,0, & |
369 |
|
|
mpi_comm_world,mpi_err) |
370 |
|
|
call mpi_bcast(ncells,1,mpi_integer,0, & |
371 |
|
|
mpi_comm_world,mpi_err) |
372 |
|
|
! MPI parameter |
373 |
|
|
call mpi_bcast(newtons_thrd,1,mpi_logical,0, & |
374 |
|
|
mpi_comm_world,mpi_err) |
375 |
|
|
! parameter for langevin dynamics |
376 |
|
|
call mpi_bcast(eta,1,mpi_double_precision,0, & |
377 |
|
|
mpi_comm_world,mpi_err) |
378 |
|
|
call mpi_bcast(bath_temp,1,mpi_double_precision,0, & |
379 |
|
|
mpi_comm_world,mpi_err) |
380 |
|
|
call mpi_bcast(langevin_skin_delta,1,mpi_double_precision,0, & |
381 |
|
|
mpi_comm_world,mpi_err) |
382 |
|
|
call mpi_bcast(use_langevin_skin,1,mpi_logical,0, & |
383 |
|
|
mpi_comm_world,mpi_err) |
384 |
|
|
|
385 |
|
|
|
386 |
|
|
end subroutine mpi_dist_params |
387 |
|
|
#endif |
388 |
|
|
|
389 |
|
|
|
390 |
|
|
|
391 |
|
|
!! subroutine to distribute column and row atom type info... |
392 |
|
|
|
393 |
|
|
subroutine mpi_handle_atypes(status) |
394 |
|
|
integer :: row_proc_size, column_proc_size |
395 |
|
|
integer :: i,ntmp |
396 |
|
|
integer, allocatable, dimension(:) :: ident_row_displs, ident_row_counts |
397 |
|
|
integer, allocatable, dimension(:) :: ident_column_displs, ident_column_counts |
398 |
|
|
! integer :: max_alloc |
399 |
|
|
integer, intent(out), optional :: status |
400 |
|
|
! max_alloc = max(max_row,max_col) |
401 |
|
|
|
402 |
|
|
!! setup tag_local arrays |
403 |
|
|
ntmp = 0 |
404 |
|
|
if (present(status)) status = 0 |
405 |
|
|
do i = 1,natoms |
406 |
|
|
if (i >= nstart .AND. i <= nend) then |
407 |
|
|
ntmp = i - nstart + 1 |
408 |
|
|
tag_local(ntmp) = i |
409 |
|
|
end if |
410 |
|
|
end do |
411 |
|
|
|
412 |
|
|
!! do row idents and tags |
413 |
|
|
call mpi_comm_size(row_comm,row_proc_size,mpi_err) |
414 |
|
|
|
415 |
|
|
call mpi_barrier(mpi_comm_world,mpi_err) |
416 |
|
|
|
417 |
|
|
allocate(ident_row_displs(row_proc_size)) |
418 |
|
|
allocate(ident_row_counts(row_proc_size)) |
419 |
|
|
|
420 |
|
|
|
421 |
|
|
call mpi_allgather(nlocal,1,mpi_integer,ident_row_counts,1,mpi_integer, & |
422 |
|
|
row_comm,mpi_err) |
423 |
|
|
if (mpi_err /= 0) then |
424 |
|
|
if (present(status)) status = -1 |
425 |
|
|
endif |
426 |
|
|
|
427 |
|
|
ident_row_displs(1) = 0 |
428 |
|
|
do i = 2, row_proc_size |
429 |
|
|
ident_row_displs(i) = ident_row_displs(i-1) + ident_row_counts(i-1) |
430 |
|
|
enddo |
431 |
|
|
|
432 |
|
|
|
433 |
|
|
call mpi_allgatherv(ident,nlocal,mpi_integer, & |
434 |
|
|
ident_row,ident_row_counts,ident_row_displs,mpi_integer,row_comm,mpi_err) |
435 |
|
|
if (mpi_err /= 0) then |
436 |
|
|
if (present(status)) status = -1 |
437 |
|
|
endif |
438 |
|
|
|
439 |
|
|
call mpi_allgatherv(tag_local,nlocal,mpi_integer, & |
440 |
|
|
tag_row,ident_row_counts,ident_row_displs,mpi_integer,row_comm,mpi_err) |
441 |
|
|
|
442 |
|
|
if (mpi_err /= 0) then |
443 |
|
|
if (present(status)) status = -1 |
444 |
|
|
endif |
445 |
|
|
|
446 |
|
|
deallocate(ident_row_displs) |
447 |
|
|
deallocate(ident_row_counts) |
448 |
|
|
|
449 |
|
|
!! do col idents |
450 |
|
|
call mpi_comm_size(col_comm,column_proc_size,mpi_err) |
451 |
|
|
|
452 |
|
|
allocate(ident_column_displs(column_proc_size)) |
453 |
|
|
allocate(ident_column_counts(column_proc_size)) |
454 |
|
|
|
455 |
|
|
call mpi_allgather(nlocal,1,mpi_integer,ident_column_counts,1,mpi_integer, & |
456 |
|
|
col_comm,mpi_err) |
457 |
|
|
if (mpi_err /= 0) then |
458 |
|
|
if (present(status)) status = -1 |
459 |
|
|
endif |
460 |
|
|
|
461 |
|
|
ident_column_displs(1) = 0 |
462 |
|
|
do i = 2, column_proc_size |
463 |
|
|
ident_column_displs(i) = ident_column_displs(i-1) + ident_column_counts(i-1) |
464 |
|
|
enddo |
465 |
|
|
|
466 |
|
|
call mpi_allgatherv(ident,nlocal,mpi_integer, & |
467 |
|
|
ident_col,ident_column_counts,ident_column_displs,mpi_integer,col_comm,mpi_err) |
468 |
|
|
if (mpi_err /= 0) then |
469 |
|
|
if (present(status)) status = -1 |
470 |
|
|
endif |
471 |
|
|
|
472 |
|
|
call mpi_allgatherv(tag_local,nlocal,mpi_integer, & |
473 |
|
|
tag_col,ident_column_counts,ident_column_displs,mpi_integer,col_comm,mpi_err) |
474 |
|
|
if (mpi_err /= 0) then |
475 |
|
|
if (present(status)) status = -1 |
476 |
|
|
endif |
477 |
|
|
|
478 |
|
|
|
479 |
|
|
deallocate(ident_column_displs) |
480 |
|
|
deallocate(ident_column_counts) |
481 |
|
|
|
482 |
|
|
|
483 |
|
|
end subroutine mpi_handle_atypes |
484 |
|
|
|
485 |
|
|
|
486 |
|
|
!! initalizes a gather scatter plan |
487 |
|
|
subroutine plan_gather_scatter( local_number, & |
488 |
|
|
orig_comm, this_plan) |
489 |
|
|
|
490 |
|
|
type (gs_plan), intent(out) :: this_plan |
491 |
|
|
integer, intent(in) :: local_number |
492 |
|
|
integer, intent(in) :: orig_comm |
493 |
|
|
integer :: sizeof_int |
494 |
|
|
integer :: ierror |
495 |
|
|
integer :: comm |
496 |
|
|
integer :: me |
497 |
|
|
integer :: comm_procs |
498 |
|
|
integer :: i,junk |
499 |
|
|
integer :: number_of_particles |
500 |
|
|
|
501 |
|
|
|
502 |
|
|
|
503 |
|
|
number_of_particles = 0 |
504 |
|
|
call mpi_comm_dup(orig_comm,comm,mpi_err) |
505 |
|
|
call mpi_comm_rank(comm,me,mpi_err) |
506 |
|
|
call mpi_comm_size(comm,comm_procs,mpi_err) |
507 |
|
|
|
508 |
|
|
sizeof_int = selected_int_kind(4) |
509 |
|
|
|
510 |
|
|
allocate (this_plan%counts(0:comm_procs-1),STAT=ierror) |
511 |
|
|
if (ierror /= 0) then |
512 |
|
|
|
513 |
|
|
end if |
514 |
|
|
|
515 |
|
|
allocate (this_plan%displs(0:comm_procs-1),STAT=ierror) |
516 |
|
|
if (ierror /= 0) then |
517 |
|
|
|
518 |
|
|
end if |
519 |
|
|
|
520 |
|
|
|
521 |
|
|
call mpi_allgather(local_number,1,mpi_integer,this_plan%counts, & |
522 |
|
|
1,mpi_integer,comm,mpi_err) |
523 |
|
|
|
524 |
|
|
|
525 |
|
|
!! figure out the total number of particles in this plan |
526 |
|
|
number_of_particles = sum(this_plan%counts) |
527 |
|
|
|
528 |
|
|
|
529 |
|
|
!initialize plan |
530 |
|
|
this_plan%displs(0) = 0 |
531 |
|
|
do i = 1, comm_procs - 1,1 |
532 |
|
|
this_plan%displs(i) = this_plan%displs(i-1) + this_plan%counts(i-1) |
533 |
|
|
end do |
534 |
|
|
|
535 |
|
|
|
536 |
|
|
this_plan%me = me |
537 |
|
|
this_plan%nprocs = comm_procs |
538 |
|
|
this_plan%full_size = number_of_particles |
539 |
|
|
this_plan%comm = comm |
540 |
|
|
this_plan%n_datum = local_number |
541 |
|
|
|
542 |
|
|
|
543 |
|
|
end subroutine plan_gather_scatter |
544 |
|
|
|
545 |
|
|
subroutine unplan_gather_scatter(this_plan) |
546 |
|
|
|
547 |
|
|
type (gs_plan), intent(inout) :: this_plan |
548 |
|
|
|
549 |
|
|
call mpi_comm_free(this_plan%comm,mpi_err) |
550 |
|
|
|
551 |
|
|
deallocate(this_plan%counts) |
552 |
|
|
deallocate(this_plan%displs) |
553 |
|
|
|
554 |
|
|
end subroutine unplan_gather_scatter |
555 |
|
|
|
556 |
|
|
subroutine gather_double( sbuffer, rbuffer, this_plan, status) |
557 |
|
|
|
558 |
|
|
type (gs_plan), intent(in) :: this_plan |
559 |
|
|
real( kind = DP ), dimension(:), intent(in) :: sbuffer |
560 |
|
|
real( kind = DP ), dimension(:), intent(in) :: rbuffer |
561 |
|
|
integer :: noffset |
562 |
|
|
integer, intent(out), optional :: status |
563 |
|
|
|
564 |
|
|
if (present(status)) status = 0 |
565 |
|
|
noffset = this_plan%displs(this_plan%me) |
566 |
|
|
|
567 |
|
|
call mpi_allgatherv(sbuffer,this_plan%n_datum, mpi_double_precision, & |
568 |
|
|
rbuffer,this_plan%counts,this_plan%displs,mpi_double_precision, & |
569 |
|
|
this_plan%comm, mpi_err) |
570 |
|
|
|
571 |
|
|
if (mpi_err /= 0) then |
572 |
|
|
if (present(status)) status = -1 |
573 |
|
|
endif |
574 |
|
|
|
575 |
|
|
end subroutine gather_double |
576 |
|
|
|
577 |
|
|
subroutine gather_double_dim( sbuffer, rbuffer, this_plan, status) |
578 |
|
|
|
579 |
|
|
type (gs_plan), intent(in) :: this_plan |
580 |
|
|
real( kind = DP ), dimension(:,:), intent(in) :: sbuffer |
581 |
|
|
real( kind = DP ), dimension(:,:), intent(in) :: rbuffer |
582 |
|
|
integer :: noffset,i,ierror |
583 |
|
|
integer, intent(out), optional :: status |
584 |
|
|
|
585 |
|
|
external mpi_allgatherv |
586 |
|
|
|
587 |
|
|
if (present(status)) status = 0 |
588 |
|
|
|
589 |
|
|
! noffset = this_plan%displs(this_plan%me) |
590 |
|
|
|
591 |
|
|
call mpi_allgatherv(sbuffer,this_plan%n_datum, mpi_double_precision, & |
592 |
|
|
rbuffer,this_plan%counts,this_plan%displs,mpi_double_precision, & |
593 |
|
|
this_plan%comm, mpi_err) |
594 |
|
|
|
595 |
|
|
if (mpi_err /= 0) then |
596 |
|
|
if (present(status)) status = -1 |
597 |
|
|
endif |
598 |
|
|
|
599 |
|
|
end subroutine gather_double_dim |
600 |
|
|
|
601 |
|
|
subroutine scatter_double( sbuffer, rbuffer, this_plan, status) |
602 |
|
|
|
603 |
|
|
type (gs_plan), intent(in) :: this_plan |
604 |
|
|
real( kind = DP ), dimension(:), intent(in) :: sbuffer |
605 |
|
|
real( kind = DP ), dimension(:), intent(in) :: rbuffer |
606 |
|
|
integer, intent(out), optional :: status |
607 |
|
|
external mpi_reduce_scatter |
608 |
|
|
|
609 |
|
|
if (present(status)) status = 0 |
610 |
|
|
|
611 |
|
|
call mpi_reduce_scatter(sbuffer,rbuffer, this_plan%counts, & |
612 |
|
|
mpi_double_precision, MPI_SUM, this_plan%comm, mpi_err) |
613 |
|
|
|
614 |
|
|
if (mpi_err /= 0) then |
615 |
|
|
if (present(status)) status = -1 |
616 |
|
|
endif |
617 |
|
|
|
618 |
|
|
end subroutine scatter_double |
619 |
|
|
|
620 |
|
|
subroutine scatter_double_dim( sbuffer, rbuffer, this_plan, status) |
621 |
|
|
|
622 |
|
|
type (gs_plan), intent(in) :: this_plan |
623 |
|
|
real( kind = DP ), dimension(:,:), intent(in) :: sbuffer |
624 |
|
|
real( kind = DP ), dimension(:,:), intent(in) :: rbuffer |
625 |
|
|
integer, intent(out), optional :: status |
626 |
|
|
external mpi_reduce_scatter |
627 |
|
|
|
628 |
|
|
if (present(status)) status = 0 |
629 |
|
|
call mpi_reduce_scatter(sbuffer,rbuffer, this_plan%counts, & |
630 |
|
|
mpi_double_precision, MPI_SUM, this_plan%comm, mpi_err) |
631 |
|
|
|
632 |
|
|
if (mpi_err /= 0) then |
633 |
|
|
if (present(status)) status = -1 |
634 |
|
|
endif |
635 |
|
|
|
636 |
|
|
end subroutine scatter_double_dim |
637 |
|
|
|
638 |
|
|
|
639 |
|
|
!!$ subroutine mpi_bcast_t(BUFFER, COUNT, DATATYPE, ROOT, COMM, & |
640 |
|
|
!!$ IERROR) |
641 |
|
|
!!$ character (len=*) :: BUFFER |
642 |
|
|
!!$ integer :: COUNT, DATATYPE, ROOT, COMM, IERROR |
643 |
|
|
!!$ external MPI_BCAST |
644 |
|
|
!!$ call MPI_BCAST(BUFFER, COUNT, DATATYPE, ROOT, COMM, IERROR) |
645 |
|
|
!!$ end subroutine mpi_bcast_t |
646 |
|
|
!!$ |
647 |
|
|
!!$ SUBROUTINE MPI_SEND_T(BUF, COUNT, DATATYPE, DEST, TAG, COMM, & |
648 |
|
|
!!$ IERROR) |
649 |
|
|
!!$ character(len=*), dimension(:) :: BUF |
650 |
|
|
!!$ INTEGER COUNT, DATATYPE, DEST, TAG, COMM, IERROR |
651 |
|
|
!!$ EXTERNAL MPI_SEND |
652 |
|
|
!!$ CALL MPI_SEND(BUF, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) |
653 |
|
|
!!$ END SUBROUTINE MPI_SEND_T |
654 |
|
|
!!$ |
655 |
|
|
!!$ subroutine mpi_recv_T(BUF, COUNT, DATATYPE, SOURCE, TAG, COMM, & |
656 |
|
|
!!$ STATUS, IERROR) |
657 |
|
|
!!$ USE MPI_CONSTANTS,ONLY: MPI_STATUS_SIZE |
658 |
|
|
!!$ character(len=*), dimension(:) :: BUF |
659 |
|
|
!!$ INTEGER COUNT, DATATYPE, SOURCE, TAG, COMM, & |
660 |
|
|
!!$ & STATUS(MPI_STATUS_SIZE), IERROR |
661 |
|
|
!!$ EXTERNAL MPI_RECV |
662 |
|
|
!!$ CALL MPI_RECV(BUF, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, & |
663 |
|
|
!!$ & IERROR) |
664 |
|
|
!!$ end subroutine mpi_recv_T |
665 |
|
|
|
666 |
|
|
|
667 |
|
|
!!$ SUBROUTINE MPI_SEND_char(BUF, COUNT, DATATYPE, DEST, TAG, COMM, & |
668 |
|
|
!!$ IERROR) |
669 |
|
|
!!$ character(len=*) :: BUF |
670 |
|
|
!!$ INTEGER COUNT, DATATYPE, DEST, TAG, COMM, IERROR |
671 |
|
|
!!$ EXTERNAL MPI_SEND |
672 |
|
|
!!$ CALL MPI_SEND(BUF, COUNT, DATATYPE, DEST, TAG, COMM, IERROR) |
673 |
|
|
!!$ END SUBROUTINE MPI_SEND_char |
674 |
|
|
!!$ |
675 |
|
|
!!$ subroutine mpi_recv_char(BUF, COUNT, DATATYPE, SOURCE, TAG, COMM, & |
676 |
|
|
!!$ STATUS, IERROR) |
677 |
|
|
!!$ USE MPI_CONSTANTS,ONLY: MPI_STATUS_SIZE |
678 |
|
|
!!$ character(len=*) :: BUF |
679 |
|
|
!!$ INTEGER :: COUNT, DATATYPE, SOURCE, TAG, COMM, & |
680 |
|
|
!!$ STATUS(MPI_STATUS_SIZE), IERROR |
681 |
|
|
!!$ EXTERNAL MPI_RECV |
682 |
|
|
!!$ CALL MPI_RECV(BUF, COUNT, DATATYPE, SOURCE, TAG, COMM, STATUS, & |
683 |
|
|
!!$ IERROR) |
684 |
|
|
!!$ end subroutine mpi_recv_char |
685 |
|
|
|
686 |
|
|
#endif |
687 |
|
|
end module mpi_module |
688 |
|
|
|