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
|
C
C Copyright (C) by Argonne National Laboratory
C See COPYRIGHT in top-level directory
C
C This is a special test that requires an getarg/iargc routine
C
program main
C This implicit none is removed here because the iargc was not
C declared on the old sparc compilers
C implicit none
include 'mpif.h'
integer errs, err
integer rank, size, rsize, i
integer np
integer errcodes(2)
integer parentcomm, intercomm
integer status(MPI_STATUS_SIZE)
character*(10) inargv(6), outargv(6)
character*(80) argv(64)
integer argc
data inargv /"a", "b=c", "d e", "-pf", " Ss", " " /
data outargv /"a", "b=c", "d e", "-pf", "Ss", " " /
integer ierr
integer can_spawn
errs = 0
np = 2
call MTest_Init( ierr )
call MTestSpawnPossible( can_spawn, errs )
if ( can_spawn .eq. 0 ) then
call MTest_Finalize( errs )
goto 300
endif
call MPI_Comm_get_parent( parentcomm, ierr )
if (parentcomm .eq. MPI_COMM_NULL) then
C Create 2 more processes
call MPI_Comm_spawn( "./spawnargvf", inargv, np,
$ MPI_INFO_NULL, 0, MPI_COMM_WORLD, intercomm, errcodes,
$ ierr )
else
intercomm = parentcomm
endif
C We now have a valid intercomm
call MPI_Comm_remote_size( intercomm, rsize, ierr )
call MPI_Comm_size( intercomm, size, ierr )
call MPI_Comm_rank( intercomm, rank, ierr )
if (parentcomm .eq. MPI_COMM_NULL) then
C Parent
if (rsize .ne. np) then
errs = errs + 1
print *, "Did not create ", np, " processes (got
$ ", rsize, ")"
endif
do i=0, rsize-1
call MPI_Send( i, 1, MPI_INTEGER, i, 0, intercomm, ierr )
enddo
C We could use intercomm reduce to get the errors from the
C children, but we'll use a simpler loop to make sure that
C we get valid data
do i=0, rsize-1
call MPI_Recv( err, 1, MPI_INTEGER, i, 1, intercomm,
$ MPI_STATUS_IGNORE, ierr )
errs = errs + err
enddo
else
C Child
C FIXME: This assumes that stdout is handled for the children
C (the error count will still be reported to the parent)
argc = iargc()
do i=1, argc
call getarg( i, argv(i) )
enddo
if (size .ne. np) then
errs = errs + 1
print *, "(Child) Did not create ", np, " processes (got ",
$ size, ")"
endif
call MPI_Recv( i, 1, MPI_INTEGER, 0, 0, intercomm, status, ierr
$ )
if (i .ne. rank) then
errs = errs + 1
print *, "Unexpected rank on child ", rank, "(",i,")"
endif
C Check the command line
do i=1, argc
if (outargv(i) .eq. " ") then
errs = errs + 1
print *, "Wrong number of arguments (", argc, ")"
goto 200
endif
if (argv(i) .ne. outargv(i)) then
errs = errs + 1
print *, "Found arg ", argv(i), " but expected ",
$ outargv(i)
endif
enddo
200 continue
if (outargv(i) .ne. " ") then
C We had too few args in the spawned command
errs = errs + 1
print *, "Too few arguments to spawned command"
endif
C Send the errs back to the parent process
call MPI_Ssend( errs, 1, MPI_INTEGER, 0, 1, intercomm, ierr )
endif
C It isn't necessary to free the intercomm, but it should not hurt
call MPI_Comm_free( intercomm, ierr )
C Note that the MTest_Finalize get errs only over COMM_WORLD
if (parentcomm .eq. MPI_COMM_NULL) then
call MTest_Finalize( errs )
else
call MPI_Finalize( ierr )
endif
300 continue
end
|
