Ignore:
Timestamp:
May 4, 2016 3:27:53 PM (5 years ago)
Author:
raasch
Message:

re-formatting of remaining pmc routines

File:
1 edited

Legend:

Unmodified
Added
Removed
  • palm/trunk/SOURCE/pmc_handle_communicator_mod.f90

    r1883 r1900  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! re-formatting to match PALM style
    2323!
    2424! Former revisions:
     
    3232! 1850 2016-04-08 13:29:27Z maronga
    3333! Module renamed
    34 !
    3534!
    3635! 1808 2016-04-05 19:44:00Z raasch
     
    7978#endif
    8079
    81    USE pmc_general,                                                            &
    82        ONLY: pmc_status_ok, pmc_status_error, pmc_max_modell
    83 
    84    IMPLICIT NONE
    85 
    86    TYPE pmc_layout
    87 
    88       CHARACTER(len=32) ::  name
    89 
    90       INTEGER  ::  id
    91       INTEGER  ::  parent_id
    92       INTEGER  ::  npe_total
    93 
    94       REAL(wp) ::  lower_left_x
    95       REAL(wp) ::  lower_left_y
    96 
    97    END TYPE pmc_layout
    98 
    99    PUBLIC  pmc_status_ok, pmc_status_error
    100 
    101    INTEGER, PARAMETER, PUBLIC ::  pmc_error_npes          = 1  ! illegal number of PEs
    102    INTEGER, PARAMETER, PUBLIC ::  pmc_namelist_error      = 2  ! error(s) in nestpar namelist
    103    INTEGER, PARAMETER, PUBLIC ::  pmc_no_namelist_found   = 3  ! No couple layout file found
    104 
    105    ! Coupler Setup
    106 
    107    INTEGER                                    :: m_world_comm !global nesting communicator
    108    INTEGER                                    :: m_my_CPL_id  !Coupler id of this model
    109    INTEGER                                    :: m_Parent_id  !Coupler id of parent of this model
    110    INTEGER                                    :: m_ncpl       !Number of Couplers in layout file
    111 
    112    TYPE(PMC_layout),DIMENSION(PMC_MAX_MODELL) :: m_couplers   !Information of all couplers
    113 
    114    ! MPI settings
    115 
    116    INTEGER,PUBLIC                    :: m_model_comm          !Communicator of this model
    117    INTEGER,PUBLIC                    :: m_to_server_comm      !Communicator to the server
    118    INTEGER,DIMENSION(PMC_MAX_MODELL) :: m_to_client_comm      !Communicator to the client(s)
    119    INTEGER,PUBLIC                    :: m_world_rank
    120    INTEGER                           :: m_world_npes
    121    INTEGER,PUBLIC                    :: m_model_rank
    122    INTEGER,PUBLIC                    :: m_model_npes
    123    INTEGER                           :: m_server_remote_size  !Number of Server PE's
    124 
    125    PUBLIC m_to_client_comm
    126 
    127    !Indicates this PE is server for Cleint NR
    128 
    129    INTEGER,DIMENSION(:),POINTER,PUBLIC :: PMC_Server_for_Client
    130 
    131    INTERFACE pmc_is_rootmodel
    132       MODULE PROCEDURE pmc_is_rootmodel
    133    END INTERFACE pmc_is_rootmodel
    134 
    135    INTERFACE pmc_get_model_info
    136       MODULE PROCEDURE pmc_get_model_info
    137    END INTERFACE pmc_get_model_info
    138 
    139    PUBLIC pmc_get_model_info, pmc_init_model, pmc_is_rootmodel
     80    USE pmc_general,                                                           &
     81        ONLY: pmc_status_ok, pmc_status_error, pmc_max_models
     82
     83    IMPLICIT NONE
     84
     85    TYPE pmc_layout
     86
     87       CHARACTER(LEN=32) ::  name
     88
     89       INTEGER  ::  id            !<
     90       INTEGER  ::  parent_id     !<
     91       INTEGER  ::  npe_total     !<
     92
     93       REAL(wp) ::  lower_left_x  !<
     94       REAL(wp) ::  lower_left_y  !<
     95
     96    END TYPE pmc_layout
     97
     98    PUBLIC  pmc_status_ok, pmc_status_error
     99
     100    INTEGER, PARAMETER, PUBLIC ::  pmc_error_npes        = 1  !< illegal number of PEs
     101    INTEGER, PARAMETER, PUBLIC ::  pmc_namelist_error    = 2  !< error(s) in nestpar namelist
     102    INTEGER, PARAMETER, PUBLIC ::  pmc_no_namelist_found = 3  !< no couple layout namelist found
     103
     104    INTEGER ::  m_world_comm  !< global nesting communicator
     105    INTEGER ::  m_my_cpl_id   !< coupler id of this model
     106    INTEGER ::  m_parent_id   !< coupler id of parent of this model
     107    INTEGER ::  m_ncpl        !< number of couplers given in nestpar namelist
     108
     109    TYPE(pmc_layout), DIMENSION(pmc_max_models) ::  m_couplers  !< information of all couplers
     110
     111    INTEGER, PUBLIC ::  m_model_comm          !< communicator of this model
     112    INTEGER, PUBLIC ::  m_to_server_comm      !< communicator to the server
     113    INTEGER, PUBLIC ::  m_world_rank          !<
     114    INTEGER         ::  m_world_npes          !<
     115    INTEGER, PUBLIC ::  m_model_rank          !<
     116    INTEGER, PUBLIC ::  m_model_npes          !<
     117    INTEGER         ::  m_server_remote_size  !< number of server PEs
     118
     119    INTEGER, DIMENSION(pmc_max_models), PUBLIC ::  m_to_client_comm   !< communicator to the client(s)
     120    INTEGER, DIMENSION(:), POINTER, PUBLIC ::  pmc_server_for_client  !<
     121
     122
     123    INTERFACE pmc_is_rootmodel
     124       MODULE PROCEDURE pmc_is_rootmodel
     125    END INTERFACE pmc_is_rootmodel
     126
     127    INTERFACE pmc_get_model_info
     128       MODULE PROCEDURE pmc_get_model_info
     129    END INTERFACE pmc_get_model_info
     130
     131    PUBLIC pmc_get_model_info, pmc_init_model, pmc_is_rootmodel
    140132
    141133 CONTAINS
    142134
    143    SUBROUTINE pmc_init_model( comm, nesting_datatransfer_mode, nesting_mode,   &
     135 SUBROUTINE pmc_init_model( comm, nesting_datatransfer_mode, nesting_mode,     &
    144136                              pmc_status )
    145137
    146       USE control_parameters,                                                  &
    147           ONLY:  message_string
    148 
    149       USE pegrid,                                                              &
    150           ONLY:  myid
     138    USE control_parameters,                                                    &
     139        ONLY:  message_string
     140
     141    USE pegrid,                                                                &
     142        ONLY:  myid
    151143
    152144      IMPLICIT NONE
    153145
    154       CHARACTER(LEN=7), INTENT(OUT) ::  nesting_mode
    155       CHARACTER(LEN=7), INTENT(OUT) ::  nesting_datatransfer_mode
    156 
    157       INTEGER, INTENT(OUT)                ::  comm
    158       INTEGER, INTENT(OUT)                ::  pmc_status
    159 
    160       INTEGER                             ::  i, ierr, istat
    161       INTEGER,DIMENSION(pmc_max_modell+1) ::  start_pe
    162       INTEGER                             ::  m_my_cpl_rank
    163       INTEGER                             ::  tag, clientcount
    164       INTEGER,DIMENSION(pmc_max_modell)   ::  activeserver  ! I am active server for this client ID
    165 
    166       pmc_status   = pmc_status_ok
    167       comm         = -1
    168       m_world_comm = MPI_COMM_WORLD
    169       m_my_cpl_id  = -1
    170       clientcount  =  0
    171       activeserver = -1
    172       start_pe(:)  =  0
    173 
    174       CALL  MPI_COMM_RANK( MPI_COMM_WORLD, m_world_rank, istat )
    175       CALL  MPI_COMM_SIZE( MPI_COMM_WORLD, m_world_npes, istat )
    176 !
    177 !--   Only PE 0 of root model reads
    178       IF ( m_world_rank == 0 )  THEN
    179 
    180          CALL read_coupling_layout( nesting_datatransfer_mode, nesting_mode,   &
    181                                     pmc_status )
    182 
    183          IF ( pmc_status /= pmc_no_namelist_found  .AND.                       &
    184               pmc_status /= pmc_namelist_error )                               &
    185          THEN
    186 !
    187 !--         Calculate start PE of every model
    188             start_pe(1) = 0
    189             DO  i = 2, m_ncpl+1
    190                start_pe(i) = start_pe(i-1) + m_couplers(i-1)%npe_total
    191             ENDDO
    192 
    193 !
    194 !--         The number of cores provided with the run must be the same as the
    195 !--         total sum of cores required by all nest domains
    196             IF ( start_pe(m_ncpl+1) /= m_world_npes )  THEN
    197                WRITE ( message_string, '(A,I6,A,I6,A)' )                       &
    198                                'nesting-setup requires more MPI procs (',      &
    199                                start_pe(m_ncpl+1), ') than provided (',        &
    200                                m_world_npes,')'
    201                CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
    202             ENDIF
    203 
    204          ENDIF
    205 
    206       ENDIF
    207 !
    208 !--   Broadcast the read status. This synchronises all other PEs with PE 0 of
    209 !--   the root model. Without synchronisation, they would not behave in the
    210 !--   correct way (e.g. they would not return in case of a missing NAMELIST)
    211       CALL MPI_BCAST( pmc_status, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
    212 
    213       IF ( pmc_status == pmc_no_namelist_found )  THEN
    214 !
    215 !--      Not a nested run; return the MPI_WORLD communicator
    216          comm = MPI_COMM_WORLD
    217          RETURN
    218 
    219       ELSEIF ( pmc_status == pmc_namelist_error )  THEN
    220 !
    221 !--      Only the root model gives the error message. Others are aborted by the
    222 !--      message-routine with MPI_ABORT. Must be done this way since myid and
    223 !--      comm2d have not yet been assigned at this point.
    224          IF ( m_world_rank == 0 )  THEN
    225             message_string = 'errors in \$nestpar'
    226             CALL message( 'pmc_init_model', 'PA0223', 3, 2, 0, 6, 0 )
    227          ENDIF
    228 
    229       ENDIF
    230 
    231       CALL MPI_BCAST( m_ncpl,          1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
    232       CALL MPI_BCAST( start_pe, m_ncpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
    233 
    234 !
    235 !--   Broadcast coupling layout
    236       DO  i = 1, m_ncpl
    237          CALL MPI_BCAST( m_couplers(i)%name, LEN( m_couplers(i)%name ), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
    238          CALL MPI_BCAST( m_couplers(i)%id,           1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
    239          CALL MPI_BCAST( m_couplers(i)%Parent_id,    1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
    240          CALL MPI_BCAST( m_couplers(i)%npe_total,    1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
    241          CALL MPI_BCAST( m_couplers(i)%lower_left_x, 1, MPI_REAL,    0, MPI_COMM_WORLD, istat )
    242          CALL MPI_BCAST( m_couplers(i)%lower_left_y, 1, MPI_REAL,    0, MPI_COMM_WORLD, istat )
    243       ENDDO
    244       CALL MPI_BCAST( nesting_mode, LEN( nesting_mode ), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
    245       CALL MPI_BCAST( nesting_datatransfer_mode, LEN(nesting_datatransfer_mode), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
    246 
    247 !
    248 !--   Assign global MPI processes to individual models by setting the couple id
    249       DO  i = 1, m_ncpl
    250          IF ( m_world_rank >= start_pe(i)  .AND.  m_world_rank < start_pe(i+1) ) &
    251          THEN
    252             m_my_cpl_id = i
    253             EXIT
    254          ENDIF
    255       ENDDO
    256       m_my_cpl_rank = m_world_rank - start_pe(i)
    257 
    258 !
    259 !--   MPI_COMM_WORLD is the communicator for ALL models (MPI-1 approach).
    260 !--   The communictors for the individual models as created by MPI_COMM_SPLIT.
    261 !--   The color of the model is represented by the coupler id
    262       CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, m_my_cpl_id, m_my_cpl_rank, comm,   &
    263                            istat )
    264 !
    265 !--   Get size and rank of the model running on this PE
    266       CALL  MPI_COMM_RANK( comm, m_model_rank, istat )
    267       CALL  MPI_COMM_SIZE( comm, m_model_npes, istat )
    268 
    269 !
    270 !--   Broadcast (from PE 0) the parent id and id of every model
    271       DO  i = 1, m_ncpl
    272          CALL MPI_BCAST( m_couplers(i)%parent_id, 1, MPI_INTEGER, 0,           &
    273                          MPI_COMM_WORLD, istat )
    274          CALL MPI_BCAST( m_couplers(i)%id,        1, MPI_INTEGER, 0,           &
    275                          MPI_COMM_WORLD, istat )
    276       ENDDO
    277 
    278 !
    279 !--   Save the current model communicator for PMC internal use
    280       m_model_comm = comm
    281 
    282 !
    283 !--   Create intercommunicator between server and clients.
    284 !--   MPI_INTERCOMM_CREATE creates an intercommunicator between 2 groups of
    285 !--   different colors.
    286 !--   The grouping was done above with MPI_COMM_SPLIT
    287       DO  i = 2, m_ncpl
    288 
    289          IF ( m_couplers(i)%parent_id == m_my_cpl_id )  THEN
    290 !
    291 !--         Collect server PEs.
    292 !--         Every model exept the root model has a parent model which acts as
    293 !--         server model. Create an intercommunicator to connect current PE to
    294 !--         all client PEs
    295             tag = 500 + i
    296             CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD, start_pe(i),   &
    297                                        tag, m_to_client_comm(i), istat)
    298             clientcount = clientcount + 1
    299             activeserver(i) = 1
    300 
    301          ELSEIF ( i == m_my_cpl_id)  THEN
    302 !
    303 !--         Collect client PEs.
    304 !--         Every model exept the root model has a paremt model which acts as
    305 !--         server model. Create an intercommunicator to connect current PE to
    306 !--         all server PEs
    307             tag = 500 + i
    308             CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD,                &
    309                                        start_pe(m_couplers(i)%parent_id),      &
    310                                        tag, m_to_server_comm, istat )
    311          ENDIF
    312 
    313       ENDDO
    314 
    315 !
    316 !--   If I am server, count the number of clients that I have
    317 !--   Although this loop is symmetric on all processes, the "activeserver" flag
    318 !--   is true (==1) on the respective individual PE only.
    319       ALLOCATE( pmc_server_for_client(clientcount+1) )
    320 
    321       clientcount = 0
    322       DO  i = 2, m_ncpl
    323          IF ( activeserver(i) == 1 )  THEN
    324             clientcount = clientcount + 1
    325             pmc_server_for_client(clientcount) = i
    326          ENDIF
    327       ENDDO
    328 !
    329 !--   Get the size of the server model
    330       IF ( m_my_cpl_id > 1 )  THEN
    331          CALL MPI_COMM_REMOTE_SIZE( m_to_server_comm, m_server_remote_size,    &
    332                                     istat)
    333       ELSE
    334 !
    335 !--      The root model does not have a server
    336          m_server_remote_size = -1             !
    337       ENDIF
    338 !
    339 !--   Set myid to non-tero value except for the root domain. This is a setting
    340 !--   for the message routine which is called at the end of pmci_init. That
    341 !--   routine outputs messages for myid = 0, only. However, myid has not been
    342 !--   assigened so far, so that all PEs of the root model would output a
    343 !--   message. To avoid this, set myid to some other value except for PE0 of the
    344 !--   root domain.
    345       IF ( m_world_rank /= 0 )  myid = 1
    346 
    347    END SUBROUTINE PMC_init_model
    348 
    349 
     146    CHARACTER(LEN=7), INTENT(OUT) ::  nesting_mode               !<
     147    CHARACTER(LEN=7), INTENT(OUT) ::  nesting_datatransfer_mode  !<
     148
     149    INTEGER, INTENT(OUT) ::  comm        !<
     150    INTEGER, INTENT(OUT) ::  pmc_status  !<
     151
     152    INTEGER ::  clientcount    !<
     153    INTEGER ::  i              !<
     154    INTEGER ::  ierr           !<
     155    INTEGER ::  istat          !<
     156    INTEGER ::  m_my_cpl_rank  !<
     157    INTEGER ::  tag            !<
     158
     159    INTEGER, DIMENSION(pmc_max_models)   ::  activeserver  ! I am active server for this client ID
     160    INTEGER, DIMENSION(pmc_max_models+1) ::  start_pe
     161
     162    pmc_status   = pmc_status_ok
     163    comm         = -1
     164    m_world_comm = MPI_COMM_WORLD
     165    m_my_cpl_id  = -1
     166    clientcount  =  0
     167    activeserver = -1
     168    start_pe(:)  =  0
     169
     170    CALL MPI_COMM_RANK( MPI_COMM_WORLD, m_world_rank, istat )
     171    CALL MPI_COMM_SIZE( MPI_COMM_WORLD, m_world_npes, istat )
     172!
     173!-- Only PE 0 of root model reads
     174    IF ( m_world_rank == 0 )  THEN
     175
     176       CALL read_coupling_layout( nesting_datatransfer_mode, nesting_mode,     &
     177                                  pmc_status )
     178
     179       IF ( pmc_status /= pmc_no_namelist_found  .AND.                         &
     180            pmc_status /= pmc_namelist_error )                                 &
     181       THEN
     182!
     183!--       Calculate start PE of every model
     184          start_pe(1) = 0
     185          DO  i = 2, m_ncpl+1
     186             start_pe(i) = start_pe(i-1) + m_couplers(i-1)%npe_total
     187          ENDDO
     188
     189!
     190!--       The number of cores provided with the run must be the same as the
     191!--       total sum of cores required by all nest domains
     192          IF ( start_pe(m_ncpl+1) /= m_world_npes )  THEN
     193             WRITE ( message_string, '(A,I6,A,I6,A)' )                         &
     194                             'nesting-setup requires more MPI procs (',        &
     195                             start_pe(m_ncpl+1), ') than provided (',          &
     196                             m_world_npes,')'
     197             CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
     198          ENDIF
     199
     200       ENDIF
     201
     202    ENDIF
     203!
     204!-- Broadcast the read status. This synchronises all other PEs with PE 0 of
     205!-- the root model. Without synchronisation, they would not behave in the
     206!-- correct way (e.g. they would not return in case of a missing NAMELIST)
     207    CALL MPI_BCAST( pmc_status, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
     208
     209    IF ( pmc_status == pmc_no_namelist_found )  THEN
     210!
     211!--    Not a nested run; return the MPI_WORLD communicator
     212       comm = MPI_COMM_WORLD
     213       RETURN
     214
     215    ELSEIF ( pmc_status == pmc_namelist_error )  THEN
     216!
     217!--    Only the root model gives the error message. Others are aborted by the
     218!--    message-routine with MPI_ABORT. Must be done this way since myid and
     219!--    comm2d have not yet been assigned at this point.
     220       IF ( m_world_rank == 0 )  THEN
     221          message_string = 'errors in \$nestpar'
     222          CALL message( 'pmc_init_model', 'PA0223', 3, 2, 0, 6, 0 )
     223       ENDIF
     224
     225    ENDIF
     226
     227    CALL MPI_BCAST( m_ncpl,          1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
     228    CALL MPI_BCAST( start_pe, m_ncpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
     229
     230!
     231!-- Broadcast coupling layout
     232    DO  i = 1, m_ncpl
     233       CALL MPI_BCAST( m_couplers(i)%name, LEN( m_couplers(i)%name ),          &
     234                       MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
     235       CALL MPI_BCAST( m_couplers(i)%id,           1, MPI_INTEGER, 0,          &
     236                       MPI_COMM_WORLD, istat )
     237       CALL MPI_BCAST( m_couplers(i)%Parent_id,    1, MPI_INTEGER, 0,          &
     238                       MPI_COMM_WORLD, istat )
     239       CALL MPI_BCAST( m_couplers(i)%npe_total,    1, MPI_INTEGER, 0,          &
     240                       MPI_COMM_WORLD, istat )
     241       CALL MPI_BCAST( m_couplers(i)%lower_left_x, 1, MPI_REAL,    0,          &
     242                       MPI_COMM_WORLD, istat )
     243       CALL MPI_BCAST( m_couplers(i)%lower_left_y, 1, MPI_REAL,    0,          &
     244                       MPI_COMM_WORLD, istat )
     245    ENDDO
     246    CALL MPI_BCAST( nesting_mode, LEN( nesting_mode ), MPI_CHARACTER, 0,       &
     247                    MPI_COMM_WORLD, istat )
     248    CALL MPI_BCAST( nesting_datatransfer_mode, LEN(nesting_datatransfer_mode), &
     249                    MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
     250
     251!
     252!-- Assign global MPI processes to individual models by setting the couple id
     253    DO  i = 1, m_ncpl
     254       IF ( m_world_rank >= start_pe(i)  .AND.  m_world_rank < start_pe(i+1) ) &
     255       THEN
     256          m_my_cpl_id = i
     257          EXIT
     258       ENDIF
     259    ENDDO
     260    m_my_cpl_rank = m_world_rank - start_pe(i)
     261
     262!
     263!-- MPI_COMM_WORLD is the communicator for ALL models (MPI-1 approach).
     264!-- The communictors for the individual models as created by MPI_COMM_SPLIT.
     265!-- The color of the model is represented by the coupler id
     266    CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, m_my_cpl_id, m_my_cpl_rank, comm,     &
     267                         istat )
     268!
     269!-- Get size and rank of the model running on this PE
     270    CALL  MPI_COMM_RANK( comm, m_model_rank, istat )
     271    CALL  MPI_COMM_SIZE( comm, m_model_npes, istat )
     272
     273!
     274!-- Broadcast (from PE 0) the parent id and id of every model
     275    DO  i = 1, m_ncpl
     276       CALL MPI_BCAST( m_couplers(i)%parent_id, 1, MPI_INTEGER, 0,             &
     277                       MPI_COMM_WORLD, istat )
     278       CALL MPI_BCAST( m_couplers(i)%id,        1, MPI_INTEGER, 0,             &
     279                       MPI_COMM_WORLD, istat )
     280    ENDDO
     281
     282!
     283!-- Save the current model communicator for pmc internal use
     284    m_model_comm = comm
     285
     286!
     287!-- Create intercommunicator between server and clients.
     288!-- MPI_INTERCOMM_CREATE creates an intercommunicator between 2 groups of
     289!-- different colors.
     290!-- The grouping was done above with MPI_COMM_SPLIT
     291    DO  i = 2, m_ncpl
     292
     293       IF ( m_couplers(i)%parent_id == m_my_cpl_id )  THEN
     294!
     295!--       Collect server PEs.
     296!--       Every model exept the root model has a parent model which acts as
     297!--       server model. Create an intercommunicator to connect current PE to
     298!--       all client PEs
     299          tag = 500 + i
     300          CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD, start_pe(i),     &
     301                                     tag, m_to_client_comm(i), istat)
     302          clientcount = clientcount + 1
     303          activeserver(i) = 1
     304
     305       ELSEIF ( i == m_my_cpl_id)  THEN
     306!
     307!--       Collect client PEs.
     308!--       Every model exept the root model has a paremt model which acts as
     309!--       server model. Create an intercommunicator to connect current PE to
     310!--       all server PEs
     311          tag = 500 + i
     312          CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD,                  &
     313                                     start_pe(m_couplers(i)%parent_id),        &
     314                                     tag, m_to_server_comm, istat )
     315       ENDIF
     316
     317    ENDDO
     318
     319!
     320!-- If I am server, count the number of clients that I have
     321!-- Although this loop is symmetric on all processes, the "activeserver" flag
     322!-- is true (==1) on the respective individual PE only.
     323    ALLOCATE( pmc_server_for_client(clientcount+1) )
     324
     325    clientcount = 0
     326    DO  i = 2, m_ncpl
     327       IF ( activeserver(i) == 1 )  THEN
     328          clientcount = clientcount + 1
     329          pmc_server_for_client(clientcount) = i
     330       ENDIF
     331    ENDDO
     332!
     333!-- Get the size of the server model
     334    IF ( m_my_cpl_id > 1 )  THEN
     335       CALL MPI_COMM_REMOTE_SIZE( m_to_server_comm, m_server_remote_size,      &
     336                                  istat)
     337    ELSE
     338!
     339!--    The root model does not have a server
     340       m_server_remote_size = -1
     341    ENDIF
     342!
     343!-- Set myid to non-tero value except for the root domain. This is a setting
     344!-- for the message routine which is called at the end of pmci_init. That
     345!-- routine outputs messages for myid = 0, only. However, myid has not been
     346!-- assigened so far, so that all PEs of the root model would output a
     347!-- message. To avoid this, set myid to some other value except for PE0 of the
     348!-- root domain.
     349    IF ( m_world_rank /= 0 )  myid = 1
     350
     351 END SUBROUTINE PMC_init_model
     352
     353
     354
     355 SUBROUTINE pmc_get_model_info( comm_world_nesting, cpl_id, cpl_name,          &
     356                                cpl_parent_id, lower_left_x, lower_left_y,     &
     357                                ncpl, npe_total, request_for_cpl_id )
    350358!
    351359!-- Provide module private variables of the pmc for PALM
    352     SUBROUTINE pmc_get_model_info( comm_world_nesting, cpl_id, cpl_name,       &
    353                                    cpl_parent_id, lower_left_x, lower_left_y,  &
    354                                    ncpl, npe_total, request_for_cpl_id )
    355 
    356       USE kinds
    357 
    358       IMPLICIT NONE
    359 
    360       CHARACTER(LEN=*), INTENT(OUT), OPTIONAL ::  cpl_name
    361 
    362       INTEGER, INTENT(IN), OPTIONAL ::  request_for_cpl_id
    363 
    364       INTEGER, INTENT(OUT), OPTIONAL ::  comm_world_nesting
    365       INTEGER, INTENT(OUT), OPTIONAL ::  cpl_id
    366       INTEGER, INTENT(OUT), OPTIONAL ::  cpl_parent_id
    367       INTEGER, INTENT(OUT), OPTIONAL ::  ncpl
    368       INTEGER, INTENT(OUT), OPTIONAL ::  npe_total
    369 
    370       INTEGER ::  requested_cpl_id
    371 
    372       REAL(wp), INTENT(OUT), OPTIONAL ::  lower_left_x
    373       REAL(wp), INTENT(OUT), OPTIONAL ::  lower_left_y
    374 
    375 !
    376 !--   Set the requested coupler id
    377       IF ( PRESENT( request_for_cpl_id ) )  THEN
    378          requested_cpl_id = request_for_cpl_id
    379 !
    380 !--      Check for allowed range of values
    381          IF ( requested_cpl_id < 1 .OR. requested_cpl_id > m_ncpl )  RETURN
    382       ELSE
    383          requested_cpl_id = m_my_cpl_id
    384       ENDIF
    385 
    386 !
    387 !--   Return the requested information
    388       IF ( PRESENT( comm_world_nesting )  )  THEN
    389          comm_world_nesting = m_world_comm
    390       ENDIF
    391       IF ( PRESENT( cpl_id )        )  THEN
    392          cpl_id = requested_cpl_id
    393       ENDIF
    394       IF ( PRESENT( cpl_parent_id ) )  THEN
    395          cpl_parent_id = m_couplers(requested_cpl_id)%parent_id
    396       ENDIF
    397       IF ( PRESENT( cpl_name )      )  THEN
    398          cpl_name = m_couplers(requested_cpl_id)%name
    399       ENDIF
    400       IF ( PRESENT( ncpl )          )  THEN
    401          ncpl = m_ncpl
    402       ENDIF
    403       IF ( PRESENT( npe_total )     )  THEN
    404          npe_total = m_couplers(requested_cpl_id)%npe_total
    405       ENDIF
    406       IF ( PRESENT( lower_left_x )  )  THEN
    407          lower_left_x = m_couplers(requested_cpl_id)%lower_left_x
    408       ENDIF
    409       IF ( PRESENT( lower_left_y )  )  THEN
    410          lower_left_y = m_couplers(requested_cpl_id)%lower_left_y
    411       ENDIF
    412 
    413    END SUBROUTINE pmc_get_model_info
    414 
    415 
    416 
    417    LOGICAL function pmc_is_rootmodel( )
    418 
    419       IMPLICIT NONE
    420 
    421       pmc_is_rootmodel = ( m_my_cpl_id == 1 )
    422 
    423    END FUNCTION pmc_is_rootmodel
     360
     361    USE kinds
     362
     363    IMPLICIT NONE
     364
     365    CHARACTER(LEN=*), INTENT(OUT), OPTIONAL ::  cpl_name  !<
     366
     367    INTEGER, INTENT(IN), OPTIONAL ::  request_for_cpl_id  !<
     368
     369    INTEGER, INTENT(OUT), OPTIONAL ::  comm_world_nesting  !<
     370    INTEGER, INTENT(OUT), OPTIONAL ::  cpl_id              !<
     371    INTEGER, INTENT(OUT), OPTIONAL ::  cpl_parent_id       !<
     372    INTEGER, INTENT(OUT), OPTIONAL ::  ncpl                !<
     373    INTEGER, INTENT(OUT), OPTIONAL ::  npe_total           !<
     374
     375    INTEGER ::  requested_cpl_id  !<
     376
     377    REAL(wp), INTENT(OUT), OPTIONAL ::  lower_left_x  !<
     378    REAL(wp), INTENT(OUT), OPTIONAL ::  lower_left_y  !<
     379
     380!
     381!-- Set the requested coupler id
     382    IF ( PRESENT( request_for_cpl_id ) )  THEN
     383       requested_cpl_id = request_for_cpl_id
     384!
     385!--    Check for allowed range of values
     386       IF ( requested_cpl_id < 1  .OR.  requested_cpl_id > m_ncpl )  RETURN
     387    ELSE
     388       requested_cpl_id = m_my_cpl_id
     389    ENDIF
     390
     391!
     392!-- Return the requested information
     393    IF ( PRESENT( comm_world_nesting )  )  THEN
     394       comm_world_nesting = m_world_comm
     395    ENDIF
     396    IF ( PRESENT( cpl_id )        )  THEN
     397       cpl_id = requested_cpl_id
     398    ENDIF
     399    IF ( PRESENT( cpl_parent_id ) )  THEN
     400       cpl_parent_id = m_couplers(requested_cpl_id)%parent_id
     401    ENDIF
     402    IF ( PRESENT( cpl_name )      )  THEN
     403       cpl_name = m_couplers(requested_cpl_id)%name
     404    ENDIF
     405    IF ( PRESENT( ncpl )          )  THEN
     406       ncpl = m_ncpl
     407    ENDIF
     408    IF ( PRESENT( npe_total )     )  THEN
     409       npe_total = m_couplers(requested_cpl_id)%npe_total
     410    ENDIF
     411    IF ( PRESENT( lower_left_x )  )  THEN
     412       lower_left_x = m_couplers(requested_cpl_id)%lower_left_x
     413    ENDIF
     414    IF ( PRESENT( lower_left_y )  )  THEN
     415       lower_left_y = m_couplers(requested_cpl_id)%lower_left_y
     416    ENDIF
     417
     418 END SUBROUTINE pmc_get_model_info
     419
     420
     421
     422 LOGICAL function pmc_is_rootmodel( )
     423
     424    IMPLICIT NONE
     425
     426    pmc_is_rootmodel = ( m_my_cpl_id == 1 )
     427
     428 END FUNCTION pmc_is_rootmodel
    424429
    425430
     
    436441    INTEGER                ::  i, istat
    437442
    438     TYPE(pmc_layout), DIMENSION(pmc_max_modell) ::  domain_layouts
     443    TYPE(pmc_layout), DIMENSION(pmc_max_models) ::  domain_layouts
    439444
    440445!-- TO_DO: include anterp_relax_length_? into nestpar and communicate them.
     
    443448!
    444449!-- Initialize some coupling variables
    445     domain_layouts(1:pmc_max_modell)%id = -1
     450    domain_layouts(1:pmc_max_models)%id = -1
    446451    m_ncpl =   0
    447452
     
    480485!
    481486!-- Get the number of nested models given in the nestpar-NAMELIST
    482     DO  i = 1, pmc_max_modell
     487    DO  i = 1, pmc_max_models
    483488!
    484489!--    When id=-1 is found for the first time, the list of domains is finished
    485        IF ( m_couplers(i)%id == -1  .OR.  i == pmc_max_modell )  THEN
     490       IF ( m_couplers(i)%id == -1  .OR.  i == pmc_max_models )  THEN
    486491          IF ( m_couplers(i)%id == -1 )  THEN
    487492             m_ncpl = i - 1
    488493             EXIT
    489494          ELSE
    490              m_ncpl = pmc_max_modell
     495             m_ncpl = pmc_max_models
    491496          ENDIF
    492497       ENDIF
Note: See TracChangeset for help on using the changeset viewer.