psmile_enddef_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.
!-----------------------------------------------------------------------
!
#ifdef DONT_HAVE_STDMPI2
#undef PRISM_with_MPI2
#endif
!
!BOP
!
! !ROUTINE: PSMILe_Enddef_appl
!
! !INTERFACE:

      subroutine psmile_enddef_appl (tag, my_icomp0_coll_comps, &
                                     n_active, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_enddef_appl

      implicit none
!
! !INPUT PARAMETERS:
!
      Integer,            Intent (In)  :: tag

!     Message tag to be used for point-to-point communication
!
! !OUTPUT PARAMETERS:
!
      Integer,            Intent (Out) :: my_icomp0_coll_comps

!     Index 0 of component information of actual application
!     in collected component information "all_comp_infos";
!     i.e. the component information of actual application is stored in
!     all_comp_infos(my_icomp0_coll_comps+1:
!                    my_icomp0_coll_comps+n_active)

      Integer,            Intent (Out) :: n_active
!
!     Number of components in actual application
!     = Number_of_comps_per_appl(Appl%sequence_number)

      Integer,            Intent (Out) :: ierror

!     Returns the error code of PSMILe_enddef_appl;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!  ... for coloring

      integer                      :: color, key
      integer                      :: comm_appl_roots, rank, size
      integer                      :: master_rank ! rank of master in comm_psmile
      logical                      :: i_am_master

!  ... for applications:

      integer                      :: iappl
      integer                      :: Number_of_comps_per_appl (noApplication)
      integer                      :: disp (noApplication)
      integer                      :: root_ranks (noApplication)

!  ... for MPI_Gather

      Type (Enddef_comp)           :: dummy_comp_info

!  ... for components:

      integer                      :: i, icomp, n, j

!  ... for exchanging of extents

      Real (PSMILe_float_kind), allocatable :: extents_buf(:,:,:)
      Integer, allocatable                  :: extent_info_buf(:,:)

!  ... Temporary vector in order to active component id's for the application

      Integer, allocatable         :: global_ids (:)
      Type (Enddef_comp), Pointer  :: b_comps (:)
      Integer                      :: comp_min, comp_max, n_miss
      Integer                      :: local_comp_min, local_comp_max

#ifndef PRISM_with_MPI2
      Integer, allocatable         :: global_ids_in (:)
#endif

!  ... for error parameters:

      integer, parameter           :: nerrp = 3
      integer                      :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Enddef_appl" finishs the definition phase for the
! application. The data of all components is stored in global array
! "all_comp_infos".
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.05.16    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_enddef_appl.F90 3248 2011-06-23 13:03:19Z coquart $
! $Author: coquart $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_enddef_appl.F90 3248 2011-06-23 13:03:19Z coquart $'
!
!----------------------------------------------------------------------

#ifdef VERBOSE
      print 9990, trim(ch_id)
      call psmile_flushstd
#endif /* VERBOSE */
!
!  Initialization
!
      ierror = 0
      master_rank = 0
      i_am_master = .false.
!
!-----------------------------------------------------------------------
!  Collect the data of active components of all application processes
!  within the application communicator "Appl%comm".
!
!  (*) Get comp_min = Minimum of global component id's
!  (*) Get comp_max = Maximum of global component id's
!  (*) Allocate vector global_ids (comp_min:comp_max)
!  (*) Get global_ids vector with
!      global_ids (comp_id) = Appl%rank: Component of global component id
!                                        "comp_id" is     active
!                                        in an application process.
!      global_ids (comp_id) = Appl%size: Component of global component id
!                                        "comp_id" is not active in an 
!                                        in an application process.
!-----------------------------------------------------------------------
!
      if (n_act_comp > 0) then
         local_comp_min = comp_infos(1)%global_comp_id
         local_comp_max = comp_infos(n_act_comp)%global_comp_id
      else
!
! hier gibt es doch bestimmt einen Wert aus der SCC info
! den man statt huge verwenden kann
!
         local_comp_min = huge (local_comp_max)
         local_comp_max = - local_comp_min
      endif
!
      call MPI_Allreduce (local_comp_min, comp_min, 1, &
                          MPI_INTEGER, MPI_MIN, Appl%comm, ierror)
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Allreduce(MPI_MIN)', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif
!
      call MPI_Allreduce (local_comp_max, comp_max, 1, &
                          MPI_INTEGER, MPI_MAX, Appl%comm, ierror)
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Allreduce(MPI_MAX)', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif
!
!  ... Is there an active component in the application ?
!
      if (comp_min > comp_max) then
         n_active = 0
      else
!
!  Allocate vector for all possible global comp id's
!
      Allocate (global_ids(comp_min:comp_max), STAT = ierror)
      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = comp_max - comp_min + 1
         call psmile_error ( PRISM_Error_Alloc, 'global_ids', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
!  Set Mask of global id's on local process
!
      global_ids (:) = Appl%size
!
      global_ids (comp_infos(1:n_act_comp)%global_comp_id) = Appl%rank
!
!  Get global id's on all PSMILe processes
!
#ifdef PRISM_with_MPI2
      call MPI_Allreduce (MPI_IN_PLACE, global_ids, comp_max-comp_min+1, &
                          MPI_INTEGER, MPI_MIN, Appl%comm, ierror)
#else
      Allocate (global_ids_in(comp_min:comp_max), STAT = ierror)
      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = comp_max - comp_min + 1
         call psmile_error ( PRISM_Error_Alloc, 'global_ids_in', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif

      global_ids_in = global_ids

      call MPI_Allreduce (global_ids_in, global_ids, comp_max-comp_min+1, &
                          MPI_INTEGER, MPI_MIN, Appl%comm, ierror)
  
      Deallocate (global_ids_in)
#endif
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Allreduce(MPI_MAX)', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif
!
!  Create a_comps vector
!
!  n_active = Total number of active components
!  n_miss   = Maximal number of unknown active components within an
!             application process.
!
      n_active = 0
         do i = comp_min, comp_max
         if (global_ids(i) /= Appl%size) n_active = n_active + 1
         end do

#ifdef PRISM_ASSERTION
      if (n_active < n_act_comp .or. n_active > comp_max-comp_min+1) then
         print *, 'n_active', n_active, n_act_comp, comp_max-comp_min+1

         call psmile_assert ( __FILE__, __LINE__, &
             'Inconsistent number of active application components!')
      endif

      if (n_active > noComponents) then
         print *, 'n_active', n_active, noComponents
         call psmile_assert ( __FILE__, __LINE__, &
             'n_active > noComponents !')
      endif
#endif

      call MPI_Allreduce (n_active-n_act_comp, n_miss, 1, &
                          MPI_INTEGER, MPI_MAX, Appl%comm, ierror)
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Allreduce(MPI_MAX)', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif
!
!===> If a component is not known in all processes of an application,
!     collect the data of all processes in the application on process 0.
!     The data of the application is stored in "b_comps".
!     "b_comps" is sorted relative to the global component id.
!     (Brauch man die Sortierung wirklich ?)
!
      if (n_miss > 0) then
         Allocate (b_comps(n_active), STAT = ierror)
         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = n_active
            call psmile_error ( PRISM_Error_Alloc, 'b_comps', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif
!
         call psmile_enddef_appl_miss (global_ids, comp_min, comp_max, &
                                       b_comps, n_active, tag, ierror)
         if (ierror > 0) return
!
      else
         b_comps => comp_infos
      endif
!
      Deallocate (global_ids)
      endif
!
!-----------------------------------------------------------------------
! Create communicator for roots of applications
! Sollte man den permanent machen ?
!-----------------------------------------------------------------------
!
      if (Appl%rank == PRISM_root) then
         color = 1
      else
         color = MPI_UNDEFINED
      endif
!
      key = Appl%sequence_number - 1
!
      call MPI_Comm_Split (comm_psmile, color, key, &
                           comm_appl_roots, 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 

      if (Appl%rank == PRISM_root) then
         call MPI_Comm_rank (comm_appl_roots, 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 
!
         i_am_master = (rank == PRISM_root)
         if (i_am_master) master_rank = psmile_rank

#ifdef PRISM_ASSERTION
!
!     Internal Control
!
         call MPI_Comm_size (comm_appl_roots, size, ierror)
         if ( ierror /= MPI_SUCCESS ) then
            ierrp (1) = ierror
            ierror = PRISM_Error_MPI

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

         if (size /= noApplication) then
            write (*, 9970) size, noApplication
            call psmile_assert ( __FILE__, __LINE__, &
                                 'size /= noApplication')
         endif

         if (rank /= Appl%sequence_number-1) then
            write (*, 9960) rank, Appl%sequence_number
            call psmile_assert ( __FILE__, __LINE__, &
                                 'rank /= Appl%sequence_number-1')
         endif
#endif /* PRISM_ASSERTION */

      endif
!
!  Broadcast master_rank to all processes
!
      i = master_rank

      call MPI_Allreduce (i, master_rank, 1, MPI_INTEGER, &
                          MPI_SUM, comm_psmile, ierror)
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Allreduce', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif 
!
!  Determine mapping of global var id's to global grid extension id's
!  for variables which are used coupling.

      if ( .not. Appl%stand_alone ) then
         call psmile_field2grid (ierror)
         if (ierror > 0) return
      endif
!
!=======================================================================
! Collect the data within the roots of applications
! The data is collected on the root of communicator "comm_appl_roots"
!
! Collected are:
!
! Number_of_comps_per_appl : Number of active components per application.
! root_ranks               : Ranks of roots in psmile communicator
!
! Number_of_Grids_Vector   : Number of grids per process for each component.
! psmile_ranks             : Rank in communicator "comm_psmile"
!                            for each process in component.
! all_extent_infos         : All data about extensions
!=======================================================================
!
!  For stand_alone applications without the driver
!  process we can already return here 

      if ( Appl%stand_alone ) then
#ifdef VERBOSE
         print 9980, trim(ch_id), ierror
#endif
         return
      endif

      if (Appl%rank == PRISM_root) then
!
!      Collect the number of components in the master process
!
!        call MPI_Gather (n_act_comp,               1, MPI_INTEGER, &
         call MPI_Gather (n_active,                 1, MPI_INTEGER, &
                          Number_of_comps_per_appl, 1, MPI_INTEGER, &
                          PRISM_root, comm_appl_roots, ierror)
         if ( ierror /= MPI_SUCCESS ) then
            ierrp (1) = ierror
            ierror = PRISM_Error_MPI

            call psmile_error ( ierror, 'MPI_Gather', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
         endif 
!
!      Collect the psmile ranks of root processes
!
         call MPI_Gather (psmile_rank, 1, MPI_INTEGER, &
                          root_ranks,  1, MPI_INTEGER, &
                          PRISM_root, comm_appl_roots, ierror)
         if ( ierror /= MPI_SUCCESS ) then
            ierrp (1) = ierror
            ierror = PRISM_Error_MPI

            call psmile_error ( ierror, 'MPI_Gather', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
         endif 
!
!-----------------------------------------------------------------------
!      Collect the number of processes per component in the master process
!-----------------------------------------------------------------------
!
         if (i_am_master) then
! Number_of_coll_comps == 0: ende ?
            Number_of_coll_comps = SUM (Number_of_comps_per_appl(:))
!
            if (Number_of_coll_comps < 2 ) &
               Appl%stand_alone = .true.

#ifdef PRISM_ASSERTION_not_needed_anymore
            if (Number_of_coll_comps < 2) then
               call psmile_assert ( __FILE__, __LINE__, &
                 'Total number of active components < 2')
            endif
#endif /* PRISM_ASSERTION */
!
            Allocate (all_comp_infos(1:Number_of_coll_comps), STAT = ierror)
            if ( ierror > 0 ) then
               ierrp (1) = ierror
               ierrp (2) = Number_of_coll_comps

               ierror = PRISM_Error_Alloc
               call psmile_error ( ierror, 'all_comp_infos', &
                                   ierrp, 2, __FILE__, __LINE__ )
               return
            endif
!
!    Get displacement for Collection of components
!
            disp (1) = 0
!cdir vector
               do iappl = 2, noApplication
               disp (iappl) = disp (iappl-1) + Number_of_comps_per_appl (iappl-1)
               enddo

             call MPI_Gatherv (b_comps,  n_active, datatype_enddef_comp, &
                       all_comp_infos, Number_of_comps_per_appl,         &
                                       disp, datatype_enddef_comp,       &
                           PRISM_root, comm_appl_roots, ierror)

         else
!
!    ... Note: all_comp_info is not allocated at this time since
!              all_comp_info is significant only on the root process.
!              The SUN run time system doesn't like to transfer
!              the all_comp_infos to MPI_Gatherv.
!
             call MPI_Gatherv (b_comps,  n_active, datatype_enddef_comp, &
                         dummy_comp_info, Number_of_comps_per_appl,      &
                                       disp, datatype_enddef_comp,       &
                           PRISM_root, comm_appl_roots, ierror)
         endif

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

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

      call MPI_Bcast ( Appl%stand_alone,1, MPI_Logical, PRISM_Root, Appl%comm, ierror )

      if ( Appl%stand_alone ) then
         print 9950, trim(ch_id)
#ifdef VERBOSE
         print 9980, trim(ch_id), ierror
         call psmile_flushstd
#endif
         return
      endif
!
!=======================================================================
! The way back:
!
! Distribute the data collected to all processes in communicator
! "comm_psmile".
!
! (*) Broadcast Number of components "Number_of_coll_comps"
! (*) Broadcast non-pointers of "all_comp_infos"
!
! (*) Broadcast vectors
!     Number_of_Grids_Vector, psmile_ranks, all_extent_infos
!     for all components from corresponding roots of applications.
!
! In prism_enddef_comp koennte man nur in den roots sammeln !
!
!=======================================================================
!
      call MPI_Bcast (Number_of_coll_comps, 1, MPI_INTEGER, &
                      master_rank, comm_psmile, ierror)
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Bcast', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif 
!
! WARNING: Not ideal. Should be removed.
!
      call MPI_Bcast (Number_of_comps_per_appl, NoApplication, MPI_INTEGER, &
                      master_rank, comm_psmile, ierror)
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Bcast', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif 
!
      call MPI_Bcast (root_ranks, NoApplication, MPI_INTEGER, &
                      master_rank, comm_psmile, ierror)
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Bcast', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif 
!
      if (.not. i_am_master) then
         Allocate (all_comp_infos(1:Number_of_coll_comps), STAT = ierror)
         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = Number_of_coll_comps

            ierror = PRISM_Error_Alloc
            call psmile_error ( ierror, 'all_comp_infos', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif
      endif
!
      call MPI_Bcast (all_comp_infos, Number_of_coll_comps, datatype_enddef_comp, &
                      master_rank, comm_psmile, ierror)
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Bcast', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif 
!
!  Share pointer for the components of the own application
!
#ifdef PRISM_ASSERTION
      if (n_active /= Number_of_comps_per_appl(Appl%sequence_number)) then
         print *, 'n_active, Number_of_comps_per_appl ', &
                   n_active, Number_of_comps_per_appl(Appl%sequence_number)

         call psmile_assert ( __FILE__, __LINE__, &
             'Inconsistent number of active application components in Number_of_comps_per_appl!')
      endif
#endif

      my_icomp0_coll_comps = &
         SUM (Number_of_comps_per_appl(1:Appl%sequence_number-1))

         do i = 1, n_active

         all_comp_infos(my_icomp0_coll_comps+i)%Number_of_Grids_Vector => &
                                     b_comps(i)%Number_of_Grids_Vector

         all_comp_infos(my_icomp0_coll_comps+i)%psmile_ranks => &
                                     b_comps(i)%psmile_ranks

         all_comp_infos(my_icomp0_coll_comps+i)%all_extent_infos => &
                                     b_comps(i)%all_extent_infos

         end do
!
      if (n_miss > 0) then
         Deallocate (b_comps)
      endif
!
!     Allocate vectors of global component information which are not 
!     contained on the current process and
!     broadcast the data from the root of the application to all processes.
!
      icomp = 0
         do iappl = 1, NoApplication
            do i = 1, Number_of_comps_per_appl(iappl)

            icomp = icomp + 1
            size = all_comp_infos(icomp)%size
!
            if (iappl /= Appl%sequence_number) then
               Allocate (all_comp_infos(icomp)%Number_of_Grids_Vector(1:size), &
                         STAT = ierror)
               if ( ierror > 0 ) then
                  ierrp (1) = ierror
                  ierrp (2) = size

                  ierror = PRISM_Error_Alloc
                  call psmile_error ( ierror, 'all_comp_infos()%Number_of_Grids_Vector', &
                                      ierrp, 2, __FILE__, __LINE__ )
                  return
               endif
               ! initialisation
               all_comp_infos(icomp)%Number_of_Grids_Vector(1:size) = 0
!
               Allocate (all_comp_infos(icomp)%psmile_ranks(1:size), &
                         STAT = ierror)
               if ( ierror > 0 ) then
                  ierrp (1) = ierror
                  ierrp (2) = size

                  ierror = PRISM_Error_Alloc
                  call psmile_error ( ierror, 'all_comp_infos()%psmile_ranks', &
                                      ierrp, 2, __FILE__, __LINE__ )
                  return
               endif
               ! Initailisation
               all_comp_infos(icomp)%psmile_ranks(1:size) = 0

#ifdef PRISM_ASSERTION
            else if (icomp /= my_icomp0_coll_comps+i) then
               print *, 'icomp, my_icomp0_coll_comps, i', &
                         icomp, my_icomp0_coll_comps, i

               call psmile_assert ( __FILE__, __LINE__, &
                                    'inconsistent indices')
#endif
            endif
!
!     Broadcast the data which depends on the size of comp communicator
!
            call MPI_Bcast (all_comp_infos(icomp)%Number_of_Grids_Vector, &
                            size, MPI_INTEGER, &
                            root_ranks(iappl), comm_psmile, ierror)
            if ( ierror /= MPI_SUCCESS ) then
               ierrp (1) = ierror
               ierror = PRISM_Error_MPI

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

            call MPI_Bcast (all_comp_infos(icomp)%psmile_ranks, size, &
                            MPI_INTEGER, &
                            root_ranks(iappl), comm_psmile, ierror)
            if ( ierror /= MPI_SUCCESS ) then
               ierrp (1) = ierror
               ierror = PRISM_Error_MPI

               call psmile_error ( ierror, 'MPI_Bcast', &
                                   ierrp, 1, __FILE__, __LINE__ )
               return
            endif 
!
!     Allocate the data which depends on the number of grids
!
            n = SUM (all_comp_infos(icomp)%Number_of_Grids_Vector(:))

            if (iappl /= Appl%sequence_number) then
!
               Allocate (all_comp_infos(icomp)%all_extent_infos(n), STAT = ierror)
               if ( ierror > 0 ) then
                  ierrp (1) = ierror
                  ierrp (2) = n * nd_extent_infos

                  ierror = PRISM_Error_Alloc
                  call psmile_error ( ierror, 'all_comp_infos()%all_extent_infos', &
                                      ierrp, 2, __FILE__, __LINE__ )
                  return
               endif
               ! Initialisation
               do j = 1, n
                  all_comp_infos(icomp)%all_extent_infos(i)%extent(:,:) = 0
               enddo
               all_comp_infos(icomp)%all_extent_infos(:)%local_grid_id  = 0
               all_comp_infos(icomp)%all_extent_infos(:)%global_grid_id = 0
               all_comp_infos(icomp)%all_extent_infos(:)%grid_type      = 0
               all_comp_infos(icomp)%all_extent_infos(:)%tr_code        = 0

            endif
!
!     Broadcast the data which depends on the number of grids
!
            Allocate (extents_buf(2, ndim_3d, n),                &
                      extent_info_buf(nd_extent_infos, n),       &
                      STAT = ierror)
            if ( ierror > 0 ) then
               ierrp (1) = ierror
               ierrp (2) = n * (2 * ndim_3d) + n * nd_extent_infos

               ierror = PRISM_Error_Alloc
               call psmile_error ( ierror, 'extents_buf, extent_info_buf', &
                                   ierrp, 2, __FILE__, __LINE__ )
               return
            endif

            if (root_ranks(iappl) == psmile_rank) then
               do j = 1, n
                  extents_buf(:,:,j)   = all_comp_infos(icomp)%all_extent_infos(j)%extent(:,:)
                  extent_info_buf(1,j) = all_comp_infos(icomp)%all_extent_infos(j)%local_grid_id
                  extent_info_buf(2,j) = all_comp_infos(icomp)%all_extent_infos(j)%global_grid_id
                  extent_info_buf(3,j) = all_comp_infos(icomp)%all_extent_infos(j)%grid_type
                  extent_info_buf(4,j) = all_comp_infos(icomp)%all_extent_infos(j)%tr_code
               enddo
            endif

            call MPI_Bcast (extent_info_buf, n*nd_extent_infos, MPI_INTEGER, &
                            root_ranks(iappl), comm_psmile, ierror)
            if ( ierror /= MPI_SUCCESS ) then
               ierrp (1) = ierror
               ierror = PRISM_Error_MPI

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

            call MPI_Bcast (extents_buf, n*2*ndim_3d, PSMILe_float_datatype, &
                            root_ranks(iappl), comm_psmile, ierror)
            if ( ierror /= MPI_SUCCESS ) then
               ierrp (1) = ierror
               ierror = PRISM_Error_MPI

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

            if (root_ranks(iappl) /= psmile_rank) then
               do j = 1, n
                  all_comp_infos(icomp)%all_extent_infos(j)%extent(:,:)    = extents_buf(:,:,j)
                  all_comp_infos(icomp)%all_extent_infos(j)%local_grid_id  = extent_info_buf(1,j)
                  all_comp_infos(icomp)%all_extent_infos(j)%global_grid_id = extent_info_buf(2,j)
                  all_comp_infos(icomp)%all_extent_infos(j)%grid_type      = extent_info_buf(3,j)
                  all_comp_infos(icomp)%all_extent_infos(j)%tr_code        = extent_info_buf(4,j)
               enddo
            endif

            Deallocate (extents_buf, extent_info_buf)
!
            end do ! Component
         end do ! Application
!
!=======================================================================
!     Free
!=======================================================================
!
!     Free communicator created (wirklich ? )
!
      if (comm_appl_roots /= MPI_COMM_NULL) then
         call MPI_Comm_free (comm_appl_roots, ierror)
         if ( ierror /= MPI_SUCCESS ) then
            ierrp (1) = ierror
            ierror = PRISM_Error_MPI

            call psmile_error ( ierror, 'MPI_Comm_free', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
         endif 
      endif
!
!===> All done
!
#ifdef VERBOSE
      call psmile_print_comp_info ( all_comp_infos, Number_of_coll_comps, &
                                    'End of PSMILe_enddef_appl' )

      print 9980, trim(ch_id), ierror
      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats
!
9990 format (1x, a, ': psmile_enddef_appl')
9980 format (1x, a, ': psmile_enddef_appl: eof ierror =', i3)
9950 format (1x, a, ': psmile_enddef_appl: WARNING: Reset Appl%stand_alone to .true.!')
!
#ifdef PRISM_ASSERTION

9970 format (/1x, 'psmile_enddef_appl: inconsistent number of applications:', &
                  ' size = ', i7, '; noApplication =', i7)
9960 format (/1x, 'psmile_enddef_appl: wrong rank: rank = ', i7, &
                  '; Appl%sequence_number =', i7)
#endif /* PRISM_ASSERTION */
!
      end subroutine PSMILe_enddef_appl