1 |
|
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 |
|