Home


About us
PALM
PALM-4U
Installation
Release notes
Documentation
Getting Help
Gallery
Developers area

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

last commit documented

File:
1 moved

Legend:

Unmodified
Added
Removed

  • palm/trunk/SOURCE/pmc_parent_mod.f90

    r1927 r1933  
    1  MODULE pmc_server
    2 
    3 !--------------------------------------------------------------------------------!
     1 MODULE pmc_parent
     2
     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! Module renamed. Code clean up. The words server/client changed to parent/child.
    2730!
    2831! 1900 2016-05-04 15:27:53Z raasch
    … …  
    4750!
    4851! 1786 2016-03-08 05:49:27Z raasch
    49 ! change in client-server data transfer: server now gets data from client
    50 ! instead that client put's it to the server
     52! change in child-parent data transfer: parent now gets data from child
     53! instead that child put's it to the parent
    5154!
    5255! 1779 2016-03-03 08:01:28Z raasch
    … …  
    6871! ------------
    6972!
    70 ! Server part of Palm Model Coupler
    71 !------------------------------------------------------------------------------!
     73! Parent part of Palm Model Coupler
     74!-------------------------------------------------------------------------------!
    7275
    7376#if defined( __parallel )
    … …  
    8083#endif
    8184    USE kinds
    82     USE pmc_general,                                                           &
    83         ONLY: arraydef, clientdef, da_namedef, da_namelen, pedef,              &
     85    USE pmc_general,                                                            &
     86        ONLY: arraydef, childdef, da_namedef, da_namelen, pedef,                &
    8487              pmc_g_setname, pmc_max_array, pmc_max_models, pmc_sort
    8588
    86     USE pmc_handle_communicator,                                               &
    87         ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm,        &
    88               m_world_rank, pmc_server_for_client
    89 
    90     USE pmc_mpi_wrapper,                                                       &
     89    USE pmc_handle_communicator,                                                &
     90        ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_child_comm,          &
     91              m_world_rank, pmc_parent_for_child
     92
     93    USE pmc_mpi_wrapper,                                                        &
    9194        ONLY: pmc_alloc_mem, pmc_bcast, pmc_time
    9295
    … …  
    9699   SAVE
    97100
    98    TYPE clientindexdef
     101   TYPE childindexdef
    99102      INTEGER                              ::  nrpoints       !<
    100103      INTEGER, DIMENSION(:,:), ALLOCATABLE ::  index_list_2d  !<
    101    END TYPE clientindexdef
    102 
    103    TYPE(clientdef), DIMENSION(pmc_max_models)      ::  clients     !<
    104    TYPE(clientindexdef), DIMENSION(pmc_max_models) ::  indclients  !<
     104   END TYPE childindexdef
     105
     106   TYPE(childdef), DIMENSION(pmc_max_models)       ::  children     !<
     107   TYPE(childindexdef), DIMENSION(pmc_max_models)  ::  indchildren  !<
    105108
    106109   INTEGER ::  next_array_in_list = 0  !<
    107110
    108111
    109    PUBLIC pmc_server_for_client
    110 
    111 
    112    INTERFACE pmc_serverinit
    113       MODULE PROCEDURE  pmc_serverinit
    114    END INTERFACE pmc_serverinit
     112   PUBLIC pmc_parent_for_child
     113
     114
     115   INTERFACE pmc_parentinit
     116      MODULE PROCEDURE  pmc_parentinit
     117   END INTERFACE pmc_parentinit
    115118
    116119    INTERFACE pmc_s_set_2d_index_list
    … …  
    147150    END INTERFACE pmc_s_set_active_data_array
    148151
    149     PUBLIC pmc_serverinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer,      &
    150            pmc_s_getdata_from_buffer, pmc_s_getnextarray,                      &
    151            pmc_s_setind_and_allocmem, pmc_s_set_active_data_array,             &
     152    PUBLIC pmc_parentinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer,       &
     153           pmc_s_getdata_from_buffer, pmc_s_getnextarray,                       &
     154           pmc_s_setind_and_allocmem, pmc_s_set_active_data_array,              &
    152155           pmc_s_set_dataarray, pmc_s_set_2d_index_list
    153156
    … …  
    155158
    156159
    157  SUBROUTINE pmc_serverinit
     160 SUBROUTINE pmc_parentinit
    158161
    159162    IMPLICIT NONE
    160163
    161     INTEGER ::  clientid  !<
     164    INTEGER ::  childid   !<
    162165    INTEGER ::  i         !<
    163166    INTEGER ::  j         !<
    … …  
    165168
    166169
    167     DO  i = 1, SIZE( pmc_server_for_client )-1
    168 
    169        clientid = pmc_server_for_client( i )
    170 
    171        clients(clientid)%model_comm = m_model_comm
    172        clients(clientid)%inter_comm = m_to_client_comm(clientid)
     170    DO  i = 1, SIZE( pmc_parent_for_child )-1
     171
     172       childid = pmc_parent_for_child( i )
     173
     174       children(childid)%model_comm = m_model_comm
     175       children(childid)%inter_comm = m_to_child_comm(childid)
     176
    173177!
    174178!--    Get rank and size
    175        CALL MPI_COMM_RANK( clients(clientid)%model_comm,                       &
    176                            clients(clientid)%model_rank, istat )
    177        CALL MPI_COMM_SIZE( clients(clientid)%model_comm,                       &
    178                            clients(clientid)%model_npes, istat )
    179        CALL MPI_COMM_REMOTE_SIZE( clients(clientid)%inter_comm,                &
    180                                   clients(clientid)%inter_npes, istat )
     179       CALL MPI_COMM_RANK( children(childid)%model_comm,                        &
     180                           children(childid)%model_rank, istat )
     181       CALL MPI_COMM_SIZE( children(childid)%model_comm,                        &
     182                           children(childid)%model_npes, istat )
     183       CALL MPI_COMM_REMOTE_SIZE( children(childid)%inter_comm,                 &
     184                                  children(childid)%inter_npes, istat )
     185
    181186!
    182187!--    Intra communicater is used for MPI_GET
    183        CALL MPI_INTERCOMM_MERGE( clients(clientid)%inter_comm, .FALSE.,        &
    184                                  clients(clientid)%intra_comm, istat )
    185        CALL MPI_COMM_RANK( clients(clientid)%intra_comm,                       &
    186                            clients(clientid)%intra_rank, istat )
    187 
    188        ALLOCATE( clients(clientid)%pes(clients(clientid)%inter_npes))
    189 !
    190 !--    Allocate array of TYPE arraydef for all client PEs to store information
     188       CALL MPI_INTERCOMM_MERGE( children(childid)%inter_comm, .FALSE.,         &
     189                                 children(childid)%intra_comm, istat )
     190       CALL MPI_COMM_RANK( children(childid)%intra_comm,                        &
     191                           children(childid)%intra_rank, istat )
     192
     193       ALLOCATE( children(childid)%pes(children(childid)%inter_npes))
     194
     195!
     196!--    Allocate array of TYPE arraydef for all child PEs to store information
    191197!--    of the transfer array
    192        DO  j = 1, clients(clientid)%inter_npes
    193          ALLOCATE( clients(clientid)%pes(j)%array_list(pmc_max_array) )
     198       DO  j = 1, children(childid)%inter_npes
     199         ALLOCATE( children(childid)%pes(j)%array_list(pmc_max_array) )
    194200       ENDDO
    195201
    196        CALL get_da_names_from_client (clientid)
    197 
    198     ENDDO
    199 
    200  END SUBROUTINE pmc_serverinit
    201 
    202 
    203 
    204  SUBROUTINE pmc_s_set_2d_index_list( clientid, index_list )
     202       CALL get_da_names_from_child (childid)
     203
     204    ENDDO
     205
     206 END SUBROUTINE pmc_parentinit
     207
     208
     209
     210 SUBROUTINE pmc_s_set_2d_index_list( childid, index_list )
    205211
    206212     IMPLICIT NONE
    207213
    208      INTEGER, INTENT(IN)                    :: clientid    !<
     214     INTEGER, INTENT(IN)                    :: childid     !<
    209215     INTEGER, DIMENSION(:,:), INTENT(INOUT) :: index_list  !<
    210216
    … …  
    219225
    220226     IF ( m_model_rank == 0 )  THEN
    221 !
    222 !--     Sort to ascending server PE
     227
     228!
     229!--     Sort to ascending parent PE order
    223230        CALL pmc_sort( index_list, 6 )
    224231
    225232        is = 1
    226233        DO  ip = 0, m_model_npes-1
    227 !
    228 !--        Split into server PEs
     234
     235!
     236!--        Split into parent PEs
    229237           ie = is - 1
     238
    230239!
    231240!--        There may be no entry for this PE
    … …  
    244253              ian =  0
    245254           ENDIF
    246 !
    247 !--        Send data to other server PEs
     255
     256!
     257!--        Send data to other parent PEs
    248258           IF ( ip == 0 )  THEN
    249               indclients(clientid)%nrpoints = ian
     259              indchildren(childid)%nrpoints = ian
    250260              IF ( ian > 0)  THEN
    251                   ALLOCATE( indclients(clientid)%index_list_2d(6,ian) )
    252                   indclients(clientid)%index_list_2d(:,1:ian) =                &
     261                  ALLOCATE( indchildren(childid)%index_list_2d(6,ian) )
     262                  indchildren(childid)%index_list_2d(:,1:ian) =                 &
    253263                                                             index_list(:,is:ie)
    254264              ENDIF
    255265           ELSE
    256               CALL MPI_SEND( ian, 1, MPI_INTEGER, ip, 1000, m_model_comm,      &
     266              CALL MPI_SEND( ian, 1, MPI_INTEGER, ip, 1000, m_model_comm,       &
    257267                             istat )
    258268              IF ( ian > 0)  THEN
    259                   CALL MPI_SEND( index_list(1,is), 6*ian, MPI_INTEGER, ip,  &
     269                  CALL MPI_SEND( index_list(1,is), 6*ian, MPI_INTEGER, ip,      &
    260270                                 1001, m_model_comm, istat )
    261271              ENDIF
    … …  
    267277     ELSE
    268278
    269         CALL MPI_RECV( indclients(clientid)%nrpoints, 1, MPI_INTEGER, 0, 1000, &
     279        CALL MPI_RECV( indchildren(childid)%nrpoints, 1, MPI_INTEGER, 0, 1000, &
    270280                       m_model_comm, MPI_STATUS_IGNORE, istat )
    271         ian = indclients(clientid)%nrpoints
     281        ian = indchildren(childid)%nrpoints
    272282
    273283        IF ( ian > 0 )  THEN
    274            ALLOCATE( indclients(clientid)%index_list_2d(6,ian) )
    275            CALL MPI_RECV( indclients(clientid)%index_list_2d, 6*ian,           &
    276                           MPI_INTEGER, 0, 1001, m_model_comm,                  &
     284           ALLOCATE( indchildren(childid)%index_list_2d(6,ian) )
     285           CALL MPI_RECV( indchildren(childid)%index_list_2d, 6*ian,            &
     286                          MPI_INTEGER, 0, 1001, m_model_comm,                   &
    277287                          MPI_STATUS_IGNORE, istat)
    278288        ENDIF
    … …  
    280290     ENDIF
    281291
    282      CALL set_pe_index_list( clientid, clients(clientid),                      &
    283                              indclients(clientid)%index_list_2d,               &
    284                              indclients(clientid)%nrpoints )
     292     CALL set_pe_index_list( childid, children(childid),                        &
     293                             indchildren(childid)%index_list_2d,                &
     294                             indchildren(childid)%nrpoints )
    285295
    286296 END SUBROUTINE pmc_s_set_2d_index_list
    … …  
    298308
    299309
    300  LOGICAL FUNCTION pmc_s_getnextarray( clientid, myname )
     310 LOGICAL FUNCTION pmc_s_getnextarray( childid, myname )
     311
    301312!
    302313!-- List handling is still required to get minimal interaction with
    … …  
    304315!-- TODO: what does "still" mean? Is there a chance to change this!
    305316    CHARACTER(LEN=*), INTENT(OUT) ::  myname    !<
    306     INTEGER(iwp), INTENT(IN)      ::  clientid  !<
     317    INTEGER(iwp), INTENT(IN)      ::  childid   !<
    307318
    308319    TYPE(arraydef), POINTER :: ar
    … …  
    310321
    311322    next_array_in_list = next_array_in_list + 1
    312 !
    313 !-- Array names are the same on all client PEs, so take first PE to get the name
    314     ape => clients(clientid)%pes(1)
     323
     324!
     325!-- Array names are the same on all children PEs, so take first PE to get the name
     326    ape => children(childid)%pes(1)
    315327
    316328    IF ( next_array_in_list > ape%nr_arrays )  THEN
     329
    317330!
    318331!--    All arrays are done
    … …  
    323336    ar => ape%array_list(next_array_in_list)
    324337    myname = ar%name
     338
    325339!
    326340!-- Return true if legal array
    … …  
    332346
    333347
    334  SUBROUTINE pmc_s_set_dataarray_2d( clientid, array, array_2 )
     348 SUBROUTINE pmc_s_set_dataarray_2d( childid, array, array_2 )
    335349
    336350    IMPLICIT NONE
    337351
    338     INTEGER,INTENT(IN) ::  clientid  !<
     352    INTEGER,INTENT(IN) ::  childid   !<
    339353
    340354    REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER           ::  array    !<
    … …  
    355369    IF ( PRESENT( array_2 ) )  THEN
    356370       second_adr = C_LOC(array_2)
    357        CALL pmc_s_setarray( clientid, nrdims, dims, array_adr,                 &
     371       CALL pmc_s_setarray( childid, nrdims, dims, array_adr,                   &
    358372                            second_adr = second_adr)
    359373    ELSE
    360        CALL pmc_s_setarray( clientid, nrdims, dims, array_adr )
     374       CALL pmc_s_setarray( childid, nrdims, dims, array_adr )
    361375    ENDIF
    362376
    … …  
    365379
    366380
    367  SUBROUTINE pmc_s_set_dataarray_3d( clientid, array, nz_cl, nz, array_2 )
     381 SUBROUTINE pmc_s_set_dataarray_3d( childid, array, nz_cl, nz, array_2 )
    368382
    369383    IMPLICIT NONE
    370384
    371     INTEGER, INTENT(IN) ::  clientid  !<
     385    INTEGER, INTENT(IN) ::  childid   !<
    372386    INTEGER, INTENT(IN) ::  nz        !<
    373387    INTEGER, INTENT(IN) ::  nz_cl     !<
    … …  
    381395    TYPE(C_PTR)           ::  second_adr  !<
    382396
     397!
    383398!-- TODO: the next assignment seems to be obsolete. Please check!
    384399    dims      = 1
    … …  
    397412    IF ( PRESENT( array_2 ) )  THEN
    398413      second_adr = C_LOC( array_2 )
    399       CALL pmc_s_setarray( clientid, nrdims, dims, array_adr,                  &
     414      CALL pmc_s_setarray( childid, nrdims, dims, array_adr,                    &
    400415                           second_adr = second_adr)
    401416    ELSE
    402        CALL pmc_s_setarray( clientid, nrdims, dims, array_adr )
     417       CALL pmc_s_setarray( childid, nrdims, dims, array_adr )
    403418    ENDIF
    404419
    … …  
    407422
    408423
    409  SUBROUTINE pmc_s_setind_and_allocmem( clientid )
    410 
    411     USE control_parameters,                                                    &
     424 SUBROUTINE pmc_s_setind_and_allocmem( childid )
     425
     426    USE control_parameters,                                                     &
    412427        ONLY:  message_string
    413428
    … …  
    415430
    416431!
    417 !-- Naming convention for appendices:   _sc  -> server to client transfer
    418 !--                                     _cs  -> client to server transfer
    419 !--                                     send -> server to client transfer
    420 !--                                     recv -> client to server transfer
    421     INTEGER, INTENT(IN) ::  clientid  !<
     432!-- Naming convention for appendices:   _pc  -> parent to child transfer
     433!--                                     _cp  -> child to parent transfer
     434!--                                     send -> parent to child transfer
     435!--                                     recv -> child to parent transfer
     436    INTEGER, INTENT(IN) ::  childid   !<
    422437
    423438    INTEGER                        ::  arlen    !<
    … …  
    439454    TYPE(arraydef), POINTER ::  ar        !<
    440455
    441     REAL(wp),DIMENSION(:), POINTER, SAVE ::  base_array_sc  !< base array for server to client transfer
    442     REAL(wp),DIMENSION(:), POINTER, SAVE ::  base_array_cs  !< base array for client to server transfer
    443 
    444 !
    445 !-- Server to client direction
     456    REAL(wp),DIMENSION(:), POINTER, SAVE ::  base_array_pc  !< base array for parent to child transfer
     457    REAL(wp),DIMENSION(:), POINTER, SAVE ::  base_array_cp  !< base array for child to parent transfer
     458
     459!
     460!-- Parent to child direction
    446461    myindex = 1
    447462    rcount  = 0
    … …  
    450465!
    451466!-- First stride: compute size and set index
    452     DO  i = 1, clients(clientid)%inter_npes
    453 
    454        ape => clients(clientid)%pes(i)
     467    DO  i = 1, children(childid)%inter_npes
     468
     469       ape => children(childid)%pes(i)
    455470       tag = 200
    456471
    … …  
    469484          tag    = tag + 1
    470485          rcount = rcount + 1
    471           CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag,                   &
    472                           clients(clientid)%inter_comm, req(rcount), ierr )
     486          CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag,                    &
     487                          children(childid)%inter_comm, req(rcount), ierr )
     488
    473489!
    474490!--       Maximum of 1024 outstanding requests
    475 !--       TODO: what does this limit means?
     491!--       TODO: what does this limit mean?
    476492          IF ( rcount == 1024 )  THEN
    477493             CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
    … …  
    492508
    493509!
    494 !-- Create RMA (One Sided Communication) window for data buffer server to
    495 !-- client transfer.
     510!-- Create RMA (One Sided Communication) window for data buffer parent to
     511!-- child transfer.
    496512!-- The buffer of MPI_GET (counterpart of transfer) can be PE-local, i.e.
    497513!-- it can but must not be part of the MPI RMA window. Only one RMA window is
    498514!-- required to prepare the data for
    499 !--                       server -> client transfer on the server side
     515!--                       parent -> child transfer on the parent side
    500516!-- and for
    501 !--                       client -> server transfer on the client side
    502     CALL pmc_alloc_mem( base_array_sc, bufsize )
    503     clients(clientid)%totalbuffersize = bufsize * wp
     517!--                       child -> parent transfer on the child side
     518    CALL pmc_alloc_mem( base_array_pc, bufsize )
     519    children(childid)%totalbuffersize = bufsize * wp
    504520
    505521    winsize = bufsize * wp
    506     CALL MPI_WIN_CREATE( base_array_sc, winsize, wp, MPI_INFO_NULL,            &
    507                          clients(clientid)%intra_comm,                         &
    508                          clients(clientid)%win_server_client, ierr )
     522    CALL MPI_WIN_CREATE( base_array_pc, winsize, wp, MPI_INFO_NULL,             &
     523                         children(childid)%intra_comm,                          &
     524                         children(childid)%win_parent_child, ierr )
     525
    509526!
    510527!-- Open window to set data
    511     CALL MPI_WIN_FENCE( 0, clients(clientid)%win_server_client, ierr )
     528    CALL MPI_WIN_FENCE( 0, children(childid)%win_parent_child, ierr )
     529
    512530!
    513531!-- Second stride: set buffer pointer
    514     DO  i = 1, clients(clientid)%inter_npes
    515 
    516        ape => clients(clientid)%pes(i)
     532    DO  i = 1, children(childid)%inter_npes
     533
     534       ape => children(childid)%pes(i)
    517535
    518536       DO  j = 1, ape%nr_arrays
    519537
    520538          ar => ape%array_list(j)
    521           ar%sendbuf = C_LOC( base_array_sc(ar%sendindex) )
    522 
    523 !--       TODO: replace this by standard PALM error message using the message routine
    524           IF ( ar%sendindex + ar%sendsize > bufsize )  THEN
    525              write(0,'(a,i4,4i7,1x,a)') 'Server Buffer too small ',i,        &
    526                 ar%sendindex,ar%sendsize,ar%sendindex+ar%sendsize,bufsize,trim(ar%name)
    527              CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
     539          ar%sendbuf = C_LOC( base_array_pc(ar%sendindex) )
     540
     541          IF ( ar%sendindex + ar%sendsize > bufsize )  THEN             
     542             WRITE( message_string, '(a,i4,4i7,1x,a)' )                         &
     543                    'Parent buffer too small ',i,                               &
     544                    ar%sendindex,ar%sendsize,ar%sendindex+ar%sendsize,          &
     545                    bufsize,trim(ar%name)
     546             CALL message( 'pmc_s_setind_and_allocmem', 'PA0429', 3, 2, 0, 6, 0 )
    528547          ENDIF
    529548       ENDDO
    … …  
    531550
    532551!
    533 !-- Client to server direction
     552!-- Child to parent direction
    534553    bufsize = 8
     554
    535555!
    536556!-- First stride: compute size and set index
    537     DO  i = 1, clients(clientid)%inter_npes
    538 
    539        ape => clients(clientid)%pes(i)
     557    DO  i = 1, children(childid)%inter_npes
     558
     559       ape => children(childid)%pes(i)
    540560       tag = 300
    541561
    … …  
    543563
    544564          ar => ape%array_list(j)
    545 !
    546 !--       Receive index from client
     565
     566!
     567!--       Receive index from child
    547568          tag = tag + 1
    548           CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag,                    &
    549                          clients(clientid)%inter_comm, MPI_STATUS_IGNORE, ierr )
     569          CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag,                     &
     570                         children(childid)%inter_comm, MPI_STATUS_IGNORE, ierr )
    550571
    551572          IF ( ar%nrdims == 3 )  THEN
    … …  
    564585!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of
    565586!-- the MPI RMA window
    566     CALL pmc_alloc_mem( base_array_cs, bufsize, base_ptr )
    567     clients(clientid)%totalbuffersize = bufsize * wp
    568 
    569     CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
     587    CALL pmc_alloc_mem( base_array_cp, bufsize, base_ptr )
     588    children(childid)%totalbuffersize = bufsize * wp
     589
     590    CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
     591
    570592!
    571593!-- Second stride: set buffer pointer
    572     DO  i = 1, clients(clientid)%inter_npes
    573 
    574        ape => clients(clientid)%pes(i)
     594    DO  i = 1, children(childid)%inter_npes
     595
     596       ape => children(childid)%pes(i)
    575597
    576598       DO  j = 1, ape%nr_arrays
    … …  
    585607
    586608
    587  SUBROUTINE pmc_s_fillbuffer( clientid, waittime )
     609 SUBROUTINE pmc_s_fillbuffer( childid, waittime )
    588610
    589611    IMPLICIT NONE
    590612
    591     INTEGER, INTENT(IN)             ::  clientid  !<
     613    INTEGER, INTENT(IN)             ::  childid   !<
    592614
    593615    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
    … …  
    612634
    613635!
    614 !-- Synchronization of the model is done in pmci_client_synchronize and
    615 !-- pmci_server_synchronize. Therefor the RMA window can be filled without
     636!-- Synchronization of the model is done in pmci_synchronize.
     637!-- Therefor the RMA window can be filled without
    616638!-- sychronization at this point and a barrier is not necessary.
    617639!-- Please note that waittime has to be set in pmc_s_fillbuffer AND
    … …  
    619641    IF ( PRESENT( waittime) )  THEN
    620642      t1 = pmc_time()
    621       CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
     643      CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
    622644      t2 = pmc_time()
    623645      waittime = t2- t1
    624646    ENDIF
    625647
    626     DO  ip = 1, clients(clientid)%inter_npes
    627 
    628        ape => clients(clientid)%pes(ip)
     648    DO  ip = 1, children(childid)%inter_npes
     649
     650       ape => children(childid)%pes(ip)
    629651
    630652       DO  j = 1, ape%nr_arrays
    … …  
    649671             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
    650672             DO  ij = 1, ape%nrele
    651                 buf(myindex:myindex+ar%a_dim(4)-1) =                           &
     673                buf(myindex:myindex+ar%a_dim(4)-1) =                            &
    652674                        data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i)
    653675                myindex = myindex + ar%a_dim(4)
    … …  
    659681
    660682    ENDDO
     683
    661684!
    662685!-- Buffer is filled
    663     CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
     686    CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
    664687
    665688 END SUBROUTINE pmc_s_fillbuffer
    … …  
    667690
    668691
    669  SUBROUTINE pmc_s_getdata_from_buffer( clientid, waittime )
     692 SUBROUTINE pmc_s_getdata_from_buffer( childid, waittime )
    670693
    671694    IMPLICIT NONE
    672695
    673     INTEGER, INTENT(IN)             ::  clientid  !<
    674     REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
    675 
    676     INTEGER                        ::  ierr         !<
    677     INTEGER                        ::  ij           !<
    678     INTEGER                        ::  ip           !<
    679     INTEGER                        ::  istat        !<
    680     INTEGER                        ::  j            !<
    681     INTEGER                        ::  myindex      !<
    682     INTEGER                        ::  nr           !<
    683     INTEGER                        ::  target_pe    !<
    684     INTEGER(kind=MPI_ADDRESS_KIND) ::  target_disp  !<
    685 
    686     INTEGER, DIMENSION(1)          ::  buf_shape    !<
     696    INTEGER, INTENT(IN)             ::  childid      !<
     697    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime     !<
     698
     699    INTEGER                        ::  ierr          !<
     700    INTEGER                        ::  ij            !<
     701    INTEGER                        ::  ip            !<
     702    INTEGER                        ::  istat         !<
     703    INTEGER                        ::  j             !<
     704    INTEGER                        ::  myindex       !<
     705    INTEGER                        ::  nr            !<
     706    INTEGER                        ::  target_pe     !<
     707    INTEGER(kind=MPI_ADDRESS_KIND) ::  target_disp   !<
     708
     709    INTEGER, DIMENSION(1)          ::  buf_shape     !<
    687710
    688711    REAL(wp)                            ::  t1       !<
    … …  
    697720
    698721    t1 = pmc_time()
    699 !
    700 !-- Wait for client to fill buffer
    701     CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
     722
     723!
     724!-- Wait for child to fill buffer
     725    CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
    702726    t2 = pmc_time() - t1
    703727    IF ( PRESENT( waittime ) )  waittime = t2
     728
    704729!
    705730!-- TODO: check next statement
    706731!-- Fence might do it, test later
    707 !-- CALL MPI_WIN_FENCE( 0, clients(clientid)%win_server_client, ierr)
    708     CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
    709 
    710     DO  ip = 1, clients(clientid)%inter_npes
    711 
    712        ape => clients(clientid)%pes(ip)
     732!-- CALL MPI_WIN_FENCE( 0, children(childid)%win_parent_child, ierr)
     733    CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
     734
     735    DO  ip = 1, children(childid)%inter_npes
     736
     737       ape => children(childid)%pes(ip)
    713738
    714739       DO  j = 1, ape%nr_arrays
    … …  
    731756          IF ( nr > 0 )  THEN
    732757             target_disp = ar%recvindex - 1
    733 !
    734 !--          Client PEs are located behind server PEs
     758
     759!
     760!--          Child PEs are located behind parent PEs
    735761             target_pe = ip - 1 + m_model_npes
    736              CALL MPI_WIN_LOCK( MPI_LOCK_SHARED, target_pe, 0,                 &
    737                                 clients(clientid)%win_server_client, ierr )
    738              CALL MPI_GET( buf, nr, MPI_REAL, target_pe, target_disp, nr,      &
    739                            MPI_REAL, clients(clientid)%win_server_client, ierr )
    740              CALL MPI_WIN_UNLOCK( target_pe,                                   &
    741                                   clients(clientid)%win_server_client, ierr )
     762             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED, target_pe, 0,                  &
     763                                children(childid)%win_parent_child, ierr )
     764             CALL MPI_GET( buf, nr, MPI_REAL, target_pe, target_disp, nr,       &
     765                           MPI_REAL, children(childid)%win_parent_child, ierr )
     766             CALL MPI_WIN_UNLOCK( target_pe,                                    &
     767                                  children(childid)%win_parent_child, ierr )
    742768          ENDIF
    743769
    … …  
    755781             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3))
    756782             DO  ij = 1, ape%nrele
    757                 data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i) =     &
     783                data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i) =      &
    758784                                              buf(myindex:myindex+ar%a_dim(4)-1)
    759785                myindex = myindex + ar%a_dim(4)
    … …  
    770796
    771797
    772  SUBROUTINE get_da_names_from_client( clientid )
    773 !
    774 !-- Get data array description and name from client
     798 SUBROUTINE get_da_names_from_child( childid )
     799
     800!
     801!-- Get data array description and name from child
    775802    IMPLICIT NONE
    776803
    777     INTEGER, INTENT(IN) ::  clientid  !<
     804    INTEGER, INTENT(IN) ::  childid  !<
    778805
    779806    TYPE(da_namedef) ::  myname  !<
    780807
    781808    DO
    782        CALL pmc_bcast( myname%couple_index, 0, comm=m_to_client_comm(clientid) )
     809       CALL pmc_bcast( myname%couple_index, 0, comm=m_to_child_comm(childid) )
    783810       IF ( myname%couple_index == -1 )  EXIT
    784        CALL pmc_bcast( myname%serverdesc,   0, comm=m_to_client_comm(clientid) )
    785        CALL pmc_bcast( myname%nameonserver, 0, comm=m_to_client_comm(clientid) )
    786        CALL pmc_bcast( myname%clientdesc,   0, comm=m_to_client_comm(clientid) )
    787        CALL pmc_bcast( myname%nameonclient, 0, comm=m_to_client_comm(clientid) )
    788 
    789        CALL pmc_g_setname( clients(clientid), myname%couple_index,             &
    790                            myname%nameonserver )
     811       CALL pmc_bcast( myname%parentdesc,   0, comm=m_to_child_comm(childid) )
     812       CALL pmc_bcast( myname%nameonparent, 0, comm=m_to_child_comm(childid) )
     813       CALL pmc_bcast( myname%childdesc,    0, comm=m_to_child_comm(childid) )
     814       CALL pmc_bcast( myname%nameonchild,  0, comm=m_to_child_comm(childid) )
     815
     816       CALL pmc_g_setname( children(childid), myname%couple_index,              &
     817                           myname%nameonparent )
    791818   ENDDO
    792819
    793  END SUBROUTINE get_da_names_from_client
    794 
    795 
    796 
    797  SUBROUTINE pmc_s_setarray(clientid, nrdims, dims, array_adr, second_adr )
    798 !
    799 !-- Set array for client interPE 0
     820 END SUBROUTINE get_da_names_from_child
     821
     822
     823
     824 SUBROUTINE pmc_s_setarray(childid, nrdims, dims, array_adr, second_adr )
     825
     826!
     827!-- Set array for child inter PE 0
    800828    IMPLICIT NONE
    801829
    802     INTEGER, INTENT(IN)               ::  clientid  !<
    803     INTEGER, INTENT(IN)               ::  nrdims    !<
    804     INTEGER, INTENT(IN), DIMENSION(:) ::  dims      !<
     830    INTEGER, INTENT(IN)               ::  childid    !<
     831    INTEGER, INTENT(IN)               ::  nrdims     !<
     832    INTEGER, INTENT(IN), DIMENSION(:) ::  dims       !<
    805833
    806834    TYPE(C_PTR), INTENT(IN)           :: array_adr   !<
    … …  
    813841
    814842
    815     DO  i = 1, clients(clientid)%inter_npes
    816 
    817        ape => clients(clientid)%pes(i)
     843    DO  i = 1, children(childid)%inter_npes
     844
     845       ape => children(childid)%pes(i)
    818846       ar  => ape%array_list(next_array_in_list)
    819847       ar%nrdims = nrdims
    … …  
    835863
    836864
    837  SUBROUTINE pmc_s_set_active_data_array( clientid, iactive )
     865 SUBROUTINE pmc_s_set_active_data_array( childid, iactive )
    838866
    839867    IMPLICIT NONE
    840868
    841     INTEGER, INTENT(IN) ::  clientid  !<
     869    INTEGER, INTENT(IN) ::  childid   !<
    842870    INTEGER, INTENT(IN) ::  iactive   !<
    843871
    … …  
    849877    TYPE(arraydef), POINTER ::  ar   !<
    850878
    851     DO  ip = 1, clients(clientid)%inter_npes
    852 
    853        ape => clients(clientid)%pes(ip)
     879    DO  ip = 1, children(childid)%inter_npes
     880
     881       ape => children(childid)%pes(ip)
    854882
    855883       DO  j = 1, ape%nr_arrays
    … …  
    868896
    869897
    870  SUBROUTINE set_pe_index_list( clientid, myclient, index_list, nrp )
     898 SUBROUTINE set_pe_index_list( childid, mychild, index_list, nrp )
    871899
    872900    IMPLICIT NONE
    873901
    874     INTEGER, INTENT(IN)                 ::  clientid    !<
     902    INTEGER, INTENT(IN)                 ::  childid     !<
    875903    INTEGER, INTENT(IN), DIMENSION(:,:) ::  index_list  !<
    876904    INTEGER, INTENT(IN)                 ::  nrp         !<
    877905
    878     TYPE(clientdef), INTENT(INOUT) ::  myclient  !<
     906    TYPE(childdef), INTENT(INOUT)       ::  mychild     !<
    879907
    880908    INTEGER                                 :: i        !<
    … …  
    888916    INTEGER(KIND=MPI_ADDRESS_KIND)          :: winsize  !<
    889917
    890     INTEGER, DIMENSION(myclient%inter_npes) :: remind   !<
     918    INTEGER, DIMENSION(mychild%inter_npes) :: remind   !<
    891919
    892920    INTEGER, DIMENSION(:), POINTER          :: remindw  !<
    … …  
    896924
    897925!
    898 !-- First, count entries for every remote client PE
    899     DO  i = 1, myclient%inter_npes
    900        ape => myclient%pes(i)
     926!-- First, count entries for every remote child PE
     927    DO  i = 1, mychild%inter_npes
     928       ape => mychild%pes(i)
    901929       ape%nrele = 0
    902930    ENDDO
     931
    903932!
    904933!-- Loop over number of coarse grid cells
    905934    DO  j = 1, nrp
    906935       rempe = index_list(5,j) + 1   ! PE number on remote PE
    907        ape => myclient%pes(rempe)
    908        ape%nrele = ape%nrele + 1 ! Increment number of elements for this client PE
    909     ENDDO
    910 
    911     DO  i = 1, myclient%inter_npes
    912        ape => myclient%pes(i)
     936       ape => mychild%pes(rempe)
     937       ape%nrele = ape%nrele + 1     ! Increment number of elements for this child PE
     938    ENDDO
     939
     940    DO  i = 1, mychild%inter_npes
     941       ape => mychild%pes(i)
    913942       ALLOCATE( ape%locind(ape%nrele) )
    914943    ENDDO
    … …  
    921950    DO  j = 1, nrp
    922951       rempe = index_list(5,j) + 1
    923        ape => myclient%pes(rempe)
     952       ape => mychild%pes(rempe)
    924953       remind(rempe)     = remind(rempe)+1
    925954       ind               = remind(rempe)
    … …  
    927956       ape%locind(ind)%j = index_list(2,j)
    928957    ENDDO
    929 !
    930 !-- Prepare number of elements for client PEs
    931     CALL pmc_alloc_mem( rldef, myclient%inter_npes*2 )
    932 !
    933 !-- Number of client PEs * size of INTEGER (i just arbitrary INTEGER)
    934     winsize = myclient%inter_npes*c_sizeof(i)*2
    935 
    936     CALL MPI_WIN_CREATE( rldef, winsize, iwp, MPI_INFO_NULL,                   &
    937                          myclient%intra_comm, indwin, ierr )
     958
     959!
     960!-- Prepare number of elements for children PEs
     961    CALL pmc_alloc_mem( rldef, mychild%inter_npes*2 )
     962
     963!
     964!-- Number of child PEs * size of INTEGER (i just arbitrary INTEGER)
     965    winsize = mychild%inter_npes*c_sizeof(i)*2
     966
     967    CALL MPI_WIN_CREATE( rldef, winsize, iwp, MPI_INFO_NULL,                    &
     968                         mychild%intra_comm, indwin, ierr )
     969
    938970!
    939971!-- Open window to set data
    … …  
    942974    rldef(1) = 0            ! index on remote PE 0
    943975    rldef(2) = remind(1)    ! number of elements on remote PE 0
     976
    944977!
    945978!-- Reserve buffer for index array
    946     DO  i = 2, myclient%inter_npes
     979    DO  i = 2, mychild%inter_npes
    947980       i2          = (i-1) * 2 + 1
    948981       rldef(i2)   = rldef(i2-2) + rldef(i2-1) * 2  ! index on remote PE
    949        rldef(i2+1) = remind(i)                ! number of elements on remote PE
    950     ENDDO
    951 !
    952 !-- Close window to allow client to access data
     982       rldef(i2+1) = remind(i)                      ! number of elements on remote PE
     983    ENDDO
     984
     985!
     986!-- Close window to allow child to access data
    953987    CALL MPI_WIN_FENCE( 0, indwin, ierr )
    954 !
    955 !-- Client has retrieved data
     988
     989!
     990!-- Child has retrieved data
    956991    CALL MPI_WIN_FENCE( 0, indwin, ierr )
    957992
    958     i2 = 2 * myclient%inter_npes - 1
     993    i2 = 2 * mychild%inter_npes - 1
    959994    winsize = ( rldef(i2) + rldef(i2+1) ) * 2
     995
    960996!
    961997!-- Make sure, MPI_ALLOC_MEM works
    … …  
    9651001
    9661002    CALL MPI_BARRIER( m_model_comm, ierr )
    967     CALL MPI_WIN_CREATE( remindw, winsize*c_sizeof(i), iwp, MPI_INFO_NULL,     &
    968                          myclient%intra_comm, indwin2, ierr )
     1003    CALL MPI_WIN_CREATE( remindw, winsize*c_sizeof(i), iwp, MPI_INFO_NULL,      &
     1004                         mychild%intra_comm, indwin2, ierr )
    9691005!
    9701006!-- Open window to set data
    9711007    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
     1008
    9721009!
    9731010!-- Create the 2D index list
    9741011    DO  j = 1, nrp
    9751012       rempe = index_list(5,j) + 1    ! PE number on remote PE
    976        ape => myclient%pes(rempe)
     1013       ape => mychild%pes(rempe)
    9771014       i2    = rempe * 2 - 1
    9781015       ind   = rldef(i2) + 1
    … …  
    9811018       rldef(i2)      = rldef(i2)+2
    9821019    ENDDO
    983 !
    984 !-- All data areset
     1020
     1021!
     1022!-- All data are set
    9851023    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
     1024
    9861025!
    9871026!-- Don't know why, but this barrier is necessary before windows can be freed
    9881027!-- TODO: find out why this is required
    989     CALL MPI_BARRIER( myclient%intra_comm, ierr )
     1028    CALL MPI_BARRIER( mychild%intra_comm, ierr )
    9901029
    9911030    CALL MPI_WIN_FREE( indwin, ierr )
    9921031    CALL MPI_WIN_FREE( indwin2, ierr )
    9931032
     1033!
    9941034!-- TODO: check if the following idea needs to be done
    9951035!-- Sollte funktionieren, Problem mit MPI implementation
    … …  
    10001040
    10011041#endif
    1002  END MODULE pmc_server
     1042 END MODULE pmc_parent
Note: See TracChangeset for help on using the changeset viewer.
                                                                                                                                                                                                                                                                                                                                                                               
  | Impressum | ©Leibniz Universität Hannover |