psmile_spawn_child_appl.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PSMILe_Spawn_Child_Appl
!
! !INTERFACE:

      subroutine psmile_spawn_child_appl (intracomm, intercomm, ierror )
!
! !USES:
!
      use PRISM_constants
      use PSMILe, dummy_interface => PSMILe_Spawn_Child_Appl
      implicit none
!
! !INPUT PARAMETERS:
!
      integer, Intent(In)                 :: intracomm
!
!     Intra communicator used to spawn the processes
!
!
! !OUTPUT PARAMETERS:
!
      integer,Intent(Out)                 :: intercomm
!
!     Resulting Inter communicator
!
      integer,Intent(Out)                 :: ierror
!
!     Error status
!
! !LOCAL VARIABLES
!
      integer, parameter :: n_hosts = 1
!
#if ! defined ( PRISM_with_MPI1 )
!
! ... of dummy arguments of MPI_Comm_spawn_multiple
!
      integer            :: npes (n_hosts)
      character(len=1)   :: commands (n_hosts)
      character(len=1)   :: argv (n_hosts, 1)
#endif

#ifdef DONT_HAVE_ERRORCODES_IGNORE
      integer              :: infos (n_hosts), n
      integer, Allocatable :: ierrors (:)
      integer              :: ierrp(1)
#endif
!
! !DESCRIPTION:
!
! The MPI processes of the applications take part in the spawning
! of the MPI processes of other applications. This routine
! takes part in the spawning of the new application processes.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 02.11.02    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_spawn_child_appl.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_spawn_child_appl.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------

      ierror    = 0
      intercomm = MPI_COMM_NULL

#if ! defined ( PRISM_with_MPI1 )

!
! Spawn processes
!
#ifdef DONT_HAVE_ERRORCODES_IGNORE

!!$  MPI_INFO_NULL and MPI_ERRCODES_IGNORE are
!!$     not supported by all MPI implementations
!!$
! Info is significant only on the roots;
! therefore the dummy, not-initialized value should work
!
!     call MPI_Info_create (infos(1), ierror)
!
! ... Allocate error codes for processes (1 code per process !)
!
!     In principle, the number n must be transferred by MPI_Bcast
!     from the coupler to the processes in the applications
!     (or by another way).
!     Since I don't know whether this will work for the simulated
!     coupler and the real coupler, we set n to a ``large'' number.
!
      n = 1024
      Allocate (ierrors(1:n), STAT=ierror)
      if ( ierror /= 0 ) then
         ierrp (1) = n
         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'ierrors', &
              ierrp(1), 1, __FILE__, __LINE__ )
         return
      endif

      call MPI_Comm_spawn_multiple (n_hosts, commands, argv,        &
                                    npes, infos,                    &
                                    PRISM_root, intracomm,          &
                                    intercomm, ierrors,             &
                                    ierror)

      Deallocate (ierrors)
#else
      call MPI_Comm_spawn_multiple (n_hosts, commands, argv,        &
                                    npes, MPI_INFO_NULL,            &
                                    PRISM_root, intracomm,          &
                                    intercomm, MPI_ERRCODES_IGNORE, &
                                    ierror)
#endif
#endif

      end subroutine PSMILe_Spawn_Child_Appl

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

      integer            :: dummy1, dumm2
      integer            :: n_hosts, 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 ( ierror, 'Spawing not support with this MPI', &
                          ierrp, 1, __FILE__, __LINE__ )

      return
      end
#endif