Source

mpi3-fortran / ompi / mpi / fortran / tests / src / test_comm_spawn.f90

Full commit
Program test_comm_spawn
!=====================================================================
!
!       test_comm_spawn
!
! A program to test MPI_Comm_spawn and _multiple
!
!=====================================================================

  Use  ::  MPI_F08
  Implicit None
  
  Integer             ::  maxprocs(2) = [1, 1]
  Integer             ::  root        = 0
  Integer             ::  errcodes(2), err
  
  Character(len=32)   ::  cmd
  Character(len=32)   ::  cmds(2)
  Character(len=32)   ::  argv(3)
  Character(len=32)   ::  argvs(2,3)
  
  Type(MPI_COMM)      ::  intercomm
  Type(MPI_INFO)      ::  info(2)
  
  Interface
     integer function check_argv(argv, len) &
          BIND(C, name="check_argv")
       use, intrinsic :: ISO_C_BINDING, only : C_CHAR, C_INT
       implicit none
       character(kind=C_CHAR), dimension(*), intent(in) :: argv
       integer(C_INT), value, intent(in) :: len
     end function check_argv
     
     integer function check_argvs(count, argvs, len) &
          BIND(C, name="check_argvs")
       use, intrinsic :: ISO_C_BINDING, only : C_CHAR, C_INT
       implicit none
       character(kind=C_CHAR), dimension(*), intent(in) :: argvs
       integer(C_INT), value, intent(in) :: count, len
     end function check_argvs
  End Interface
  
!---------------------------------------------------------------------

  cmd = "test_init_finalize"
  
  argv(1) = "cmd1_arg1"
  argv(2) = "cmd1_arg2"
  argv(3) = " "
  
  err = check_argv(argv, len(argv))
  if (err /= 0) stop "check_argv failure"
  
  cmds(1) = "test_init_finalize"
  cmds(2) = "test_proc_name"
  
  argvs(1,1) = "cmd1_arg1"
  argvs(1,2) = "cmd1_arg2"
  argvs(1,3) = " "
  
  argvs(2,1) = "cmd2_arg1"
  argvs(2,2) = "cmd2_arg2"
  argvs(2,3) = " "
  
  err = check_argvs(2, argvs, len(argvs))
  if (err /= 0) stop "check_argvs failure"
  
  Call MPI_Init
  
  info(1) = MPI_INFO_NULL
  info(2) = MPI_INFO_NULL
  
  Call MPI_Comm_spawn(cmd, argv, maxprocs(1), info(1), root, MPI_COMM_WORLD, &
       intercomm, errcodes, err)
  if (err /= 0) stop "MPI_Comm_spawn failure"
  
  Call MPI_Comm_spawn_multiple(2, cmds, argvs, maxprocs, info, root, MPI_COMM_WORLD, &
       intercomm, errcodes, err)
  if (err /= 0) stop "MPI_Comm_spawn failure"
  
  Call MPI_Finalize
  
End Program test_comm_spawn


!subroutine MPI_Comm_spawn_f08(command,argv,maxprocs,info,root,comm,intercomm, &
!                              array_of_errcodes,ierror)
!   CHARACTER(LEN=*), INTENT(IN) :: command, argv(*)
!   INTEGER, INTENT(IN) :: maxprocs, root
!   TYPE(MPI_Info), INTENT(IN) :: info
!   TYPE(MPI_Comm), INTENT(IN) :: comm
!   TYPE(MPI_Comm), INTENT(OUT) :: intercomm
!   INTEGER :: array_of_errcodes(*)
!   INTEGER, OPTIONAL, INTENT(OUT) :: ierror

!subroutine MPI_Comm_spawn_multiple_f08(count,array_of_commands,array_of_argv,  &
!                                        array_of_maxprocs, &
!                                        array_of_info,root,comm,intercomm, &
!                                        array_of_errcodes,ierror)
!   INTEGER, INTENT(IN) :: count, array_of_maxprocs(*), root
!   CHARACTER(LEN=*), INTENT(IN) :: array_of_commands(*), array_of_argv(count,*)
!   TYPE(MPI_Info), INTENT(IN) :: array_of_info(*)
!   TYPE(MPI_Comm), INTENT(IN) :: comm
!   TYPE(MPI_Comm), INTENT(OUT) :: intercomm
!   INTEGER :: array_of_errcodes(*)
!   INTEGER, OPTIONAL, INTENT(OUT) :: ierror
!end subroutine MPI_Comm_spawn_multiple_f08