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
|
program fmpi_sane
*
* This program checks to make sure that you can run a basic program
* on your machine using the Fortran77 interface to MPI.
* Can increase parameter wastesz, if you think size of executable
* is causing launching problem.
*
include 'mpif.h'
integer nproc, wastesz
parameter (nproc = 4)
parameter (wastesz = 100)
integer i, Iam, Np, ierr
integer mcom, wgrp, mgrp
integer irank(nproc), stat(MPI_STATUS_SIZE)
double precision WasteSpc(wastesz)
call mpi_init(ierr)
call mpi_comm_size(MPI_COMM_WORLD, Np, ierr)
if (Np .lt. nproc) then
print*,'Not enough processes to run sanity check'
call mpi_abort(MPI_COMM_WORLD, -1, ierr)
end if
*
* Access all of WasteSpc
*
do 10 i = 1, wastesz
WasteSpc(i) = 0.0D0
10 continue
*
* Form context with NPROC members
*
do 20 i = 1, nproc
irank(i) = i - 1
20 continue
call mpi_comm_group(MPI_COMM_WORLD, wgrp, ierr)
call mpi_group_incl(wgrp, nproc, irank, mgrp, ierr)
call mpi_comm_create(MPI_COMM_WORLD, mgrp, mcom, ierr)
call mpi_group_free(mgrp, ierr)
*
* Everyone in new communicator sends a message to his neighbor
*
if (mcom .ne. MPI_COMM_NULL) then
call mpi_comm_rank(mcom, Iam, ierr)
*
* Odd nodes receive first, so we don't hang if MPI_Send is
* globally blocking
*
if (mod(Iam, 2) .ne. 0) then
call mpi_recv(i, 1, MPI_INTEGER, MOD(nproc+Iam-1, nproc),
& 0, mcom, stat, ierr)
call mpi_send(Iam, 1, MPI_INTEGER, MOD(Iam+1, nproc),
& 0, mcom, ierr)
else
call mpi_send(Iam, 1, MPI_INTEGER, MOD(Iam+1, nproc),
& 0, mcom, ierr)
call mpi_recv(i, 1, MPI_INTEGER, MOD(nproc+Iam-1, nproc),
& 0, mcom, stat, ierr)
end if
*
* Make sure we've received the right information
*
if (i .ne. MOD(nproc+Iam-1, nproc)) then
print*,'Communication does not seem to work properly!!'
call mpi_abort(MPI_COMM_WORLD, -1, ierr)
end if
end if
print*,Iam,' F77 MPI sanity test passed.'
call mpi_finalize(ierr)
stop
end
|
