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, ...
136 linhas
4.4 KiB
FortranFixed
136 linhas
4.4 KiB
FortranFixed
C
|
|
C Copyright (C) by Argonne National Laboratory
|
|
C See COPYRIGHT in top-level directory
|
|
C
|
|
|
|
C This tests spawn_mult by using the same executable and no command-line
|
|
C options. The attribute MPI_APPNUM is used to determine which
|
|
C executable is running.
|
|
C
|
|
program main
|
|
implicit none
|
|
include 'mpif.h'
|
|
include 'type1aint.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*(30) cmds(2)
|
|
integer appnum
|
|
logical flag
|
|
integer ierr
|
|
integer can_spawn
|
|
|
|
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) = "./spawnmult2f"
|
|
cmds(2) = "./spawnmult2f"
|
|
np(1) = 1
|
|
np(2) = 1
|
|
infos(1)= MPI_INFO_NULL
|
|
infos(2)= MPI_INFO_NULL
|
|
call MPI_Comm_spawn_multiple( 2, cmds, MPI_ARGVS_NULL, &
|
|
& 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
|
|
C Allow a multi-process parent
|
|
if (rank .eq. 0) then
|
|
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
|
|
endif
|
|
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)
|
|
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
|
|
C Check for correct APPNUM
|
|
call mpi_comm_get_attr( MPI_COMM_WORLD, MPI_APPNUM, aint, &
|
|
& flag, ierr )
|
|
C My appnum should be my rank in comm world
|
|
if (flag) then
|
|
appnum = aint
|
|
if (appnum .ne. rank) then
|
|
errs = errs + 1
|
|
print *, "appnum is ", appnum, " but should be ", rank
|
|
endif
|
|
else
|
|
errs = errs + 1
|
|
print *, "appnum was not set"
|
|
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
|