Shintaro Iwasaki
5ef6367f73
Specifically, this patch makes the following changes. build scripts: - master_top_srcdir -> main_top_srcdir Git: - "master" -> "main" branch (variable names and comments) global structures and variables: - MPIR_ThreadInfo.master_thread -> MPIR_ThreadInfo.main_thread - struct PMIMaster -> struct PMIMain - PMI2_Connect_comm_t.isMaster -> PMI2_Connect_comm_t.isMain names of tests: - spawntest_master -> spawntest_parent - taskmaster -> taskmanager - th_taskmaster -> th_taskmanager` comments and names of temporary/local variables: - master -> main, parent, server, ... - slave -> child, worker, client, ...
157 linhas
5.7 KiB
FortranFixed
157 linhas
5.7 KiB
FortranFixed
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 This tests spawn_mult by using the same executable but different
|
|
C command-line options.
|
|
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, wsize, i
|
|
integer np(2)
|
|
integer infos(2)
|
|
integer errcodes(2)
|
|
integer parentcomm, intercomm
|
|
integer status(MPI_STATUS_SIZE)
|
|
character*(10) inargv(2,6), outargv(2,6)
|
|
character*(30) cmds(2)
|
|
character*(80) argv(64)
|
|
integer argc
|
|
integer ierr
|
|
integer can_spawn
|
|
C
|
|
C Arguments are stored by rows, not columns in the vector.
|
|
C We write the data in a way that looks like the transpose,
|
|
C since Fortran stores by column
|
|
data inargv /"a", "-p", &
|
|
& "b=c", "27", &
|
|
& "d e", "-echo", &
|
|
& "-pf", " ", &
|
|
& "Ss", " ", &
|
|
& " ", " "/
|
|
data outargv /"a", "-p", &
|
|
& "b=c", "27", &
|
|
& "d e", "-echo", &
|
|
& "-pf", " ", &
|
|
& "Ss", " ", &
|
|
& " ", " "/
|
|
|
|
errs = 0
|
|
|
|
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
|
|
cmds(1) = "./spawnmultf"
|
|
cmds(2) = "./spawnmultf"
|
|
np(1) = 1
|
|
np(2) = 1
|
|
infos(1)= MPI_INFO_NULL
|
|
infos(2)= MPI_INFO_NULL
|
|
call MPI_Comm_spawn_multiple( 2, cmds, inargv, &
|
|
& np, infos, 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(1) + np(2)) then
|
|
errs = errs + 1
|
|
print *, "Did not create ", np(1)+np(2), &
|
|
& " 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. 2) then
|
|
errs = errs + 1
|
|
print *, "(Child) Did not create ", 2, &
|
|
& " processes (got ",size, ")"
|
|
call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
|
|
if (wsize .eq. 2) then
|
|
errs = errs + 1
|
|
print *, "(Child) world size is 2 but ", &
|
|
& " local intercomm size is not 2"
|
|
endif
|
|
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(rank+1,i) .eq. " ") then
|
|
errs = errs + 1
|
|
print *, "Wrong number of arguments (", argc, ")"
|
|
goto 200
|
|
endif
|
|
if (argv(i) .ne. outargv(rank+1,i)) then
|
|
errs = errs + 1
|
|
print *, "Found arg ", argv(i), " but expected ", &
|
|
& outargv(rank+1,i)
|
|
endif
|
|
enddo
|
|
200 continue
|
|
if (outargv(rank+1,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
|