psmile_def_mpi_compcomm.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_CompComm
!
! !INTERFACE:
!
      subroutine psmile_def_mpi_compcomm ( ierror )

! !USES:
!
      use PRISM_constants
      use PSMILe, dummy_interface => PSMILe_Def_MPI_CompComm

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

!     Returns the error code of PSMILe_Def_MPI_CompComm;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      integer            :: noRankset
      integer            :: my_rank, my_size
      integer            :: comp_rank, min_rank, max_rank, inc_rank
      integer            :: color
      integer            :: key
      integer            :: i
      integer            :: comp_index, n_comps
      integer            :: rankset_index

      Integer, parameter :: nerrp = 2
      Integer            :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine PSMILe_Def_MPI_CompComm defines the communicators
! for component local communication.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 01.12.03    R. Redler    created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_def_mpi_compcomm.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_def_mpi_compcomm.F90 2325 2010-04-21 15:00:07Z valcke $'
!
! ---------------------------------------------------------------------

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

      call psmile_flushstd
#endif /* VERBOSE */

! ---------------------------------------------------------------------
!  Get the current rank within the application communicator
! ---------------------------------------------------------------------

      call MPI_Comm_Rank ( Appl%comm, my_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, my_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

      comp_index = 1

      do i = 2, Appl%sequence_number
         comp_index = comp_index + PRISM_noCompsPerAppl(i-1)
      enddo

      rankset_index = 1

      do i = 2, comp_index
         rankset_index = rankset_index + PRISM_compRankSets(i-1)
      enddo

! ---------------------------------------------------------------------
!  Now loop over the components in the application
! ---------------------------------------------------------------------

      n_comps = PRISM_noCompsPerAppl(Appl%sequence_number)

      Comps(1:n_comps)%comm      = MPI_COMM_NULL
      Comps(1:n_comps)%comm_user = MPI_COMM_NULL

      do i = 1, n_comps
         key                = 0
         ierror             = 0

! ---------------------------------------------------------------------
!  ... and see whether this rank is found in one of the lists for this
!       particular component
! ---------------------------------------------------------------------

         do noRankset = rankset_index, rankset_index + PRISM_compRankSets(i) - 1

            min_rank = PRISM_rankSets (noRankset,1)
            max_rank = PRISM_rankSets (noRankset,2)
            inc_rank = PRISM_rankSets (noRankset,3)
 
            color = 0

            do comp_rank = min_rank, max_rank, inc_rank

               if ( comp_rank > my_size - 1 ) then

                  ierrp (1) = comp_rank
                  ierrp (2) = my_size - 1
                  ierror = PRISM_Error_Parameter

                  call psmile_error ( ierror, 'nbr_procs comming from SCC', &
                       ierrp, 2, __FILE__, __LINE__ )
                  return

               endif

               if ( comp_rank == my_rank ) color = 1

            enddo

         enddo

         call MPI_Comm_Split ( Appl%comm, color, key, Comps(i)%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

#ifdef PRISM_ASSERTION
         if ( Comps(i)%comm == MPI_COMM_NULL ) then
            call psmile_assert ( __FILE__, __LINE__, &
         'Null Communicator generated')
         endif
#endif /* PRISM_ASSERTION */

         call MPI_Comm_dup ( Comps(i)%comm, Comps(i)%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

      enddo ! i-loop

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

      call psmile_flushstd
#endif /* VERBOSE */

      end subroutine PSMILe_Def_MPI_CompComm