psmile_init_mpi2.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !BOP
00006 !
00007 ! !ROUTINE: PSMILe_Init_MPI2
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_init_mpi2 ( intercomm, ierror)
00012 !
00013 ! !USES:
00014 !
00015       use PRISM_constants
00016       use PSMILe, dummy_interface => PSMILe_Init_MPI2
00017 !
00018       implicit none
00019 !
00020 ! !INPUT PARAMETERS:
00021 !
00022       integer, Intent (InOut)  :: intercomm
00023 !
00024 !     Inter communicator between the spawning communicator and
00025 !     the processes dynamically spawned.
00026 !
00027 ! !OUTPUT PARAMETERS:
00028 !
00029       integer, Intent (Out) :: ierror
00030 
00031 !     Returns the error code of PSMILe_Init_MPI2;
00032 !             ierror = 0 : No error
00033 !             ierror > 0 : Severe error
00034 !
00035 ! !LOCAL VARIABLES
00036 !
00037       logical, parameter :: high = .true.  ! high ordering
00038       logical, parameter :: low  = .false. ! low  ordering
00039 
00040       integer, parameter :: nerrp = 3
00041       integer            :: ierrp (nerrp)
00042 
00043       integer, parameter :: ndibuf = 4
00044       integer            :: ibuf (ndibuf)
00045 
00046       integer            :: coupler_version ! protocol version of coupler
00047       integer            :: intercomm_new, comm_old, comm
00048       integer            :: index, color
00049 
00050       integer            :: status (MPI_STATUS_SIZE)
00051 
00052       integer            :: global_size
00053 
00054       integer, dimension(15) :: idate
00055       double precision, dimension(3) :: ddate
00056 
00057       integer, allocatable :: appl_redirect(:)
00058 !
00059 ! !DESCRIPTION:
00060 !
00061 ! Subroutine PSMILe_Init_MPI2 receives the initial data sent by
00062 ! the master process of the coupler and defines the communicators
00063 ! if processes were spawned by MPI-2 spawning function.
00064 !
00065 ! (*) Set communicator Appl%comm_user
00066 !
00067 ! (*) Create local communicator "Appl%comm"
00068 !
00069 ! (*) Create local communicator for the model and get rank
00070 !
00071 ! (*) Exchange protocol version with coupler and other models
00072 !
00073 ! (*) Create communicator between the coupler and this model
00074 !
00075 ! (*) Get initial data
00076 !
00077 ! (*) Create global communicator
00078 !
00079 !
00080 ! !REVISION HISTORY:
00081 !
00082 !   Date      Programmer   Description
00083 ! ----------  ----------   -----------
00084 ! 01.12.03    R. Redler    created
00085 !
00086 !EOP
00087 !----------------------------------------------------------------------
00088 !
00089 ! $Id: psmile_init_mpi2.F90 2325 2010-04-21 15:00:07Z valcke $
00090 ! $Author: valcke $
00091 !
00092    Character(len=len_cvs_string), save :: mycvs = 
00093        '$Id: psmile_init_mpi2.F90 2325 2010-04-21 15:00:07Z valcke $'
00094 !
00095 !----------------------------------------------------------------------
00096 #ifdef VERBOSE
00097       print *, trim(ch_id), ': PSMILe_Init_mpi2: start'
00098 
00099       call psmile_flushstd
00100 #endif /* VERBOSE */
00101 !
00102 !===> Create communicator for the processes within the model for PSMILe
00103 !     internal usage. This is simply a duplicate of MPI_COMM_WORLD.
00104 !
00105       call MPI_Comm_dup ( MPI_COMM_WORLD, Appl%comm, ierror )
00106 
00107       if ( ierror /= MPI_SUCCESS ) then
00108          ierrp (1) = ierror
00109          ierror = PRISM_Error_MPI
00110 
00111          call psmile_error ( ierror, 'MPI_Comm_dup', &
00112                              ierrp, 1, __FILE__, __LINE__ )
00113          return
00114       endif
00115 !
00116 !===> Create communicator for the processes within the application
00117 !     which is provided to the user with prism_get_local_comm. 
00118 !
00119       call MPI_Comm_dup ( Appl%comm, Appl%comm_user, ierror )
00120 
00121       if ( ierror /= MPI_SUCCESS ) then
00122          ierrp (1) = ierror
00123          ierror = PRISM_Error_MPI
00124 
00125          call psmile_error ( ierror, 'MPI_Comm_dup', &
00126                              ierrp, 1, __FILE__, __LINE__ )
00127          return
00128       endif
00129 
00130       call MPI_Comm_rank ( Appl%comm,  Appl%rank, ierror )
00131 
00132       if ( ierror /= MPI_SUCCESS ) then
00133          ierrp (1) = ierror
00134          ierror = PRISM_Error_MPI
00135 
00136          call psmile_error ( ierror, 'MPI_Comm_rank', &
00137                             ierrp, 1, __FILE__, __LINE__ )
00138          return
00139       endif
00140 
00141       call MPI_Comm_size ( Appl%comm,  Appl%size, ierror )
00142 
00143       if ( ierror /= MPI_SUCCESS ) then
00144          ierrp (1) = ierror
00145          ierror = PRISM_Error_MPI
00146 
00147          call psmile_error ( ierror, 'MPI_Comm_rank', &
00148                             ierrp, 1, __FILE__, __LINE__ )
00149          return
00150       endif
00151 
00152 ! ---------------------------------------------------------------------
00153 !     Get protocol version for communication between the driver and the
00154 !     applications. Corresponding Driver MPI_Bcast calls are located in
00155 !     PRISMDrv_Init_appl.
00156 ! ---------------------------------------------------------------------
00157 
00158 !===> Get protocol version within the application
00159 
00160       call MPI_Allreduce (PSMILe_latest_protocol_version, protocol_version, &
00161                           1, MPI_Integer, MPI_MIN, Appl%comm,  &
00162                           ierror)
00163 
00164       if ( ierror /= MPI_SUCCESS ) then
00165          ierrp (1) = ierror
00166          ierror = PRISM_Error_MPI
00167 
00168          call psmile_error ( ierror, 'MPI_Reduce', &
00169                              ierrp, 1, __FILE__, __LINE__ )
00170          return
00171       endif
00172 
00173       if (PSMILe_latest_protocol_version /= protocol_version) then
00174          print *, trim(ch_id), &
00175              'PSMILe Warning: Different PSMILe protocol versions '
00176          print *, trim(ch_id), &
00177              '                are used in the same application ! '
00178          print *, trim(ch_id), &
00179              '                My protocol version is', protocol_version
00180       endif
00181 
00182 !===> Send protocol version to the coupler
00183 
00184       if ( Appl%rank == PRISM_root) then
00185 
00186         call MPI_Send (protocol_version, 1, MPI_Integer, PRISM_root, &
00187                        PSMILe_Init_tag, intercomm, ierror)
00188 
00189         if ( ierror /= MPI_SUCCESS ) then
00190            ierrp (1) = ierror
00191            ierrp (2) = PRISM_root
00192            ierrp (3) = PSMILe_Init_tag
00193            ierror = PRISM_Error_Send
00194 
00195            call psmile_error ( PRISM_Error_Send, 'MPI_Send', &
00196                                ierrp, 3, __FILE__, __LINE__ )
00197            return
00198         endif
00199 !
00200 !===> Get initial data
00201 !     ibuf (1) = protocol version of the coupler
00202 !     ibuf (2) = Number of application
00203 !     ibuf (3) = Sequence number of current application
00204 !     ibuf (4) = Number of components
00205 !     ibuf (5) = Number of rank sets
00206 !
00207 !     The data is sent by the root of the coupler processes and
00208 !     broadcasted to the processes in the application
00209 
00210          call MPI_Recv ( ibuf, ndibuf, MPI_Integer, &
00211                          PRISM_root, PSMILe_Init_tag, intercomm, &
00212                          status, ierror )
00213 
00214          if ( ierror /= MPI_SUCCESS ) then
00215             ierrp (1) = ierror
00216             ierror = PRISM_Error_MPI
00217 
00218             call psmile_error ( ierror, 'MPI_Recv', &
00219                                 ierrp, 1, __FILE__, __LINE__ )
00220             return
00221          endif
00222 !
00223       endif
00224 !
00225 !===> Broadcast data to the processes of the application
00226 !
00227       call MPI_Bcast ( ibuf, ndibuf, MPI_Integer, &
00228                        PRISM_root, Appl%comm, ierror )
00229 
00230       if ( ierror /= MPI_SUCCESS ) then
00231          ierrp (1) = ierror
00232          ierror = PRISM_Error_MPI
00233 
00234          call psmile_error ( ierror, 'MPI_Bcast', &
00235                              ierrp, 1, __FILE__, __LINE__ )
00236          return
00237       endif
00238 !
00239       coupler_version      = ibuf (1)
00240       noApplication        = ibuf (2)
00241       Appl%sequence_number = ibuf (3)
00242       NoComponents         = ibuf (4)
00243 
00244 #ifdef PRISM_ASSERTION
00245       if (  noApplication < 1 ) then
00246          call psmile_assert ( __FILE__, __LINE__, &
00247              'Number of Application should be > 0!')
00248       endif
00249 
00250       if ( noComponents < noApplication  ) then
00251          call psmile_assert ( __FILE__, __LINE__, &
00252              'Number of Components should be >= Number of Applications!')
00253       endif
00254 #endif
00255 !
00256 !===> Merge intercommunicator "intercomm" and free it.
00257 !     It is not the inter_communicator to the coupler.
00258 !
00259       call MPI_Intercomm_merge ( intercomm, high, &
00260                                  comm_global, ierror)
00261 
00262       if ( ierror /= 0 ) then
00263          ierrp (1) = ierror
00264          ierror = PRISM_Error_MPI
00265 
00266          call psmile_error ( ierror, 'MPI_Intercomm_merge', &
00267                              ierrp, 1, __FILE__, __LINE__ )
00268          return
00269       endif
00270 
00271       if ( Appl%sequence_number /= 1) then
00272 
00273          call MPI_Comm_free (intercomm, ierror)
00274          if ( ierror /= 0 ) then
00275             ierrp (1) = ierror
00276             ierror = PRISM_Error_MPI
00277 
00278             call psmile_error ( ierror, 'MPI_Comm_free', &
00279                                 ierrp, 1, __FILE__, __LINE__ )
00280             return
00281          endif
00282 
00283       else
00284 
00285          comm_coupler = comm_global
00286 
00287       endif
00288 
00289 ! ---------------------------------------------------------------------
00290 !     Spawn further processes
00291 !
00292 !     The MPI processes of the application join the creation
00293 !     of the further applications in order to generate a global
00294 !     communicator.
00295 ! ---------------------------------------------------------------------
00296 
00297       do index = Appl%sequence_number+1, noApplication
00298 
00299         call psmile_spawn_child_appl (comm_global, intercomm_new, ierror)
00300         if (ierror /= 0) return
00301 
00302         comm_old = comm_global
00303 !
00304 ! ... Merge Intercommunicator so that the new processes are
00305 !     spawned within the merged communicator
00306 
00307         call MPI_Intercomm_merge ( intercomm_new, low, &
00308                                    comm_global, ierror)
00309 
00310         if ( ierror /= 0 ) then
00311            ierrp (1) = ierror
00312            ierror = PRISM_Error_MPI
00313 
00314            call psmile_error ( ierror, 'MPI_Intercomm_merge', &
00315                                ierrp, 1, __FILE__, __LINE__ )
00316            return
00317         endif
00318 
00319         call MPI_Comm_free (intercomm_new, ierror)
00320         if ( ierror /= 0 ) then
00321            ierrp (1) = ierror
00322            ierror = PRISM_Error_MPI
00323 
00324            call psmile_error ( ierror, 'MPI_Comm_free', &
00325                                ierrp, 1, __FILE__, __LINE__ )
00326            return
00327         endif
00328 
00329         if (index > 2) then
00330            call MPI_Comm_free (comm_old, ierror)
00331            if ( ierror /= 0 ) then
00332               ierrp (1) = ierror
00333               ierror = PRISM_Error_MPI
00334 
00335               call psmile_error ( ierror, 'MPI_Comm_free', &
00336                                   ierrp, 1, __FILE__, __LINE__ )
00337               return
00338            endif
00339         endif
00340 
00341       enddo
00342 
00343 ! The resulting communicator is the global communicator
00344 
00345       call MPI_Comm_rank ( comm_global, global_rank, ierror )
00346 
00347       if ( ierror /= MPI_SUCCESS ) then
00348          ierrp (1) = ierror
00349          ierror = PRISM_Error_MPI
00350 
00351          call psmile_error ( ierror, 'MPI_Comm_rank', &
00352                             ierrp, 1, __FILE__, __LINE__ )
00353          return
00354       endif
00355 !
00356 !===> Duplicate comm_global to get comm_trans
00357 !
00358       call MPI_Comm_dup (comm_global, comm_trans, ierror)
00359 
00360       if ( ierror /= MPI_SUCCESS ) then
00361          ierrp (1) = ierror
00362          ierror = PRISM_Error_MPI
00363 
00364          call psmile_error ( ierror, 'MPI_Comm_dup', &
00365                              ierrp, 1, __FILE__, __LINE__ )
00366          return
00367       endif
00368 
00369 ! ---------------------------------------------------------------------
00370 !     All applications started
00371 !
00372 !     (*) Receive and broadcast final protocol version
00373 ! ---------------------------------------------------------------------
00374 
00375 !===> Broadcast the final protocol version within the global communicator
00376 
00377       call MPI_Bcast ( protocol_version, 1, MPI_Integer, &
00378                        PRISMdrv_root, comm_global, ierror )
00379 
00380       if ( ierror /= MPI_SUCCESS ) then
00381          ierrp (1) = ierror
00382          ierror = PRISM_Error_MPI
00383 
00384          call psmile_error ( ierror, 'MPI_Bcast', &
00385                              ierrp, 1, __FILE__, __LINE__ )
00386          return
00387       endif
00388 
00389 #ifdef PRISM_ASSERTION
00390       if (  protocol_version < 0 .or. &
00391             protocol_version > PSMILe_latest_protocol_version) then
00392 
00393          write (*, 9990)
00394          call psmile_assert ( __FILE__, __LINE__, &
00395            'impossible protocol versions computed')
00396 
00397 9990 format (/1x, 'PSMILe_Init_MPI2: protocol_version =', i7, &
00398                  '; latest =', i7)
00399       endif
00400 #endif /* PRISM_ASSERTION */
00401 
00402 ! ---------------------------------------------------------------------
00403 ! Get initial data from the root of coupler processes and
00404 ! ---------------------------------------------------------------------
00405 
00406 !
00407 !===> Allocate global vectors
00408 !
00409       Allocate (PRISM_applProc (0:noApplication), STAT = ierror)
00410 
00411       if ( ierror > 0 ) then
00412          ierrp (1) = ierror
00413          ierrp (2) = noApplication + 1
00414 
00415          ierror = PRISM_Error_Alloc
00416          call psmile_error ( ierror, 'PRISM_applProc', &
00417                              ierrp, 2, __FILE__, __LINE__ )
00418          return
00419       endif
00420 
00421       Allocate (PRISM_applName (0:noApplication), STAT = ierror)
00422 
00423       if ( ierror > 0 ) then
00424          ierrp (1) = ierror
00425          ierrp (2) = noApplication + 1
00426 
00427          ierror = PRISM_Error_Alloc
00428          call psmile_error ( ierror, 'PRISM_applName', &
00429                              ierrp, 2, __FILE__, __LINE__ )
00430          return
00431       endif
00432 
00433       Allocate (PRISM_noCompsPerAppl (noApplication), STAT = ierror)
00434 
00435       if ( ierror > 0 ) then
00436          ierrp (1) = ierror
00437          ierrp (2) = noApplication
00438 
00439          ierror = PRISM_Error_Alloc
00440          call psmile_error ( ierror, 'PRISM_noCompsPerAppl', &
00441                              ierrp, 2, __FILE__, __LINE__ )
00442          return
00443       endif
00444 
00445       Allocate (PRISM_compName (1:noComponents), STAT = ierror)
00446 
00447       if ( ierror > 0 ) then
00448          ierrp (1) = ierror
00449          ierrp (2) = noComponents
00450 
00451          ierror = PRISM_Error_Alloc
00452          call psmile_error ( ierror, 'PRISM_compName', &
00453                              ierrp, 2, __FILE__, __LINE__ )
00454          return
00455       endif
00456 
00457 !
00458 !===> Number of processes per application from SCC is
00459 !     distributed to all processes
00460 !
00461       call MPI_Bcast( PRISM_applProc(0), noApplication+1, MPI_Integer, &
00462                       PRISMdrv_root, comm_global, ierror )
00463 
00464       if ( ierror /= MPI_SUCCESS ) then
00465          ierrp (1) = ierror
00466          ierror = PRISM_Error_MPI
00467          call psmile_error ( ierror, 'MPI_Bcast', ierrp, 1, &
00468                              __FILE__, __LINE__ )
00469          return
00470       endif
00471 
00472       if ( PRISM_ApplProc(Appl%sequence_number) /= Appl%size ) then
00473 
00474          ierror = PRISM_Error_InitApp
00475          ierrp (1) = PRISM_ApplProc(Appl%sequence_number)
00476          ierrp (2) = Appl%size
00477 
00478          call psmile_error ( ierror, &
00479                'Inconsistent mpirun command and scc.xml', ierrp, 2, &
00480                              __FILE__, __LINE__ )
00481          return
00482       endif
00483 
00484 #ifdef PRISM_ASSERTION
00485       if ( PRISM_applProc(0) < 1 ) then
00486         call psmile_assert ( __FILE__, __LINE__, &
00487              'Coupler should be assigned to at least 1 processor!')
00488       endif
00489 #endif
00490 !
00491 ! -----------------------------------------------------------------------
00492 !     Get names of all applications
00493 ! -----------------------------------------------------------------------
00494 !===> Number of processes per application is distributed to all processes
00495 !     Note: This is only temporarily used in order to collect
00496 !           the names of applications for the test coupler 
00497 !
00498       call MPI_Comm_Size( comm_global, global_size, ierror )
00499 
00500       if ( ierror /= MPI_SUCCESS ) then
00501          ierrp (1) = ierror
00502          ierror = PRISM_Error_MPI
00503 
00504          call psmile_error ( ierror, 'MPI_Comm_size', &
00505                              ierrp, 1, __FILE__, __LINE__ )
00506          return
00507       endif
00508 !
00509 !===> Broadcast names of all applications
00510 !
00511       call MPI_Bcast( PRISM_applName(0), (noApplication+1)*max_name, &
00512                       MPI_Character, &
00513                       PRISMdrv_root, comm_global, ierror )
00514 
00515       if ( ierror /= MPI_SUCCESS ) then
00516          ierrp (1) = ierror
00517          ierror = PRISM_Error_MPI
00518          call psmile_error ( ierror, 'MPI_Bcast', ierrp, 1, &
00519                              __FILE__, __LINE__ )
00520          return
00521       endif
00522 !
00523 !===> Broadcast names of all components
00524 !
00525       call MPI_Bcast( PRISM_compName(1), noComponents*max_name, &
00526                       MPI_Character, &
00527                       PRISMdrv_root, comm_global, ierror )
00528 
00529       if ( ierror /= MPI_SUCCESS ) then
00530          ierrp (1) = ierror
00531          ierror = PRISM_Error_MPI
00532          call psmile_error ( ierror, 'MPI_Bcast', ierrp, 1, &
00533                              __FILE__, __LINE__ )
00534          return
00535       endif
00536 !
00537 !===> Broadcast the number of components of all applications
00538 !
00539       call MPI_Bcast( PRISM_noCompsPerAppl(1), noApplication, &
00540                       MPI_Integer, &
00541                       PRISMdrv_root, comm_global, ierror )
00542 
00543       if ( ierror /= MPI_SUCCESS ) then
00544          ierrp (1) = ierror
00545          ierror = PRISM_Error_MPI
00546          call psmile_error ( ierror, 'MPI_Bcast', ierrp, 1, &
00547                              __FILE__, __LINE__ )
00548          return
00549       endif
00550 !
00551 !===> The correct calling sequence of PRISM_init and PRISM_init_comp
00552 !      for multi-component applications is checked. In case PRISM_init
00553 !      is not called explicitly before any call to PRISM_init_comp for
00554 !      applications containing more than one component we terminate in
00555 !      PSMILe_Error.
00556 !
00557       if ( PRISM_noCompsPerAppl(Appl%sequence_number) > 1 .and. PRISM_comp_init ) then
00558             ierror = PRISM_Error_InitApp
00559             ierrp (1) = PRISM_noCompsPerAppl(Appl%sequence_number)
00560             call psmile_error ( ierror, 'Explicit call to PRISM_Init required', &
00561                                ierrp, 1, __FILE__, __LINE__ )
00562          return
00563       endif
00564 !
00565 !===> Broadcast the number of rank sets for the components,
00566 !     and then the ranksets
00567 
00568       Allocate (PRISM_compRankSets (1:noComponents), STAT = ierror)
00569 
00570       if ( ierror > 0 ) then
00571          ierrp (1) = ierror
00572          ierrp (2) = noComponents
00573 
00574          ierror = PRISM_Error_Alloc
00575          call psmile_error ( ierror, 'PRISM_compRankSets', &
00576                              ierrp, 2, __FILE__, __LINE__ )
00577          return
00578       endif
00579 
00580       call MPI_Bcast( PRISM_compRankSets(1), noComponents, &
00581      MPI_Integer, &
00582      PRISMdrv_root, comm_global, ierror )
00583 
00584       if ( ierror /= MPI_SUCCESS ) then
00585       ierrp (1) = ierror
00586       ierror = PRISM_Error_MPI
00587           call psmile_error ( ierror, 'MPI_Bcast', ierrp, 1, &
00588          __FILE__, __LINE__ )
00589           return
00590       endif
00591 
00592       noRanksets = sum(PRISM_compRankSets(:))
00593       Allocate (PRISM_rankSets (noRanksets,3), STAT = ierror)
00594 
00595       if ( ierror > 0 ) then
00596          ierrp (1) = ierror
00597          ierrp (2) = noRanksets
00598 
00599          ierror = PRISM_Error_Alloc
00600          call psmile_error ( ierror, 'PRISM_rankSets', &
00601                              ierrp, 2, __FILE__, __LINE__ )
00602          return
00603       endif
00604 
00605       call MPI_Bcast( PRISM_rankSets(1,1), noRanksets*3, &
00606      MPI_Integer, &
00607      PRISMdrv_root, comm_global, ierror )
00608 
00609       if ( ierror /= MPI_SUCCESS ) then
00610       ierrp (1) = ierror
00611       ierror = PRISM_Error_MPI
00612           call psmile_error ( ierror, 'MPI_Bcast', ierrp, 1, &
00613          __FILE__, __LINE__ )
00614           return
00615       endif
00616 !
00617 !===> Allocate and broadcast redirect info
00618 !
00619          Allocate ( appl_redirect(noApplication), STAT = ierror)
00620          if ( ierror > 0 ) then
00621             ierrp (1) = ierror
00622             ierrp (2) = noApplication
00623             ierror = PRISM_Error_Alloc
00624             call psmile_error ( ierror, 'appl_redirect', &
00625                  ierrp, 2, __FILE__, __LINE__ )
00626             return
00627          endif
00628 
00629          call MPI_Bcast( appl_redirect, noApplication, &
00630               MPI_Integer, PRISMdrv_root, comm_global, ierror )
00631 
00632          if ( ierror /= MPI_SUCCESS ) then
00633             ierrp (1) = ierror
00634             ierror = PRISM_Error_MPI
00635             call psmile_error ( ierror, 'MPI_Bcast', ierrp, 1, &
00636                  __FILE__, __LINE__ )
00637             return
00638          endif
00639 
00640          PRISM_Redirect(1) = appl_redirect(Appl%sequence_number)
00641 
00642          Deallocate ( appl_redirect, STAT = ierror)
00643          if ( ierror > 0 ) then
00644             ierrp (1) = ierror
00645             ierrp (2) = noApplication
00646             ierror = PRISM_Error_Dealloc
00647             call psmile_error ( ierror, 'appl_redirect', &
00648                  ierrp, 2, __FILE__, __LINE__ )
00649             return
00650          endif
00651 
00652 ! ---------------------------------------------------------------------
00653 ! Split global communicator in order to get a communicator
00654 ! between the coupler and the application
00655 !
00656 ! The communicator for the first application is already created.
00657 ! ---------------------------------------------------------------------
00658 
00659       do index = 2, noApplication
00660 
00661          if (index == Appl%sequence_number) then
00662             color = Appl%sequence_number
00663          else
00664             color = MPI_UNDEFINED
00665          endif
00666 
00667          call MPI_Comm_split (comm_global, color, global_rank, comm, ierror)
00668 
00669          if ( ierror /= MPI_SUCCESS ) then
00670             ierrp (1) = ierror
00671             ierror = PRISM_Error_MPI
00672 
00673             call psmile_error ( ierror, 'MPI_Comm_split', &
00674                                ierrp, 1, __FILE__, __LINE__ )
00675             return
00676          endif
00677 
00678          if (index == Appl%sequence_number) comm_coupler = comm
00679 
00680       enddo
00681 
00682 ! ----------------------------------------------------------------------------
00683 ! Construct a communicator comm_psmile containing all MPI processes
00684 ! which are connected to the PSMILe library
00685 ! ----------------------------------------------------------------------------
00686 
00687       color = 1
00688 
00689       call MPI_Comm_Split ( comm_global, color, global_rank,  &
00690                             comm_psmile, ierror )
00691 
00692       if ( ierror /= MPI_SUCCESS ) then
00693          ierrp (1) = ierror
00694          ierror = PRISM_Error_MPI
00695 
00696          call psmile_error ( ierror, 'MPI_Comm_Split', &
00697                              ierrp, 1, __FILE__, __LINE__ )
00698          return
00699       endif
00700 !
00701 !===> Broadcast  the run start date and the experiment start date
00702 !     and fill up internal structure. The first half corresponds
00703 !     to the start of the run, the second half corresponds to the
00704 !     start of the experiment.
00705 !
00706       call MPI_Bcast( idate(1), 15, &
00707          MPI_Integer, PRISMdrv_root, comm_global, ierror )
00708 
00709       if ( ierror /= MPI_SUCCESS ) then
00710          ierrp (1) = ierror
00711          ierror = PRISM_Error_MPI
00712          call psmile_error ( ierror, 'MPI_Bcast', ierrp, 1, &
00713                              __FILE__, __LINE__ )
00714          return
00715       endif
00716 
00717       call MPI_Bcast( ddate(1), 3, &
00718          MPI_Double_Precision, PRISMdrv_root, comm_global, ierror )
00719 
00720       if ( ierror /= MPI_SUCCESS ) then
00721          ierrp (1) = ierror
00722          ierror = PRISM_Error_MPI
00723          call psmile_error ( ierror, 'MPI_Bcast', ierrp, 1, &
00724                              __FILE__, __LINE__ )
00725          return
00726       endif
00727 
00728       PRISM_Jobstart_date%year   = idate(1)
00729       PRISM_Jobstart_date%month  = idate(2)
00730       PRISM_Jobstart_date%day    = idate(3)
00731       PRISM_Jobstart_date%hour   = idate(4)
00732       PRISM_Jobstart_date%minute = idate(5)
00733       PRISM_Jobstart_date%second = ddate(1)
00734 
00735       PRISM_Jobend_date%year     = idate(6)
00736       PRISM_Jobend_date%month    = idate(7)
00737       PRISM_Jobend_date%day      = idate(8)
00738       PRISM_Jobend_date%hour     = idate(9)
00739       PRISM_Jobend_date%minute   = idate(10)
00740       PRISM_Jobend_date%second   = ddate(2)
00741 
00742       PRISM_initial_date%year    = idate(11)
00743       PRISM_initial_date%month   = idate(12)
00744       PRISM_initial_date%day     = idate(13)
00745       PRISM_initial_date%hour    = idate(14)
00746       PRISM_initial_date%minute  = idate(15)
00747       PRISM_initial_date%second  = ddate(3)
00748 !
00749 !===> All done
00750 !
00751       ierror = 0
00752 
00753 #ifdef VERBOSE
00754       print *, trim(ch_id), ': eof PSMILe_Init_mpi2: ierror', ierror
00755 
00756       call psmile_flushstd
00757 #endif /* VERBOSE */
00758 
00759       end subroutine PSMILe_Init_MPI2