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

!
! !USES:
!
      use PRISM_constants
      use PSMILe, dummy_interface => PSMILe_Init_MPI1
      use PSMILe_SCC, only : get_execution_mode, get_dates,                &
     get_appli_details, get_applicomp_details, get_applicomprk_detls,   &
         close_scc_file, open_scc_file

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

!     Returns the error code of PSMILe_Init_MPI1;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      integer            :: index, il_myint
      integer            :: global_size
      integer, parameter :: ndibuf = 3
      integer            :: ibuf (ndibuf)

      integer, parameter :: nerrp = 2
      integer            :: ierrp (nerrp)

      integer, dimension(15) :: idate
      double precision, dimension(3) :: ddate

      Type(PRISM_Time_Struct) :: tdate
      INTEGER            :: noHosts(0:1), noArgs(0:1)

      integer, parameter :: rank_dummy = huge(il_myint)

      integer, allocatable :: appl_redirect(:)
      character (len=max_name) :: cpatch(0:1)
!
! !DESCRIPTION:
!
!
! Subroutine "PSMILe_Init_MPI1" receives the initial data sent by
! the master process of the coupler and defines the communicators
! if all processes were simultaneously started by the mpirun/mpiexec
! command.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 01.12.03    R. Redler    created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_init_mpi1.F90 2687 2010-10-28 15:15:52Z coquart $
! $Author: coquart $
!
      character(len=len_cvs_string), save :: mycvs = 
      '$Id: psmile_init_mpi1.F90 2687 2010-10-28 15:15:52Z coquart $'
!
! ---------------------------------------------------------------------

#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_Init_MPI1: start'
#endif /* VERBOSE */

!     determines PRISMdrv_root process
!     components provide only a dummy argument
!     the MPI_Allreduce call matches a call in prismdrv_init.F90

      call MPI_Allreduce ( rank_dummy, PRISMdrv_root, 1, MPI_Integer, MPI_MIN, MPI_COMM_WORLD, 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

!     if there is no driver process
      if ( PRISMdrv_root == rank_dummy ) then
!        stand alone case => set component process with rank 0 as root
         PRISMdrv_root = 0
      endif

!===> Create global communicator
!     This is simply a duplicate of MPI_COMM_WORLD.

      call MPI_Comm_dup ( MPI_COMM_WORLD, comm_global, 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 ( comm_global, global_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 ( comm_global, global_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
!
!===> Duplicate comm_global to get comm_trans
!
      call MPI_Comm_dup (comm_global, comm_trans, 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

! ---------------------------------------------------------------------
!     Get protocol version for communication between the coupler
!     and the applications (set of components)
! ---------------------------------------------------------------------

      call MPI_Allreduce (PSMILe_latest_protocol_version, protocol_version, &
                          1, MPI_Integer, MPI_MIN, comm_global,  &
                          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

      if (  protocol_version < PSMILe_latest_protocol_version) then

         write (*, 9990) protocol_version, PSMILe_latest_protocol_version
         call psmile_assert ( __FILE__, __LINE__, &
           'impossible protocol versions computed')

9990 format (/1x, 'PSMILe_Init_MPI1: protocol_version =', i7, &
                 '; latest =', i7)
      endif

! ---------------------------------------------------------------------
!     Get initial data from the root of coupler processes and broadcast
!     data to the processes of the applications. Corresponding Driver
!     MPI_Bcast calls are located in PRISMDrv_Init_appl.
! ---------------------------------------------------------------------
!
!===> Number of applications is distributed to all processes
!     The data is sent by the root of the coupler processes.
!
      if (global_rank == PRISMdrv_root) then
!
!        PSMILe is running without a driver.
!
         noApplication = 1

!        Number of components is set to 1 here. For stand_alone
!        applications it will be redefined later.

         noComponents = 1

         ibuf (1) = noApplication
         ibuf (2) = noComponents
         ibuf (3) = 1 ! Indicating stand alone
      endif

      call MPI_Bcast( ibuf, ndibuf, MPI_Integer, &
                      PRISMdrv_root, comm_global, 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

      noApplication = ibuf (1)
      noComponents  = ibuf (2)
      Appl%stand_alone = ibuf (3) .eq. 1

#ifdef PRISM_ASSERTION
      if (  noApplication < 1 ) then
         call psmile_assert ( __FILE__, __LINE__, &
             'Number of Application should be > 0!')
      endif

      if ( noComponents < noApplication  ) then
         call psmile_assert ( __FILE__, __LINE__, &
             'Number of Components should be >= Number of Applications!')
      endif

      if ( ibuf(3) < 0 .or. ibuf (3) > 1 ) then
         call psmile_assert ( __FILE__, __LINE__, &
             'Stand alone flag should be 0 or 1!')
      endif
#endif

      if ( Appl%stand_alone ) then
         print *, trim(ch_id), ': PSMILe_Init_MPI1: Assuming stand alone run!'
      endif
!
!===> Allocate global vectors
!
      Allocate (PRISM_applProc (0:noApplication), STAT = ierror)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = noApplication + 1

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

      Allocate (PRISM_applName (0:noApplication), STAT = ierror)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = noApplication + 1

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

      PRISM_applName(:) = ' '
!
!===> Initialize data for stand alone application
!
      if ( Appl%stand_alone ) then

         PRISM_applProc(0) = 0
         PRISM_applProc(1) = global_size

         PRISM_applName(0) = 'Stand alone'
         PRISM_applName(1) = trim(Appl%name)

!
!===> open the scc.xml file and load its elements into memory
!
         call open_scc_file (ierror)
!
!===> get_execution_mode
!
         call get_execution_mode (ierror, ierror)

!
!===> get the dates
!
         call get_dates (PRISM_initial_date, tdate, &
        PRISM_Jobstart_date, PRISM_Jobend_date, ierror)

!
!===> Allocate and get the number of components per application
!
         Allocate (PRISM_noCompsPerAppl (0:1), STAT = ierror)

         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = 1

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

         call get_appli_details ( 1, PRISM_applName, cpatch,  &
                              noHosts, PRISM_Redirect,      &
                                  PRISM_noCompsPerAppl,      &
                                  noArgs, ierror )
!
!===> Allocate and get the components name and the number of rank sets per comp
!
         Allocate (PRISM_compName (1:PRISM_noCompsPerAppl(1)), STAT = ierror)

         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = PRISM_noCompsPerAppl(1)

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

         Allocate(PRISM_compRankSets(1:PRISM_noCompsPerAppl(1)), STAT = ierror)

         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = PRISM_noCompsPerAppl(1)

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

     call get_applicomp_details ( 1, PRISM_noCompsPerAppl(1), &
        PRISM_compName, PRISM_compRankSets, ierror)

!
!===> Allocate and get the rank sets per component
!
         noRanksets = sum(PRISM_compRankSets(:))
         Allocate (PRISM_rankSets (noRanksets,3), STAT = ierror)

         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = noRanksets

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

     call get_applicomprk_detls ( 1, noRanksets,  &
           PRISM_rankSets, ierror)

         do index = 1, noRanksets
            PRISM_rankSets(index,3) = max(1,PRISM_rankSets(index,3))
            PRISM_rankSets(index,2) = max(PRISM_rankSets(index,1),PRISM_rankSets(index,2))
         enddo

         index = 1

!===>    close the scc.xml file and free memory
         call close_scc_file ()

      else ! Appl%stand_alone



!
!===> Allocate global vector specific for coupled runs
!
      Allocate (PRISM_noCompsPerAppl (0:noApplication), STAT = ierror)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = noApplication

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

      Allocate (PRISM_compName (1:noComponents), STAT = ierror)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = noComponents

         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'PRISM_compName', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
!===> Number of processes per application is distributed to all processes
!     Note: This is only used in order to ensure that at least one process
!     was assigne to the coupler.
!
!
!===> Number of processes per application is distributed to all processes
!
         call MPI_Bcast( PRISM_applProc(0), noApplication+1, MPI_Integer, &
                         PRISMdrv_root, comm_global, 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

#ifdef PRISM_ASSERTION
         if ( PRISM_applProc(0) < 1 ) then
            call psmile_assert ( __FILE__, __LINE__, &
                'Coupler should be assigned to at least 1 processor!')
         endif

         if (  noApplication < 1 ) then
            call psmile_assert ( __FILE__, __LINE__, &
                'Number of Application should be > 0!')
         endif
#endif

! ---------------------------------------------------------------------
!     Get names of applications
! ---------------------------------------------------------------------

!
!===> Broadcast names of all applications
!
         call MPI_Bcast( PRISM_applName(0), (noApplication+1)*max_name, &
                         MPI_Character, &
                         PRISMdrv_root, comm_global, 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
!
!===> Detect Sequence number of application in the set,
!     can be used for coloring in psmile_def_mpi_comm as well
!     It is checked whether Appl%name appears in the list that
!     is received from the transformer. If the name is not found
!     we terminate the application in PSMILe_Error.
!
#ifdef VERBOSE
         do index = 1, noApplication
            print *, trim(ch_id), ': ', index, &
                        'name of the application:         ', trim(Appl%name)
            print *, trim(ch_id), ': ', index, &
                        'compared to name given in PMIOD: ', trim(PRISM_applName(index))
         enddo
#endif
         index = 1

         do while ((trim(Appl%name) /= trim(PRISM_applName(index))) &
                    .and. index <=  noApplication)
            index = index + 1
         enddo

         if ( index > noApplication ) then
            ierrp (1) = noApplication
            ierrp (2) = index
 
            call PSMILe_Error ( ierror, Appl%name, ierrp, 2, &
                                __FILE__, __LINE__ )
            return
         endif

         Appl%sequence_number = index
!
!===> Broadcast names of all components
!
         call MPI_Bcast( PRISM_compName(1), noComponents*max_name, &
                         MPI_Character, &
                         PRISMdrv_root, comm_global, 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
!
!===> Broadcast the number of components of all applications
!
         call MPI_Bcast( PRISM_noCompsPerAppl(1), noApplication, &
                         MPI_Integer, &
                         PRISMdrv_root, comm_global, 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 and broadcast the number of rank sets for the components
!     and the ranksets

         Allocate (PRISM_compRankSets (1:noComponents), STAT = ierror)

         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = noComponents

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

         call MPI_Bcast( PRISM_compRankSets(1), noComponents, &
              MPI_Integer, &
              PRISMdrv_root, comm_global, 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

         noRanksets = sum(PRISM_compRankSets(:))
         Allocate (PRISM_rankSets (noRanksets,3), STAT = ierror)

         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = noRanksets

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

         call MPI_Bcast( PRISM_rankSets(1,1), noRanksets*3, &
              MPI_Integer, &
              PRISMdrv_root, comm_global, 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 and broadcast redirect info
!
         Allocate ( appl_redirect(noApplication), STAT = ierror)
         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = noApplication
            ierror = PRISM_Error_Alloc
            call psmile_error ( ierror, 'appl_redirect', &
                 ierrp, 2, __FILE__, __LINE__ )
            return
         endif

         call MPI_Bcast( appl_redirect, noApplication, &
              MPI_Integer, PRISMdrv_root, comm_global, 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

         PRISM_Redirect(1) = appl_redirect(Appl%sequence_number)

         Deallocate ( appl_redirect, STAT = ierror)
         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = noApplication
            ierror = PRISM_Error_Dealloc
            call psmile_error ( ierror, 'appl_redirect', &
                 ierrp, 2, __FILE__, __LINE__ )
            return
         endif

      endif ! Appl%stand_alone
!
!===> The correct calling sequence of PRISM_init and PRISM_init_comp
!      for multi-component applications is checked. In case PRISM_init
!      is not called explicitly before any call to PRISM_init_comp for
!      applications containing more than one component we terminate in
!      PSMILe_Error.
!
      if ( PRISM_noCompsPerAppl(index) > 1 .and. PRISM_comp_init ) then
            ierror = PRISM_Error_InitApp
            ierrp (1) = PRISM_noCompsPerAppl(index)
            call psmile_error ( ierror, 'Explicit call to PRISM_Init required', &
                               ierrp, 1, __FILE__, __LINE__ )
         return
      endif

!===> Create communicators for applications and alike

      call psmile_def_mpi_comm (ierror)
      if (ierror /= 0) return

      if ( PRISM_ApplProc(index) /= Appl%size ) then

         ierror = PRISM_Error_InitApp
         ierrp (1) = PRISM_ApplProc(index)
         ierrp (2) = Appl%size

         call psmile_error ( ierror, &
               'Inconsistent mpirun command and scc.xml', ierrp, 2, &
                             __FILE__, __LINE__ )
         return
      endif

      if ( .not. Appl%stand_alone ) then
!
!===> Broadcast the run start date and the experiment start date
!     and fill up internal structure. The first half corresponds
!     to the start of the run, the second half corresponds to the
!     start of the experiment.
!
         call MPI_Bcast( idate(1), 15, &
              MPI_Integer, PRISMdrv_root, comm_global, 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( ddate(1), 3, &
              MPI_Double_Precision, PRISMdrv_root, comm_global, 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

         PRISM_Jobstart_date%year   = idate(1)
         PRISM_Jobstart_date%month  = idate(2)
         PRISM_Jobstart_date%day    = idate(3)
         PRISM_Jobstart_date%hour   = idate(4)
         PRISM_Jobstart_date%minute = idate(5)
         PRISM_Jobstart_date%second = ddate(1)

         PRISM_Jobend_date%year   = idate(6)
         PRISM_Jobend_date%month  = idate(7)
         PRISM_Jobend_date%day    = idate(8)
         PRISM_Jobend_date%hour   = idate(9)
         PRISM_Jobend_date%minute = idate(10)
         PRISM_Jobend_date%second = ddate(2)

         PRISM_initial_date%year   = idate(11)
         PRISM_initial_date%month  = idate(12)
         PRISM_initial_date%day    = idate(13)
         PRISM_initial_date%hour   = idate(14)
         PRISM_initial_date%minute = idate(15)
         PRISM_initial_date%second = ddate(3)

      endif

!===> All done

      ierror = 0

#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_Init_MPI1: eof ierror =', ierror
#endif /* VERBOSE */

      end subroutine PSMILe_Init_MPI1