psmile_def_mpi_comm.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_Def_MPI_Comm
!
! !INTERFACE:
!
      subroutine psmile_def_mpi_comm (ierror)
!
! !USES:
!
      use PRISM_constants
      use PSMILe, dummy_interface => PSMILe_Def_MPI_Comm

      implicit none
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out) :: ierror

!     Returns the error code of PSMILe_get_initial_data;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      integer            :: index
      integer            :: key
      integer            :: color
      integer            :: comm

      integer, parameter :: nerrp = 1
      integer            :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine PSMILe_Def_MPI_Comm defines the communicators
! if all processes were simultaneously started by the mpirun/mpiexec
! command.
!
! The routine assumes that communicator "comm_global" is defined.

! It constructs the     communicator for the application "Appl%comm",
!               the user communicator of the application "Appl%comm_user" and
!               the communicator with the coupler "comm_coupler".
!               the communicator for the PSMILe library "comm_psmile".
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 01.12.03    R. Redler    created
!
!EOP
!-----------------------------------------------------------------------
!
! $Id: psmile_def_mpi_comm.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_def_mpi_comm.F90 2325 2010-04-21 15:00:07Z valcke $'
!
! ----------------------------------------------------------------------

#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_Def_MPI_Comm: start'

      call psmile_flushstd
#endif /* VERBOSE */
!
! Create Application Communicator
!
      if ( Appl%stand_alone ) then

         comm_coupler = MPI_COMM_NULL

         call MPI_Comm_dup ( comm_global, Appl%comm, ierror )

         if ( ierror /= MPI_SUCCESS ) then
            ierrp (1) = ierror
            ierror = PRISM_Error_MPI

            call psmile_error ( ierror, 'MPI_Comm_dup', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
         endif

      else
!
! 1st Define Communicator for subgroups
! --------------------------------------


! a) Build communicator for application local communication
! ---------------------------------------------------------
!
! Appl%sequence_number is determined in psmile_init_mpi1
!
         print *, trim(ch_id), ': Colored application with ', &
              Appl%sequence_number

         key   = 0
         color = Appl%sequence_number

         call MPI_Comm_Split ( comm_global, color, key, &
              Appl%comm, ierror )

         if ( ierror /= MPI_SUCCESS ) then
            ierrp (1) = ierror
            ierror = PRISM_Error_MPI

            call psmile_error ( ierror, 'MPI_Comm_Split', &
                 ierrp, 1, __FILE__, __LINE__ )
            return
         endif

! b) Build communicator for communication between coupler and application
! -----------------------------------------------------------------------
!
         do index = 1, noApplication

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

            if ( index == Appl%sequence_number ) then
                color = index
            else
                color = MPI_UNDEFINED
            end if

            if ( Appl%sequence_number == 0 ) color = index

! ii.) Generate a communicator for each pair

            call MPI_Comm_Split ( comm_global, color, key,   &
                                  comm, ierror )

            if ( ierror /= MPI_SUCCESS ) then
               ierrp (1) = ierror
               ierror = PRISM_Error_MPI

               call psmile_error ( ierror, 'MPI_Comm_Split', &
                                   ierrp, 1, __FILE__, __LINE__ )
               return
            endif

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

            if ( index == Appl%sequence_number ) then

               comm_coupler = comm

               call MPI_Comm_Rank ( comm_coupler, coupler_rank, ierror )

               if ( ierror /= MPI_SUCCESS ) then
                  ierrp (1) = ierror
                  ierror = PRISM_Error_MPI
                  call psmile_error ( ierror, 'MPI_Comm_Rank', &
                               ierrp, 1,  __FILE__, __LINE__ )
                  return
                endif

            endif

         end do  ! 'do index = 1, noApplication'

      endif ! Appl%stand_alone

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

      key   = 0
      color = 1
      
      call MPI_Comm_Split ( comm_global, color, key,  &
                            comm_psmile, ierror )
      
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI
         call psmile_error ( ierror, 'MPI_Comm_Split', &
                         ierrp, 1,  __FILE__, __LINE__ )
         return
      endif

! -----------------------------------------------------------------------
! d)  Construct communicator for user application and
!     get rank within comm_appl

      call MPI_Comm_dup ( Appl%comm, Appl%comm_user, ierror )

      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Comm_dup', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif

      call MPI_Comm_rank ( Appl%comm,  Appl%rank, ierror )

      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Comm_rank', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif

      call MPI_Comm_size ( Appl%comm,  Appl%size, ierror )

      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Comm_rank', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif

#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_Def_MPI_Comm: eof ierror =', ierror

      call psmile_flushstd
#endif /* VERBOSE */

      end subroutine PSMILe_Def_MPI_Comm