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
|
!
! Copyright (C) by Argonne National Laboratory
! See COPYRIGHT in top-level directory
!
! This test makes use of routines to access the command line added in
! Fortran 2003
!
program main
! declared on the old sparc compilers
use mpi_f08
integer errs, err
integer rank, size, rsize, i
integer np
integer errcodes(2)
type(MPI_Comm) parentcomm, intercomm
type(MPI_Status) status
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 comm_size
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
! Create 2 more processes
call MPI_Comm_spawn( "./spawnargvf03", inargv, np, &
& MPI_INFO_NULL, 0, MPI_COMM_WORLD, intercomm, errcodes, &
& ierr )
else
intercomm = parentcomm
endif
! 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
! 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
! We could use intercomm reduce to get the errors from the
! children, but we'll use a simpler loop to make sure that
! 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
! Child
! FIXME: This assumes that stdout is handled for the children
! (the error count will still be reported to the parent)
argc = command_argument_count()
do i=1, argc
call get_command_argument( 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
! 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
! We had too few args in the spawned command
errs = errs + 1
print *, "Too few arguments to spawned command"
endif
! Send the errs back to the parent process
call MPI_Ssend( errs, 1, MPI_INTEGER, 0, 1, intercomm, ierr )
endif
! It isn't necessary to free the intercomm, but it should not hurt
call MPI_Comm_free( intercomm, ierr )
! 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
|
