prismdrv_init_appl.F90

Go to the documentation of this file.

!------------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PRISMDrv_Init_appl
!
! !INTERFACE
subroutine prismdrv_init_appl(id_err)

!
! !USES:
!
  USE PRISMDrv, dummy_interface => PRISMDrv_Init_appl
  use psmile_timer, only : psmile_timer_init, psmile_timer_start

  IMPLICIT NONE

!
! !PARAMETERS:
!

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

! !DESCRIPTION
! Subroutine "PRISMDrv_Init_appl" sets the computational context of the 
! different applications in MPI1 such as the communicators, and spawn 
! these applications in MPI2 and set the context.
!
! !REVISED HISTORY
!   Date      Programmer   Description
! ----------  ----------   -----------
! 04/10/2002  D. Declat    Creation
!
! EOP
!----------------------------------------------------------------------
! $Id: prismdrv_init_appl.F90 2846 2011-01-04 12:02:30Z hanke $
! $Author: hanke $
!----------------------------------------------------------------------
!
! 0. Local declarations
!
  CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
     '$Id: prismdrv_init_appl.F90 2846 2011-01-04 12:02:30Z hanke $'

  INTEGER :: il_size, il_status(MPI_STATUS_SIZE)
  INTEGER :: il_inter   ! inter comm obtained by mpi_comm_spawn 

!    When an application is spawned, some info are sent via a buffer 
!    dimensionned by il_dim_buf. These info are the protocol version
!    the number of applications and the last current application spawned
  INTEGER :: il_dim_buf
  INTEGER, DIMENSION(:), ALLOCATABLE :: ila_buf
  INTEGER :: il_protocol_version

  INTEGER :: ib, ib_bis, ib_ter, ib_quad
  INTEGER :: il_comp_index  

  INTEGER :: n_host ! pointer to hostlist for current application
  INTEGER :: n_args ! pointer to arguemt list for current application

  LOGICAL :: ll_flag

  INTEGER, PARAMETER                  :: nerrp=3
  INTEGER                             :: ierrp(nerrp)
!
  INTEGER, DIMENSION(15) :: ila_date
  DOUBLE PRECISION, DIMENSION(3) :: dla_date

#ifdef PROFILE
  CHARACTER (LEN=max_name) :: timer_label(1)
#endif
!
!----------------------------------------------------------------------
!
#ifdef VERBOSE
  PRINT *, '| Enter PRISMDrv_Init_appl'
  call psmile_flushstd
#endif
!
! 1. Process management if MPI1 or MPI2 and not spawn
!
  IF (ig_MPI .eq. DRV_MPI1) THEN

#ifdef VERBOSE
      PRINT *, '| | MPI1 implementation'
      call psmile_flushstd
#endif
! 1.1. Duplicate MPI_COMM_WORLD to create the global communicator

      CALL MPI_Comm_dup (MPI_COMM_WORLD, comm_drv_global, 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_dup', &
             ierrp, 1, __FILE__, __LINE__ )
          RETURN
      ENDIF

!
! 1.1. Duplicate the global communicator to Get the transformer comm
!
      CALL MPI_Comm_dup (comm_drv_global, comm_drv_trans, 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_dup', &
             ierrp, 1, __FILE__, __LINE__ )
          RETURN
      ENDIF

!
! 1.2. Manage the exchange of information between the driver the 
!      transformer and the appl.
!
! 1.2.1. Get protocol version for communication between the coupler
!          and the models (applications)
      CALL MPI_Allreduce (DRV_latest_protocol_version, &
         il_protocol_version, 1, MPI_Integer, MPI_MIN, &
         comm_drv_global, id_err)

      IF ( id_err /= MPI_SUCCESS ) THEN
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI

          call psmile_error_common ( id_err, 'MPI_Allreduce', &
             ierrp, 1, __FILE__, __LINE__ )
          RETURN
      ENDIF

      IF (  il_protocol_version < DRV_latest_protocol_version) THEN

         PRINT *, '| | Protocol versions differ.'
         PRINT *, '| | PSMILE protocol version is ', il_protocol_version
         PRINT *, '| | DRIVER protocol version is ', DRV_latest_protocol_version
         call psmile_abort

      ENDIF
!
! 1.2.2. Number of applications and components is distributed to all
!        processes. The data is sent by the root of the coupler processes.
!       ibuf (4) = Total number of rank sets for the different components
      il_dim_buf = 3
      ALLOCATE(ila_buf(il_dim_buf), stat=id_err)
      IF (id_err > 0) THEN
          ierrp (1) = id_err
          ierrp (2) = il_dim_buf
          id_err = PRISM_Error_Alloc

          call psmile_error_common ( id_err, 'ila_buf', &
             ierrp, 2, __FILE__, __LINE__ )
          RETURN
      ENDIF

      ila_buf (1) = ig_nb_appl
      ila_buf (2) = ig_nb_tot_comps

      IF ( ig_nb_appl .eq. 0 ) THEN
          ila_buf (3) = 1 ! Indicating stand alone
      ELSE
          ila_buf (3) = 0 ! Indicating coupler mode
      ENDIF
      ila_buf (3) = 0

      CALL MPI_Bcast( ila_buf, il_dim_buf, MPI_Integer, &
         PRISMdrv_root, comm_drv_global, id_err )

      IF ( id_err /= MPI_SUCCESS ) THEN
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI

      call psmile_error_common ( id_err, 'MPI_Bcast', &
          ierrp, 1, __FILE__, __LINE__ )
          RETURN
      ENDIF

      ig_nb_appl      = ila_buf (1)
      ig_nb_tot_comps = ila_buf (2)

      DEALLOCATE(ila_buf, stat=id_err)
      IF (id_err > 0) THEN
          ierrp (1) = id_err
          ierrp (2) = il_dim_buf
          id_err = PRISM_Error_Alloc

          call psmile_error_common ( id_err, 'ila_buf', &
             ierrp, 2, __FILE__, __LINE__ )
          RETURN
      ENDIF

! 1.2.3. Number of processes per application is distributed to all process
      CALL MPI_Bcast(iga_appli_nb_pes(0), ig_nb_appl+1, MPI_Integer, &
         PRISMdrv_root, comm_drv_global, id_err )

      IF ( id_err /= MPI_SUCCESS ) THEN
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI

          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          RETURN
      ENDIF

! 1.2.5. Broadcast names of applications
      CALL MPI_Bcast(cga_appli_name(0), (ig_nb_appl+1)*max_name, &
         MPI_Character, PRISMdrv_root, comm_drv_global, id_err )

      IF ( id_err /= MPI_SUCCESS ) THEN
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI

          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          RETURN
      ENDIF

! 1.2.6. Broadcast names of components
      CALL MPI_Bcast(cga_appli_compname(1), (ig_nb_tot_comps)*max_name, &
         MPI_Character, PRISMdrv_root, comm_drv_global, id_err )

      IF ( id_err /= MPI_SUCCESS ) THEN
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI

          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          RETURN
      ENDIF

! 1.2.7. Broadcast the number of components of all applications
      CALL MPI_Bcast( iga_appli_nb_comps(1), ig_nb_appl, &
         MPI_Integer, PRISMdrv_root, comm_drv_global, id_err )

      if ( id_err /= MPI_SUCCESS ) then
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI
          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          return
      endif

! 1.2.9. Broadcast the rank sets for all the components
      CALL MPI_Bcast( iga_appli_compnbranksets(1), ig_nb_tot_comps, &
         MPI_Integer, PRISMdrv_root, comm_drv_global, id_err )

      if ( id_err /= MPI_SUCCESS ) then
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI
          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          return
      endif

      CALL MPI_Bcast( iga_appli_compranks, ig_nbtot_ranksets*3, &
         MPI_Integer, PRISMdrv_root, comm_drv_global, id_err )

      if ( id_err /= MPI_SUCCESS ) then
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI
          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          return
      endif

! 1.2.10. Broadcast redirect stdout info for all applications
      CALL MPI_Bcast( iga_appli_redirect(1), ig_nb_appl, &
         MPI_Integer, PRISMdrv_root, comm_drv_global, id_err )

      if ( id_err /= MPI_SUCCESS ) then
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI
          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          return
      endif

! 1.3. Define the local communicators

      call prismdrv_def_mpi_comm(id_err)

! 1.4  Determine the application rank (has already been defined in prismdrv_init, but there is was the global rank)

      call MPI_COMM_RANK ( comm_drv_local, Appl%rank, id_err )

      if ( id_err /= MPI_SUCCESS ) THEN
          ierrp (1) = id_err
          call psmile_error_common ( PRISM_Error_MPI, 'MPI_Comm_rank', &
             ierrp, 1, __FILE__, __LINE__ )
          return
      endif

#ifdef VERBOSE
      PRINT *, '| | End MPI1 implementation'
      call psmile_flushstd
#endif
!
! 2. Process management if MPI2 and spawn
!

  ELSE IF (ig_MPI .eq. DRV_MPI2) THEN

#ifdef VERBOSE
      PRINT *, '| | MPI2 implementation'
      call psmile_flushstd
#endif
! 2.1. If MPI2, Duplicate MPI_COMM_WORLD to get comm_drv

      CALL MPI_Comm_dup (MPI_COMM_WORLD, 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_dup', &
             ierrp, 1, __FILE__, __LINE__ )
          RETURN
      ENDIF

      CALL MPI_Comm_dup (MPI_COMM_WORLD, comm_drv_global, 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_dup', &
             ierrp, 1, __FILE__, __LINE__ )
          RETURN
      ENDIF

! 2.2. Spawn applications on hosts with prismdrv_spawn_child

! 2.2.0 Set the part of the sent buffer that won't change

      il_dim_buf = 4
      ALLOCATE(ila_buf(il_dim_buf), stat=id_err)
      IF (id_err > 0) THEN
          ierrp (1) = id_err
          ierrp (2) = il_dim_buf
          id_err = PRISM_Error_Alloc

          call psmile_error_common ( id_err, 'ila_buf', &
             ierrp, 2, __FILE__, __LINE__ )
          RETURN
      ENDIF

      ila_buf(1) = DRV_latest_protocol_version
      ila_buf(2) = ig_nb_appl
      ila_buf(4) = ig_nb_tot_comps

      n_host = 1 ! pointer to the position of the current application
      n_args = 1 ! pointer to the position of the current application

      DO ib = 1, ig_nb_appl

! 2.2.1. Spawn application ib on iga_nb_hosts_appl(ib) hosts

        IF ( Appl%rank == PRISM_Root ) THEN
           PRINT *, '| | | MPI2 Spawning processes:  '
           PRINT *, '| | | MPI2 Spawning exe_name    ', trim(cga_appli_exe_name(ib))
           PRINT *, '| | | MPI2 Spawning appli_args  ', trim(cga_appli_args(n_args))
           PRINT *, '| | | MPI2 Spawning nb_args     ', iga_appli_nb_args(ib)
           PRINT *, '| | | MPI2 Spawning nb_hosts    ', iga_appli_nb_hosts(ib)
           DO ib_bis = n_host,n_host+iga_appli_nb_hosts(ib)-1
               PRINT *, '| | | MPI2 Spawning nb_pes      ', iga_appli_hostnbprocs(ib_bis)
               PRINT *, '| | | MPI2 Spawning on hostname ', trim(cga_appli_hostname(ib_bis))
           ENDDO
        ENDIF

        call prismdrv_spawn_child (cga_appli_exe_name(ib),       &
           cga_appli_args(n_args), iga_appli_nb_args(ib), ib,  &
           iga_appli_nb_hosts(ib), cga_appli_hostname(n_host), &
           iga_appli_hostnbprocs(n_host), comm_drv_global,     &
           il_inter, id_err)

        n_host = n_host + iga_appli_nb_hosts(ib)
        n_args = n_args + iga_appli_nb_args(ib)

! 2.2.2. Exchange protocol version with psmile lib
!          The protocol version is sent by the root process of the appl.

        IF ( Appl%rank == PRISM_Root ) THEN
           CALL MPI_Recv (il_protocol_version, 1, MPI_Integer, &
                PRISM_root, PSMILe_Init_tag, il_inter, &
                il_status, id_err)

           IF ( id_err /= MPI_SUCCESS ) THEN
              ierrp (1) = id_err
              ierrp (2) = PRISM_root
              ierrp (3) = PSMILe_Init_tag

              id_err = PRISM_Error_Recv

              call psmile_error_common ( id_err, 'MPI_Recv', &
                   ierrp, 3, __FILE__, __LINE__ )
              RETURN
           ENDIF

! 2.2.3. Send initial data to root of spawned processes
!
!     ibuf (1) = Protocol version of the coupler
!     ibuf (2) = Number of application
!     ibuf (3) = Sequence number of current application
!     ibuf (4) = Total number of rank sets for the different components

           ila_buf(3) = ib

           CALL MPI_Send(ila_buf, il_dim_buf, MPI_Integer, &
                PRISM_root, PSMILe_Init_tag, il_inter, &
                id_err)

           IF ( id_err /= MPI_SUCCESS ) THEN
              ierrp (1) = id_err
              ierrp (2) = PRISM_root
              ierrp (3) = PSMILe_Init_tag
              id_err = PRISM_Error_Send

              call psmile_error_common ( PRISM_Error_Send, 'MPI_Send', &
                   ierrp, 3, __FILE__, __LINE__ )
              RETURN
           ENDIF
        ENDIF

      DEALLOCATE(ila_buf, stat=id_err)
      IF (id_err > 0) THEN
          ierrp (1) = id_err
          ierrp (2) = il_dim_buf
          id_err = PRISM_Error_Alloc

          call psmile_error_common ( id_err, 'ila_buf', &
             ierrp, 2, __FILE__, __LINE__ )
          RETURN
      ENDIF

! 2.2.4. Merge the communicators to get comm_drv_global

        !flag is set to false => driver gets the lower ranks => PRISM_root == PRISMdrv_root == 0
        ll_flag = .false.

        CALL MPI_Intercomm_merge (il_inter, ll_flag, comm_drv_global, &
           id_err)

        IF ( id_err /= 0 ) THEN
            ierrp (1) = id_err
            id_err = PRISM_Error_MPI

            call psmile_error_common ( id_err, 'MPI_Intercomm_merge', &
               ierrp, 1, __FILE__, __LINE__ )
            RETURN
        ENDIF

! 2.2.4bis. The resulting communicator is the global communicator

        CALL MPI_Comm_rank ( comm_drv_global, global_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

! 2.2.5. Free the communicators

        IF (ib /= 1) THEN

            CALL MPI_Comm_free (il_inter, id_err)

            IF ( id_err /= 0 ) THEN
                ierrp (1) = id_err
                id_err = PRISM_Error_MPI

                call psmile_error_common ( id_err, 'MPI_Comm_free', &
                   ierrp, 1, __FILE__, __LINE__ )
                RETURN
            ENDIF

        ELSE

            comm_coupling (ib) = comm_drv_global

        ENDIF

      END DO

! 2.4. Duplicate the global communicator to Get the transformer comm

      CALL MPI_Comm_dup (comm_drv_global, comm_drv_trans, 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_dup', &
             ierrp, 1, __FILE__, __LINE__ )
          RETURN
      ENDIF


! 2.5. Broadcast the protocol version

      CALL MPI_Bcast ( il_protocol_version, 1, MPI_Integer, &
         PRISMdrv_root, comm_drv_global, id_err )

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


! 2.5. Broadcast the number of pes per application

      call MPI_Bcast( iga_appli_nb_pes(0), ig_nb_appl+1, MPI_Integer, &
         PRISMdrv_root, comm_drv_global, id_err )

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


! 2.9. Broadcast names of all applications and components
!
! 2.9.1 Broadcast names of all applications
      CALL MPI_Bcast( cga_appli_name(0), (ig_nb_appl+1)*max_name, &
         MPI_Character, PRISMdrv_root, comm_drv_global, id_err )

      if ( id_err /= MPI_SUCCESS ) then
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI
          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          return
      endif

! 2.9.2. Broadcast names of components
      CALL MPI_Bcast(cga_appli_compname(1), (ig_nb_tot_comps)*max_name, &
         MPI_Character, PRISMdrv_root, comm_drv_global, id_err )

      IF ( id_err /= MPI_SUCCESS ) THEN
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI

          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          RETURN
      ENDIF

! 2.9.4. Broadcast the number of components per application

      call MPI_Bcast( iga_appli_nb_comps(1), ig_nb_appl, &
         MPI_Integer, PRISMdrv_root, comm_drv_global, id_err )

      if ( id_err /= MPI_SUCCESS ) then
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI
          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          return
      endif

! 2.9.5. Broadcast the rank sets for all the components
      CALL MPI_Bcast( iga_appli_compnbranksets(1), ig_nb_tot_comps, &
         MPI_Integer, PRISMdrv_root, comm_drv_global, id_err )

      if ( id_err /= MPI_SUCCESS ) then
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI
          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          return
      endif

      CALL MPI_Bcast( iga_appli_compranks, ig_nbtot_ranksets*3, &
         MPI_Integer, PRISMdrv_root, comm_drv_global, id_err )

      if ( id_err /= MPI_SUCCESS ) then
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI
          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          return
      endif

! 2.9.6. Broadcast redirect stdout info for all applications
      CALL MPI_Bcast( iga_appli_redirect(1), ig_nb_appl, &
         MPI_Integer, PRISMdrv_root, comm_drv_global, id_err )

      if ( id_err /= MPI_SUCCESS ) then
          ierrp (1) = id_err
          id_err = PRISM_Error_MPI
          call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
             __FILE__, __LINE__ )
          return
      endif

! 2.10. Split global communicator in order to get a communicator
!       between the driver and the application

      do ib = 2, ig_nb_appl

        call MPI_Comm_split (comm_drv_global, ib, PRISM_Root, &
           comm_coupling(ib), 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

      enddo

! 2.11. Construct a communicator comm_psmile containing all MPI processes
!       which are connected to the PSMILe library

      call MPI_Comm_Split ( comm_drv_global, MPI_UNDEFINED, 0,  &
         comm_drv_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 *, '| | End MPI2 implementation'
      call psmile_flushstd
#endif
  END IF
!
! 2.12  Initialize driver's internal timers
!
#ifdef PROFILE
  timer_label = 'main'
  call psmile_timer_init (1, timer_label, 'Driver', 'driver_timer_stats', comm_drv_local)
  call psmile_timer_start(1)
#endif
!

! 3. Broadcast sga_run_start_date and sga_experiment_start_date
!    2 vectors of integers and doubles are set with the date
!    and then broadcasted.
!    set the vectors for ig_run_start_date

  ila_date(1)  = sga_run_start_date%year
  ila_date(2)  = sga_run_start_date%month
  ila_date(3)  = sga_run_start_date%day
  ila_date(4)  = sga_run_start_date%hour
  ila_date(5)  = sga_run_start_date%minute
  dla_date(1)  = sga_run_start_date%second

!    set the vectors for ig_run_end_date

  ila_date(6)  = sga_run_end_date%year
  ila_date(7)  = sga_run_end_date%month
  ila_date(8)  = sga_run_end_date%day
  ila_date(9)  = sga_run_end_date%hour
  ila_date(10) = sga_run_end_date%minute
  dla_date(2)  = sga_run_end_date%second

!    set the vectors for ig_experiment_start_date

  ila_date(11) = sga_experiment_start_date%year
  ila_date(12) = sga_experiment_start_date%month
  ila_date(13) = sga_experiment_start_date%day
  ila_date(14) = sga_experiment_start_date%hour
  ila_date(15) = sga_experiment_start_date%minute
  dla_date(3)  = sga_experiment_start_date%second

!    broacast the two vectors

  CALL MPI_Bcast( ila_date(1), 15, &
       MPI_Integer, PRISMdrv_root, comm_drv_global, id_err )

  if ( id_err /= MPI_SUCCESS ) then
     ierrp (1) = id_err
     id_err = PRISM_Error_MPI
     call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
          __FILE__, __LINE__ )
     return
  endif

  CALL MPI_Bcast( dla_date(1), 3, &
       MPI_Double_Precision, PRISMdrv_root, comm_drv_global, id_err )

  if ( id_err /= MPI_SUCCESS ) then
     ierrp (1) = id_err
     id_err = PRISM_Error_MPI
     call psmile_error_common ( id_err, 'MPI_Bcast', ierrp, 1, &
          __FILE__, __LINE__ )
     return
  endif

!
! 4. Give the comp_id to all the components processes
!
! 4.1. Get the global size and thus the dimensioning number of the process
!      management stucture
!
  CALL MPI_Comm_size (comm_drv_global, il_size, 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_size', ierrp, 1, &
         __FILE__, __LINE__ )
      RETURN
  ENDIF

  IF ( il_size <= ig_driver_nb_pes ) THEN
     PRINT *, '| | Number of driver processes started was      ', ig_driver_nb_pes
     PRINT *, '| | Number of application processes started was ', ig_driver_nb_pes-il_size
     PRINT *, '| | Number of total processes started was       ', il_size
     ierrp (1) = ig_driver_nb_pes-il_size
     ierrp (2) = PRISM_UNDEFINED
     call psmile_error_common ( PRISM_Error_InitApp, 'Inconsistent mpirun command and scc.xml', &
          ierrp, 2, __FILE__, __LINE__ )
  ENDIF

! 4.2. Allocate the Drv_Proc_manage structure
  ALLOCATE(Drv_Procs(il_size), stat = id_err)

  IF ( id_err > 0 ) THEN
      ierrp (1) = id_err
      ierrp (2) = il_size
      call psmile_error_common ( PRISM_Error_Alloc, 'PRISM_comm_global_size', &
         ierrp, 2, __FILE__, __LINE__ )
  ENDIF

  IF (Appl%rank == PRISM_root ) THEN
! 4.3. Receive the application name from each application process

!     for all processes in comm_drv_global
      DO ib = 0, il_size - 1
!       if rank does not belong to a driver process
        IF ((ib < PRISMdrv_root) .OR. ((PRISMdrv_root + ig_driver_nb_pes) <= ib)) THEN
! dd 25/02/04 this is a workaround patch. On the sun the exchanges of names
!             give wrong values to the driver
          CALL MPI_Recv (Drv_Procs(ib+1)%appli_name, max_name, MPI_Character, &
             ib, 1, comm_drv_global, il_status, id_err)
          CALL MPI_Recv (Drv_Procs(ib+1)%comps_per_rank, 1, MPI_Integer, &
             ib, 1, comm_drv_global, il_status, id_err)
          IF ( Drv_Procs(ib+1)%comps_per_rank > 0 ) THEN
             ALLOCATE(Drv_Procs(ib+1)%comp_name(Drv_Procs(ib+1)%comps_per_rank))
             ALLOCATE(Drv_Procs(ib+1)%global_rank(Drv_Procs(ib+1)%comps_per_rank))
             ALLOCATE(Drv_Procs(ib+1)%global_comp_id(Drv_Procs(ib+1)%comps_per_rank))
          ENDIF
#ifdef DEBUG
          PRINT *, '| | application name ', trim(Drv_Procs(ib+1)%appli_name)
          PRINT *, '| | with             ', Drv_Procs(ib+1)%comps_per_rank, 'comps on rank ', ib
          CALL psmile_flushstd
#endif
        ENDIF
      ENDDO
! 4.4. Receive the component names from each application process and send
!         back global component Id

!     for all processes in comm_drv_global
      DO ib = 0, il_size - 1
!       if rank does not belong to a driver process
        IF ((ib < PRISMdrv_root) .OR. ((PRISMdrv_root + ig_driver_nb_pes) <= ib)) THEN
          DO ib_bis = 1, Drv_Procs(ib+1)%comps_per_rank
#ifdef DEBUG
            PRINT *, '| | receive a component name from ', ib
            CALL psmile_flushstd
#endif
            CALL MPI_Recv (Drv_Procs(ib+1)%comp_name(ib_bis), max_name, MPI_Character, &
                 ib, 1, comm_drv_global, il_status, id_err)
#ifdef DEBUG
            PRINT *, '| | received component name ', trim(Drv_Procs(ib+1)%comp_name(ib_bis)), ' from ', ib
            CALL psmile_flushstd
#endif

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

            Drv_Procs(ib+1)%global_rank(ib_bis) = ib
            Drv_Procs(ib+1)%global_comp_id(ib_bis) = huge(il_comp_index)

            il_comp_index = 0
            OUTER: DO ib_ter = 1, ig_nb_appl

             DO ib_quad = 1, iga_appli_nb_comps(ib_ter)

                il_comp_index = il_comp_index + 1

#ifdef DEBUG
            PRINT *, '| | testing application name "', &
               TRIM(cga_appli_name(ib_ter)), '" == "', TRIM(Drv_Procs(ib+1)%appli_name), '" = ', &
               (TRIM(cga_appli_name(ib_ter)) .eq. TRIM(Drv_Procs(ib+1)%appli_name))
            CALL psmile_flushstd
#endif

                IF (TRIM(cga_appli_name(ib_ter)) .eq. &
                     TRIM(Drv_Procs(ib+1)%appli_name)) THEN
#ifdef DEBUG
                  PRINT *, '| | testing component name "', &
                     TRIM(cga_appli_compname(il_comp_index)), '" == "', &
                     TRIM(Drv_Procs(ib+1)%comp_name(ib_bis)), '" = ', &
                     (TRIM(cga_appli_compname(il_comp_index)) .eq. TRIM(Drv_Procs(ib+1)%comp_name(ib_bis)))
                  CALL psmile_flushstd
#endif
                   IF (TRIM(cga_appli_compname(il_comp_index)) .eq. &
                        TRIM(Drv_Procs(ib+1)%comp_name(ib_bis))) THEN
                      Drv_Procs(ib+1)%global_comp_id(ib_bis) = il_comp_index
                      EXIT OUTER
                   END IF
                END IF
               END DO !ib_quad
            END DO OUTER ! ib_ter

            IF (Drv_Procs(ib+1)%global_comp_id(ib_bis) == huge(il_comp_index)) then
               ierrp (1) = Drv_Procs(ib+1)%global_comp_id(ib_bis)
               id_err = PRISM_Error_Comp_name

               call psmile_error_common ( id_err, 'could not find matching component', &
                                          ierrp, 1, __FILE__, __LINE__ )
               RETURN
            ENDIF

            CALL MPI_Send (Drv_Procs(ib+1)%global_comp_id(ib_bis), 1, &
                MPI_INTEGER, ib, 2, comm_drv_global, id_err)
#ifdef DEBUG
            PRINT *, '| | send global comp ID ', Drv_Procs(ib+1)%global_comp_id(ib_bis), ' to ', ib
            CALL psmile_flushstd
#endif
             IF ( id_err /= MPI_SUCCESS ) THEN
                ierrp (1) = id_err
                id_err = PRISM_Error_MPI
                call psmile_error_common ( id_err, 'MPI_Send', ierrp, 1, &
                     __FILE__, __LINE__ )
                RETURN
             ENDIF

          END DO ! ib_bis
        END IF

      END DO ! ib

  ENDIF
!
#ifdef VERBOSE
  PRINT *, '| Quit PRISMDrv_Init_appl'
  PRINT *, '|'
  call psmile_flushstd
#endif
END SUBROUTINE PRISMDrv_Init_appl