prismdrv_spawn_child.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !Routine: PRISMDrv_spawn_child
!
! !INTERFACE:

subroutine prismdrv_spawn_child ( exec, args, n_args, application_number, &
   n_hosts, hostnames, npes, intracomm, intercomm, ierror )
!
! !USES:
  USE PRISMDrv, dummy_interface => prismdrv_spawn_child 

  IMPLICIT NONE
!
! !PARAMETERS:
!
  character(len=*),Intent(In)         :: exec
!
!     Name of executable
!
  integer,Intent(In)                  :: n_args
!
!     Number of arguments
!
  character(len=*),Intent(In)         :: args (n_args)
!
!     List of arguments for the exceutable
!
  integer,Intent(In)                  :: application_number
!
!     Number of the application; used to specify the application group
!
  integer,Intent(In)                  :: n_hosts
!
!     Host names on which the processes should be spawned
!
  character(len=*),Intent(In)         :: hostnames (n_hosts)
!
!     Number of hosts 
!
  integer,Intent(In)                  :: npes (n_hosts)
!
!     Number of processes to be spawned per host
!
  integer, Intent(In)                 :: intracomm
!
!     Intra communicator used to spawn the processes
!
  integer,Intent(Out)                 :: intercomm
!
!     Resulting Inter communicator
!
  integer,Intent(Out)                 :: ierror
!
!     Error status
!
! !DESCRIPTION:
!
!     to spawn processes, called form the coupler
!
!
! !REVISION HISTORY:
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03/12/2001  R. Redler    created
!
! EOP
!----------------------------------------------------------------------
! $Id: prismdrv_spawn_child.F90 2889 2011-01-14 12:18:54Z hanke $
! $Author: hanke $
!----------------------------------------------------------------------

#if ! defined ( PRISM_with_MPI1 )
!
! Local declaration
!
  character(len=64)                  :: commands (n_hosts)
  character(len=64)                  :: argv (n_hosts, n_args+1)
  character(len=8)                   :: appl_group
  integer                            :: info (n_hosts)
  integer                            :: n ! Total number of processes
  integer                            :: i

#ifdef DONT_HAVE_ERRORCODES_IGNORE
  integer, allocatable               :: ierrors (:)
#endif

! ---------------------------------------------------------------------
!
  PRINT *, '| | Enter PRISMDrv_spawn_child'
  call psmile_flushstd
!
! Initialisation
!
  intercomm = MPI_COMM_NULL
  ierror    = 0
!
! Compute total number of processes to be spawned
!
  n = 0
  do i = 1, n_hosts
    n = n + max (0, npes(i))
  enddo
!
! Set constant arguments
!
  commands (1:n_hosts) = exec
!
  do i = 1, n_hosts
    argv (i, 1:n_args) = args (1:n_args)
  enddo
!
  argv (1:n_hosts, n_args+1) = ' '
!
! Create info objects for spawning the processes
!
  write (appl_group, "(i8)") application_number
!
! ... Set info argument for each host
!
# if !  defined ( PRISM_LAM )
  do i = 1, n_hosts
    call MPI_Info_create (info(i), ierror)
!
! ... Specify host name on which the processes should be spawned
!
    call MPI_Info_set (info(i), "host", hostnames(i), ierror)
!
! ... Specify further info's for spawning of processes
!
!     These infos may be system dependent and should be ignored
!     by the system which don't support them.
!
!     The application group specifies a set of processes which should
!     simultaneously run; i.e. they should be simultaneously swapped
!     in and out in order to avoid waitinf for processes swapped out.
!
    call MPI_Info_set (info(i), "appl_group", appl_group, ierror)
!
  enddo
!
! Spawn processes 
!
#else
  info = MPI_INFO_NULL
#endif

#ifdef DONT_HAVE_ERRORCODES_IGNORE
!
! ... Allocate error codes for processes (1 code per process !)
!
  Allocate (ierrors(1:n))

  call MPI_Comm_spawn_multiple ( n_hosts, commands, argv, npes,  &
     info, PRISM_root, intracomm, intercomm, ierrors, ierror     )
#else
  call MPI_Comm_spawn_multiple (n_hosts, commands, argv, npes, info,  &
     PRISM_root, intracomm, intercomm, MPI_ERRCODES_IGNORE, ierror    )
#endif
!
! Free info object
!
# if ! defined ( PRISM_LAM )
  do i = 1, n_hosts
    call MPI_Info_free  ( info(i), ierror )
  end do
#endif
!
! Deallocate error codes
!
#ifdef DONT_HAVE_ERRORCODES_IGNORE
  Deallocate (ierrors)
#endif
!
! Formats
!
1000 format (1x, '| | | Spawning ', a, ' on', i4, ' processe(s) and', i3, &
     ' host(s).' )

  PRINT *, '| | Quit PRISMDrv_spawn_child'
  PRINT *, '| |'
  call psmile_flushstd

#else
  intercomm = MPI_COMM_NULL
  ierror    = 0
#endif

END SUBROUTINE PRISMDrv_spawn_child

#ifdef DONT_HAVE_STDMPI2
      subroutine MPI_Comm_spawn_multiple ( n_hosts, commands, argv, &
                                    npes, dummy1, root, intracomm,  &
                                    intercomm, dummy2, ierror)

      integer            :: dummy1, dummy2
      integer            :: n_hosts
      integer            :: root
      integer            :: npes (n_hosts)
      character(len=1)   :: commands (n_hosts)
      character(len=1)   :: argv (n_hosts, 1)
      integer            :: intracomm, intercomm, ierror

      Integer, parameter :: nerrp = 1
      Integer            :: ierrp (nerrp)

         call psmile_error_common ( -1, 'Spawing not support with this MPI', &
            ierrp, 1, __FILE__, __LINE__ )

         return
      end
#endif