Ignore:
Timestamp:
Jun 13, 2016 7:12:51 AM (5 years ago)
Author:
hellstea
Message:

last commit documented

File:
1 edited

Legend:

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

    r1925 r1933  
    11 MODULE PMC_handle_communicator
    22
    3 !--------------------------------------------------------------------------------!
     3!-------------------------------------------------------------------------------!
    44! This file is part of PALM.
    55!
     
    1616!
    1717! Copyright 1997-2016 Leibniz Universitaet Hannover
    18 !--------------------------------------------------------------------------------!
     18!-------------------------------------------------------------------------------!
    1919!
    2020! Current revisions:
    2121! ------------------
    2222!
    23 !
     23! 
    2424! Former revisions:
    2525! -----------------
    2626! $Id$
     27!
     28! 1901 2016-05-04 15:39:38Z raasch
     29! Initial version of purely vertical nesting introduced.
     30! Code clean up. The words server/client changed to parent/child.
    2731!
    2832! 1900 2016-05-04 15:27:53Z raasch
     
    7074! ------------
    7175! Handle MPI communicator in PALM model coupler
    72 !------------------------------------------------------------------------------!
     76!-------------------------------------------------------------------------------!
    7377
    7478#if defined( __parallel )
     
    8185#endif
    8286
    83     USE pmc_general,                                                           &
     87    USE pmc_general,                                                            &
    8488        ONLY: pmc_status_ok, pmc_status_error, pmc_max_models
     89    USE control_parameters,                                                     &
     90        ONLY: message_string
    8591
    8692    IMPLICIT NONE
     
    113119
    114120    INTEGER, PUBLIC ::  m_model_comm          !< communicator of this model
    115     INTEGER, PUBLIC ::  m_to_server_comm      !< communicator to the server
     121    INTEGER, PUBLIC ::  m_to_parent_comm      !< communicator to the parent
    116122    INTEGER, PUBLIC ::  m_world_rank          !<
    117123    INTEGER         ::  m_world_npes          !<
    118124    INTEGER, PUBLIC ::  m_model_rank          !<
    119125    INTEGER, PUBLIC ::  m_model_npes          !<
    120     INTEGER         ::  m_server_remote_size  !< number of server PEs
    121 
    122     INTEGER, DIMENSION(pmc_max_models), PUBLIC ::  m_to_client_comm   !< communicator to the client(s)
    123     INTEGER, DIMENSION(:), POINTER, PUBLIC ::  pmc_server_for_client  !<
     126    INTEGER         ::  m_parent_remote_size  !< number of parent PEs
     127
     128    INTEGER, DIMENSION(pmc_max_models), PUBLIC ::  m_to_child_comm    !< communicator to the child(ren)
     129    INTEGER, DIMENSION(:), POINTER, PUBLIC ::  pmc_parent_for_child   !<
    124130
    125131
     
    136142 CONTAINS
    137143
    138  SUBROUTINE pmc_init_model( comm, nesting_datatransfer_mode, nesting_mode,     &
     144 SUBROUTINE pmc_init_model( comm, nesting_datatransfer_mode, nesting_mode,      &
    139145                              pmc_status )
    140146
    141     USE control_parameters,                                                    &
     147    USE control_parameters,                                                     &
    142148        ONLY:  message_string
    143149
    144     USE pegrid,                                                                &
     150    USE pegrid,                                                                 &
    145151        ONLY:  myid
    146152
    147153      IMPLICIT NONE
    148154
    149     CHARACTER(LEN=7), INTENT(OUT) ::  nesting_mode               !<
     155    CHARACTER(LEN=8), INTENT(OUT) ::  nesting_mode               !<
    150156    CHARACTER(LEN=7), INTENT(OUT) ::  nesting_datatransfer_mode  !<
    151157
     
    153159    INTEGER, INTENT(OUT) ::  pmc_status  !<
    154160
    155     INTEGER ::  clientcount    !<
     161    INTEGER ::  childcount     !<
    156162    INTEGER ::  i              !<
    157163    INTEGER ::  ierr           !<
     
    160166    INTEGER ::  tag            !<
    161167
    162     INTEGER, DIMENSION(pmc_max_models)   ::  activeserver  ! I am active server for this client ID
     168    INTEGER, DIMENSION(pmc_max_models)   ::  activeparent  ! I am active parent for this child ID
    163169    INTEGER, DIMENSION(pmc_max_models+1) ::  start_pe
    164170
     
    167173    m_world_comm = MPI_COMM_WORLD
    168174    m_my_cpl_id  = -1
    169     clientcount  =  0
    170     activeserver = -1
     175    childcount   =  0
     176    activeparent = -1
    171177    start_pe(:)  =  0
    172178
     
    177183    IF ( m_world_rank == 0 )  THEN
    178184
    179        CALL read_coupling_layout( nesting_datatransfer_mode, nesting_mode,     &
     185       CALL read_coupling_layout( nesting_datatransfer_mode, nesting_mode,      &
    180186                                  pmc_status )
    181187
    182        IF ( pmc_status /= pmc_no_namelist_found  .AND.                         &
    183             pmc_status /= pmc_namelist_error )                                 &
     188       IF ( pmc_status /= pmc_no_namelist_found  .AND.                          &
     189            pmc_status /= pmc_namelist_error )                                  &
    184190       THEN
    185191!
     
    194200!--       total sum of cores required by all nest domains
    195201          IF ( start_pe(m_ncpl+1) /= m_world_npes )  THEN
    196              WRITE ( message_string, '(A,I6,A,I6,A)' )                         &
    197                              'nesting-setup requires more MPI procs (',        &
    198                              start_pe(m_ncpl+1), ') than provided (',          &
    199                              m_world_npes,')'
     202             WRITE ( message_string, '(A,I6,A,I6,A)' )                          &
     203                             'nesting-setup requires different number of ',     &
     204                             'MPI procs (', start_pe(m_ncpl+1), ') than ',      &
     205                             'provided (', m_world_npes,')'
    200206             CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
    201207          ENDIF
     
    234240!-- Broadcast coupling layout
    235241    DO  i = 1, m_ncpl
    236        CALL MPI_BCAST( m_couplers(i)%name, LEN( m_couplers(i)%name ),          &
     242       CALL MPI_BCAST( m_couplers(i)%name, LEN( m_couplers(i)%name ),           &
    237243                       MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
    238        CALL MPI_BCAST( m_couplers(i)%id,           1, MPI_INTEGER, 0,          &
    239                        MPI_COMM_WORLD, istat )
    240        CALL MPI_BCAST( m_couplers(i)%Parent_id,    1, MPI_INTEGER, 0,          &
    241                        MPI_COMM_WORLD, istat )
    242        CALL MPI_BCAST( m_couplers(i)%npe_total,    1, MPI_INTEGER, 0,          &
    243                        MPI_COMM_WORLD, istat )
    244        CALL MPI_BCAST( m_couplers(i)%lower_left_x, 1, MPI_REAL,    0,          &
    245                        MPI_COMM_WORLD, istat )
    246        CALL MPI_BCAST( m_couplers(i)%lower_left_y, 1, MPI_REAL,    0,          &
     244       CALL MPI_BCAST( m_couplers(i)%id,           1, MPI_INTEGER, 0,           &
     245                       MPI_COMM_WORLD, istat )
     246       CALL MPI_BCAST( m_couplers(i)%Parent_id,    1, MPI_INTEGER, 0,           &
     247                       MPI_COMM_WORLD, istat )
     248       CALL MPI_BCAST( m_couplers(i)%npe_total,    1, MPI_INTEGER, 0,           &
     249                       MPI_COMM_WORLD, istat )
     250       CALL MPI_BCAST( m_couplers(i)%lower_left_x, 1, MPI_REAL,    0,           &
     251                       MPI_COMM_WORLD, istat )
     252       CALL MPI_BCAST( m_couplers(i)%lower_left_y, 1, MPI_REAL,    0,           &
    247253                       MPI_COMM_WORLD, istat )
    248254    ENDDO
    249     CALL MPI_BCAST( nesting_mode, LEN( nesting_mode ), MPI_CHARACTER, 0,       &
     255    CALL MPI_BCAST( nesting_mode, LEN( nesting_mode ), MPI_CHARACTER, 0,        &
    250256                    MPI_COMM_WORLD, istat )
    251     CALL MPI_BCAST( nesting_datatransfer_mode, LEN(nesting_datatransfer_mode), &
     257    CALL MPI_BCAST( nesting_datatransfer_mode, LEN(nesting_datatransfer_mode),  &
    252258                    MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
    253259
     
    255261!-- Assign global MPI processes to individual models by setting the couple id
    256262    DO  i = 1, m_ncpl
    257        IF ( m_world_rank >= start_pe(i)  .AND.  m_world_rank < start_pe(i+1) ) &
     263       IF ( m_world_rank >= start_pe(i)  .AND.  m_world_rank < start_pe(i+1) )  &
    258264       THEN
    259265          m_my_cpl_id = i
     
    267273!-- The communictors for the individual models as created by MPI_COMM_SPLIT.
    268274!-- The color of the model is represented by the coupler id
    269     CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, m_my_cpl_id, m_my_cpl_rank, comm,     &
     275    CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, m_my_cpl_id, m_my_cpl_rank, comm,      &
    270276                         istat )
    271277!
     
    277283!-- Broadcast (from PE 0) the parent id and id of every model
    278284    DO  i = 1, m_ncpl
    279        CALL MPI_BCAST( m_couplers(i)%parent_id, 1, MPI_INTEGER, 0,             &
    280                        MPI_COMM_WORLD, istat )
    281        CALL MPI_BCAST( m_couplers(i)%id,        1, MPI_INTEGER, 0,             &
     285       CALL MPI_BCAST( m_couplers(i)%parent_id, 1, MPI_INTEGER, 0,              &
     286                       MPI_COMM_WORLD, istat )
     287       CALL MPI_BCAST( m_couplers(i)%id,        1, MPI_INTEGER, 0,              &
    282288                       MPI_COMM_WORLD, istat )
    283289    ENDDO
     
    288294
    289295!
    290 !-- Create intercommunicator between server and clients.
     296!-- Create intercommunicator between parent and children.
    291297!-- MPI_INTERCOMM_CREATE creates an intercommunicator between 2 groups of
    292298!-- different colors.
     
    296302       IF ( m_couplers(i)%parent_id == m_my_cpl_id )  THEN
    297303!
    298 !--       Collect server PEs.
     304!--       Collect parent PEs.
    299305!--       Every model exept the root model has a parent model which acts as
    300 !--       server model. Create an intercommunicator to connect current PE to
    301 !--       all client PEs
     306!--       parent model. Create an intercommunicator to connect current PE to
     307!--       all children PEs
    302308          tag = 500 + i
    303           CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD, start_pe(i),     &
    304                                      tag, m_to_client_comm(i), istat)
    305           clientcount = clientcount + 1
    306           activeserver(i) = 1
     309          CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD, start_pe(i),      &
     310                                     tag, m_to_child_comm(i), istat)
     311          childcount = childcount + 1
     312          activeparent(i) = 1
    307313
    308314       ELSEIF ( i == m_my_cpl_id)  THEN
    309315!
    310 !--       Collect client PEs.
    311 !--       Every model exept the root model has a paremt model which acts as
    312 !--       server model. Create an intercommunicator to connect current PE to
    313 !--       all server PEs
     316!--       Collect children PEs.
     317!--       Every model except the root model has a parent model.
     318!--       Create an intercommunicator to connect current PE to all parent PEs
    314319          tag = 500 + i
    315           CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD,                  &
    316                                      start_pe(m_couplers(i)%parent_id),        &
    317                                      tag, m_to_server_comm, istat )
     320          CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD,                   &
     321                                     start_pe(m_couplers(i)%parent_id),         &
     322                                     tag, m_to_parent_comm, istat )
    318323       ENDIF
    319324
     
    321326
    322327!
    323 !-- If I am server, count the number of clients that I have
    324 !-- Although this loop is symmetric on all processes, the "activeserver" flag
     328!-- If I am parent, count the number of children that I have
     329!-- Although this loop is symmetric on all processes, the "activeparent" flag
    325330!-- is true (==1) on the respective individual PE only.
    326     ALLOCATE( pmc_server_for_client(clientcount+1) )
    327 
    328     clientcount = 0
     331    ALLOCATE( pmc_parent_for_child(childcount+1) )
     332
     333    childcount = 0
    329334    DO  i = 2, m_ncpl
    330        IF ( activeserver(i) == 1 )  THEN
    331           clientcount = clientcount + 1
    332           pmc_server_for_client(clientcount) = i
     335       IF ( activeparent(i) == 1 )  THEN
     336          childcount = childcount + 1
     337          pmc_parent_for_child(childcount) = i
    333338       ENDIF
    334339    ENDDO
    335340!
    336 !-- Get the size of the server model
     341!-- Get the size of the parent model
    337342    IF ( m_my_cpl_id > 1 )  THEN
    338        CALL MPI_COMM_REMOTE_SIZE( m_to_server_comm, m_server_remote_size,      &
     343       CALL MPI_COMM_REMOTE_SIZE( m_to_parent_comm, m_parent_remote_size,       &
    339344                                  istat)
    340345    ELSE
    341346!
    342 !--    The root model does not have a server
    343        m_server_remote_size = -1
     347!--    The root model does not have a parent
     348       m_parent_remote_size = -1
    344349    ENDIF
    345350!
     
    356361
    357362
    358  SUBROUTINE pmc_get_model_info( comm_world_nesting, cpl_id, cpl_name,          &
    359                                 cpl_parent_id, lower_left_x, lower_left_y,     &
     363 SUBROUTINE pmc_get_model_info( comm_world_nesting, cpl_id, cpl_name,           &
     364                                cpl_parent_id, lower_left_x, lower_left_y,      &
    360365                                ncpl, npe_total, request_for_cpl_id )
    361366!
     
    366371    IMPLICIT NONE
    367372
    368     CHARACTER(LEN=*), INTENT(OUT), OPTIONAL ::  cpl_name  !<
    369 
    370     INTEGER, INTENT(IN), OPTIONAL ::  request_for_cpl_id  !<
     373    CHARACTER(LEN=*), INTENT(OUT), OPTIONAL ::  cpl_name   !<
     374
     375    INTEGER, INTENT(IN), OPTIONAL ::  request_for_cpl_id   !<
    371376
    372377    INTEGER, INTENT(OUT), OPTIONAL ::  comm_world_nesting  !<
     
    433438
    434439
    435  SUBROUTINE read_coupling_layout( nesting_datatransfer_mode, nesting_mode,     &
     440 SUBROUTINE read_coupling_layout( nesting_datatransfer_mode, nesting_mode,      &
    436441                                  pmc_status )
    437442
    438443    IMPLICIT NONE
    439444
    440     CHARACTER(LEN=7), INTENT(INOUT) ::  nesting_mode
     445    CHARACTER(LEN=8), INTENT(INOUT) ::  nesting_mode
    441446    CHARACTER(LEN=7), INTENT(INOUT) ::  nesting_datatransfer_mode
    442447
    443     INTEGER, INTENT(INOUT) ::  pmc_status
    444     INTEGER                ::  i, istat
     448    INTEGER(iwp), INTENT(INOUT) ::  pmc_status
     449    INTEGER(iwp)                ::  bad_llcorner
     450    INTEGER(iwp)                ::  i
     451    INTEGER(iwp)                ::  istat
    445452
    446453    TYPE(pmc_layout), DIMENSION(pmc_max_models) ::  domain_layouts
     
    461468
    462469    IF ( istat < 0 )  THEN
     470
    463471!
    464472!--    No nestpar-NAMELIST found
    465473       pmc_status = pmc_no_namelist_found
     474
    466475!
    467476!--    Set filepointer to the beginning of the file. Otherwise PE0 will later
     
    471480
    472481    ELSEIF ( istat > 0 )  THEN
     482
    473483!
    474484!--    Errors in reading nestpar-NAMELIST
     
    481491!-- Output location message
    482492    CALL location_message( 'initialize communicators for nesting', .FALSE. )
     493
    483494!
    484495!-- Assign the layout to the internally used variable
     
    490501!
    491502!--    When id=-1 is found for the first time, the list of domains is finished
    492        IF ( m_couplers(i)%id == -1  .OR.  i == pmc_max_models )  THEN
     503        IF ( m_couplers(i)%id == -1  .OR.  i == pmc_max_models )  THEN
    493504          IF ( m_couplers(i)%id == -1 )  THEN
    494505             m_ncpl = i - 1
     
    501512    ENDDO
    502513
     514!
     515!-- Make sure that all domains have equal lower left corner in case of vertical
     516!-- nesting
     517    IF ( nesting_mode == 'vertical' )  THEN
     518       bad_llcorner = 0
     519       DO  i = 1, m_ncpl
     520          IF ( domain_layouts(i)%lower_left_x /= 0.0_wp .OR.                    &
     521               domain_layouts(i)%lower_left_y /= 0.0_wp )  THEN
     522             bad_llcorner = bad_llcorner + 1
     523             domain_layouts(i)%lower_left_x = 0.0_wp
     524             domain_layouts(i)%lower_left_y = 0.0_wp
     525          ENDIF
     526       ENDDO
     527       IF ( bad_llcorner /= 0)  THEN
     528          WRITE ( message_string, *)  'Lower left corners do not match,',       &
     529                                      'they were set to (0, 0)'
     530          CALL message( 'read_coupling_layout', 'PA0427', 0, 0, 0, 6, 0 )
     531       ENDIF
     532    ENDIF
     533
    503534 END SUBROUTINE read_coupling_layout
    504535
Note: See TracChangeset for help on using the changeset viewer.