prismdrv_def_mpi_comm.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_Def_MPI_Comm
!
! !INTERFACE
subroutine prismdrv_def_mpi_comm (id_err)

!
! !USES:
!
  USE PRISMDrv, dummy_interface => PRISMDrv_Def_MPI_Comm
!
  IMPLICIT NONE
!
! !PARAMETERS:
!

!
! ! RETURN VALUE
!
  INTEGER, INTENT (Out)               :: id_err

! !DESCRIPTION
! Subroutines "PRISMDrv_Def_mpi_comm" establishes basic communicators
! for code local and application-communication.
!
! !REVISED HISTORY
!   Date      Programmer   Description
! ----------  ----------   -----------
! 04/10/2002  R. Redler    Creation
! 25/11/2002  D. Declat    Merge with driver implementation
! EOP
!----------------------------------------------------------------------
! $Id: prismdrv_def_mpi_comm.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!----------------------------------------------------------------------
!
! 0. Local declarations
!
  CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
     '$Id: prismdrv_def_mpi_comm.F90 2325 2010-04-21 15:00:07Z valcke $'

  INTEGER                             :: index
  INTEGER                             :: key
  INTEGER                             :: color
  INTEGER                             :: comm
  
  INTEGER, PARAMETER :: nerrp = 1
  INTEGER            :: ierrp (nerrp)

! ---------------------------------------------------------------------
!
#ifdef VERBOSE
  PRINT *, '| | Enter PRISMDrv_Def_mpi_comm'
  call psmile_flushstd
#endif
! a) Initialization
! -----------------

! b) Construct communicator for code local communication
! ------------------------------------------------------

  key   = 0
  color = 0
  
  CALL MPI_Comm_Split ( comm_drv_global, color, key, comm_drv_local, id_err )

  IF ( id_err /= MPI_SUCCESS ) THEN
      ierrp (1) = id_err
      id_err = PRISM_Error_MPI
      
      call psmile_error_common ( id_err, 'MPI_Comm_Split', &
         ierrp, 1, __FILE__, __LINE__ )
      RETURN
  ENDIF

! c)  Construct communicator for communication between coupler and application
! ----------------------------------------------------------------------------

  DO INDEX = 1, ig_nb_appl

! i.)  Set one color for each pair [application(index), coupler]

    key   = 0
    color = INDEX

! ii.) Generate a communicator for each pair

    CALL MPI_Comm_Split ( comm_drv_global, color, key, comm, id_err )

    IF ( id_err /= MPI_SUCCESS ) THEN
        ierrp (1) = id_err
        id_err = PRISM_Error_MPI
      
        call psmile_error_common ( id_err, 'MPI_Comm_Split', &
           ierrp, 1, __FILE__, __LINE__ )
        RETURN
    ENDIF

! iii.) Save the communicator for communication from application to coupler

    comm_coupling(index) = comm

    CALL MPI_Comm_Rank ( comm_coupling(index), driver_rank, id_err )

    IF ( id_err /= MPI_SUCCESS ) THEN
        ierrp (1) = id_err
        id_err = PRISM_Error_MPI
      
        call psmile_error_common ( id_err, 'MPI_Comm_Rank', &
           ierrp, 1, __FILE__, __LINE__ )
        RETURN
    ENDIF

  END DO


! d)  Construct a communicator comm_psmile containing all MPI processes
!     which are connected to the PSMILe library
! ----------------------------------------------------------------------------

  key   = 0
  color = MPI_UNDEFINED

  CALL MPI_Comm_Split ( comm_drv_global, color, key,  &
     comm_psmile, id_err )
  
  IF ( id_err /= MPI_SUCCESS ) THEN
      ierrp (1) = id_err
      id_err = PRISM_Error_MPI
      
      call psmile_error_common ( id_err, 'MPI_Comm_Split', &
         ierrp, 1, __FILE__, __LINE__ )
      RETURN
  ENDIF
!
! ---------------------------------------------------------------------
!
#ifdef VERBOSE
  PRINT *, '| | Quit PRISMDrv_Def_MPI_Comm'
  call psmile_flushstd
#endif
END SUBROUTINE PRISMDrv_Def_MPI_Comm