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

last commit documented

File:
1 moved

Legend:

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

    r1932 r1933  
    1 MODULE pmc_client
    2 
    3 !--------------------------------------------------------------------------------!
     1MODULE pmc_child
     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! 1897 2016-05-03 08:10:23Z raasch
     29! Module renamed. Code clean up. The words server/client changed to parent/child.
    2730!
    2831! 1896 2016-05-03 08:06:41Z 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 of that child puts it to the parent
    5154!
    5255! 1783 2016-03-06 18:36:17Z raasch
     
    6770! ------------
    6871!
    69 ! Client part of Palm Model Coupler
    70 !------------------------------------------------------------------------------!
     72! Child part of Palm Model Coupler
     73!-------------------------------------------------------------------------------!
    7174
    7275#if defined( __parallel )
     
    8184
    8285    USE kinds
    83     USE pmc_general,                                                           &
    84         ONLY:  arraydef, clientdef, da_desclen, da_namedef, da_namelen, pedef, &
     86    USE pmc_general,                                                            &
     87        ONLY:  arraydef, childdef, da_desclen, da_namedef, da_namelen, pedef,  &
    8588               pmc_da_name_err,  pmc_g_setname, pmc_max_array, pmc_status_ok
    8689
    87     USE pmc_handle_communicator,                                               &
    88         ONLY:  m_model_comm, m_model_npes, m_model_rank, m_to_server_comm
    89 
    90     USE pmc_mpi_wrapper,                                                       &
    91         ONLY:  pmc_alloc_mem, pmc_bcast, pmc_inter_bcast,                      &
    92                pmc_recv_from_server, pmc_send_to_server, pmc_time
     90    USE pmc_handle_communicator,                                                &
     91        ONLY:  m_model_comm, m_model_npes, m_model_rank, m_to_parent_comm
     92
     93    USE pmc_mpi_wrapper,                                                        &
     94        ONLY:  pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, pmc_time
    9395
    9496    IMPLICIT NONE
     
    9799    SAVE
    98100
    99     TYPE(clientdef) ::  me   !<
     101    TYPE(childdef) ::  me   !<
    100102
    101103    INTEGER ::  myindex = 0         !< counter and unique number for data arrays
     
    103105
    104106
    105     INTERFACE pmc_clientinit
    106         MODULE PROCEDURE pmc_clientinit
    107     END INTERFACE PMC_ClientInit
     107    INTERFACE pmc_childinit
     108        MODULE PROCEDURE pmc_childinit
     109    END INTERFACE pmc_childinit
    108110
    109111    INTERFACE pmc_c_clear_next_array_list
     
    142144
    143145
    144     PUBLIC pmc_clientinit, pmc_c_clear_next_array_list, pmc_c_getbuffer,       &
    145            pmc_c_getnextarray, pmc_c_putbuffer, pmc_c_setind_and_allocmem,     &
     146    PUBLIC pmc_childinit, pmc_c_clear_next_array_list, pmc_c_getbuffer,         &
     147           pmc_c_getnextarray, pmc_c_putbuffer, pmc_c_setind_and_allocmem,      &
    146148           pmc_c_set_dataarray, pmc_set_dataarray_name, pmc_c_get_2d_index_list
    147149
     
    150152
    151153
    152  SUBROUTINE pmc_clientinit
     154 SUBROUTINE pmc_childinit
    153155
    154156     IMPLICIT NONE
     
    160162!--  Get / define the MPI environment
    161163     me%model_comm = m_model_comm
    162      me%inter_comm = m_to_server_comm
     164     me%inter_comm = m_to_parent_comm
    163165
    164166     CALL MPI_COMM_RANK( me%model_comm, me%model_rank, istat )
    165167     CALL MPI_COMM_SIZE( me%model_comm, me%model_npes, istat )
    166168     CALL MPI_COMM_REMOTE_SIZE( me%inter_comm, me%inter_npes, istat )
     169
    167170!
    168171!--  Intra-communicater is used for MPI_GET
     
    173176
    174177!
    175 !--  Allocate an array of type arraydef for all server PEs to store information
     178!--  Allocate an array of type arraydef for all parent PEs to store information
    176179!--  of then transfer array
    177180     DO  i = 1, me%inter_npes
     
    179182     ENDDO
    180183
    181  END SUBROUTINE pmc_clientinit
    182 
    183 
    184 
    185  SUBROUTINE pmc_set_dataarray_name( serverarraydesc, serverarrayname,          &
    186                                     clientarraydesc, clientarrayname, istat )
    187 
    188     IMPLICIT NONE
    189 
    190     CHARACTER(LEN=*), INTENT(IN) ::  serverarrayname  !<
    191     CHARACTER(LEN=*), INTENT(IN) ::  serverarraydesc  !<
    192     CHARACTER(LEN=*), INTENT(IN) ::  clientarrayname  !<
    193     CHARACTER(LEN=*), INTENT(IN) ::  clientarraydesc  !<
     184 END SUBROUTINE pmc_childinit
     185
     186
     187
     188 SUBROUTINE pmc_set_dataarray_name( parentarraydesc, parentarrayname,           &
     189                                    childarraydesc, childarrayname, istat )
     190
     191    IMPLICIT NONE
     192
     193    CHARACTER(LEN=*), INTENT(IN) ::  parentarrayname  !<
     194    CHARACTER(LEN=*), INTENT(IN) ::  parentarraydesc  !<
     195    CHARACTER(LEN=*), INTENT(IN) ::  childarrayname   !<
     196    CHARACTER(LEN=*), INTENT(IN) ::  childarraydesc   !<
    194197
    195198    INTEGER, INTENT(OUT) ::  istat  !<
     
    204207
    205208    istat = pmc_status_ok
     209
    206210!
    207211!-- Check length of array names
    208     IF ( LEN( TRIM( serverarrayname) ) > da_namelen  .OR.                     &
    209          LEN( TRIM( clientarrayname) ) > da_namelen )  THEN
     212    IF ( LEN( TRIM( parentarrayname) ) > da_namelen  .OR.                       &
     213         LEN( TRIM( childarrayname) ) > da_namelen )  THEN
    210214       istat = pmc_da_name_err
    211215    ENDIF
     
    214218       myindex = myindex + 1
    215219       myname%couple_index = myIndex
    216        myname%serverdesc   = TRIM( serverarraydesc )
    217        myname%nameonserver = TRIM( serverarrayname )
    218        myname%clientdesc   = TRIM( clientarraydesc )
    219        myname%nameonclient = TRIM( clientarrayname )
     220       myname%parentdesc   = TRIM( parentarraydesc )
     221       myname%nameonparent = TRIM( parentarrayname )
     222       myname%childdesc    = TRIM( childarraydesc )
     223       myname%nameonchild  = TRIM( childarrayname )
    220224    ENDIF
    221225
    222226!
    223 !-- Broadcat to all client PEs
     227!-- Broadcat to all child PEs
    224228!-- TODO: describe what is broadcast here and why it is done
    225229    CALL pmc_bcast( myname%couple_index, 0, comm=m_model_comm )
    226     CALL pmc_bcast( myname%serverdesc,   0, comm=m_model_comm )
    227     CALL pmc_bcast( myname%nameonserver, 0, comm=m_model_comm )
    228     CALL pmc_bcast( myname%clientdesc,   0, comm=m_model_comm )
    229     CALL pmc_bcast( myname%nameonclient, 0, comm=m_model_comm )
    230 
    231 !
    232 !-- Broadcat to all server PEs
     230    CALL pmc_bcast( myname%parentdesc,   0, comm=m_model_comm )
     231    CALL pmc_bcast( myname%nameonparent, 0, comm=m_model_comm )
     232    CALL pmc_bcast( myname%childdesc,    0, comm=m_model_comm )
     233    CALL pmc_bcast( myname%nameonchild, 0, comm=m_model_comm )
     234
     235!
     236!-- Broadcat to all parent PEs
    233237!-- TODO: describe what is broadcast here and why it is done
    234238    IF ( m_model_rank == 0 )  THEN
     
    238242    ENDIF
    239243
    240     CALL pmc_bcast( myname%couple_index, mype, comm=m_to_server_comm )
    241     CALL pmc_bcast( myname%serverdesc,   mype, comm=m_to_server_comm )
    242     CALL pmc_bcast( myname%nameonserver, mype, comm=m_to_server_comm )
    243     CALL pmc_bcast( myname%clientdesc,   mype, comm=m_to_server_comm )
    244     CALL pmc_bcast( myname%nameonclient, mype, comm=m_to_server_comm )
    245 
    246     CALL pmc_g_setname( me, myname%couple_index, myname%nameonclient )
     244    CALL pmc_bcast( myname%couple_index, mype, comm=m_to_parent_comm )
     245    CALL pmc_bcast( myname%parentdesc,   mype, comm=m_to_parent_comm )
     246    CALL pmc_bcast( myname%nameonparent, mype, comm=m_to_parent_comm )
     247    CALL pmc_bcast( myname%childdesc,    mype, comm=m_to_parent_comm )
     248    CALL pmc_bcast( myname%nameonchild,  mype, comm=m_to_parent_comm )
     249
     250    CALL pmc_g_setname( me, myname%couple_index, myname%nameonchild )
    247251
    248252 END SUBROUTINE pmc_set_dataarray_name
     
    269273    ENDIF
    270274
    271     CALL pmc_bcast( myname%couple_index, mype, comm=m_to_server_comm )
     275    CALL pmc_bcast( myname%couple_index, mype, comm=m_to_parent_comm )
    272276
    273277 END SUBROUTINE pmc_set_dataarray_name_lastentry
     
    296300
    297301    win_size = C_SIZEOF( dummy )
    298     CALL MPI_WIN_CREATE( dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm,   &
     302    CALL MPI_WIN_CREATE( dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm,    &
    299303                         indwin, ierr )
    300 !
    301 !-- Open window on server side
     304
     305!
     306!-- Open window on parent side
    302307!-- TODO: why is the next MPI routine called twice??
    303308    CALL MPI_WIN_FENCE( 0, indwin, ierr )
    304 !
    305 !-- Close window on server side and open on client side
     309
     310!
     311!-- Close window on parent side and open on child side
    306312    CALL MPI_WIN_FENCE( 0, indwin, ierr )
    307313
    308314    DO  i = 1, me%inter_npes
    309315       disp = me%model_rank * 2
    310        CALL MPI_GET( nrele((i-1)*2+1), 2, MPI_INTEGER, i-1, disp, 2,           &
     316       CALL MPI_GET( nrele((i-1)*2+1), 2, MPI_INTEGER, i-1, disp, 2,            &
    311317                     MPI_INTEGER, indwin, ierr )
    312318    ENDDO
     319
    313320!
    314321!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
     
    336343!
    337344!-- Local buffer used in MPI_GET can but must not be inside the MPI Window.
    338 !-- Here, we use a dummy for the MPI window because the server PEs do not access
     345!-- Here, we use a dummy for the MPI window because the parent PEs do not access
    339346!-- the RMA window via MPI_GET or MPI_PUT
    340     CALL MPI_WIN_CREATE( dummy, winsize, iwp, MPI_INFO_NULL, me%intra_comm,    &
     347    CALL MPI_WIN_CREATE( dummy, winsize, iwp, MPI_INFO_NULL, me%intra_comm,     &
    341348                         indwin2, ierr )
     349
    342350!
    343351!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
     
    353361          disp = nrele(2*(i-1)+1)
    354362          CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , i-1, 0, indwin2, ierr )
    355           CALL MPI_GET( myind, 2*nr, MPI_INTEGER, i-1, disp, 2*nr,             &
     363          CALL MPI_GET( myind, 2*nr, MPI_INTEGER, i-1, disp, 2*nr,              &
    356364                        MPI_INTEGER, indwin2, ierr )
    357365          CALL MPI_WIN_UNLOCK( i-1, indwin2, ierr )
     
    389397
    390398 LOGICAL FUNCTION pmc_c_getnextarray( myname )
     399
    391400!
    392401!--  List handling is still required to get minimal interaction with
     
    403412
    404413!
    405 !-- Array names are the same on all client PEs, so take first PE to get the name
     414!-- Array names are the same on all child PEs, so take first PE to get the name
    406415    ape => me%pes(1)
     416
    407417!
    408418!-- Check if all arrays have been processed
     
    497507
    498508    IMPLICIT NONE
    499 !
    500 !-- Naming convention for appendices:  _sc  -> server to client transfer
    501 !--                                    _cs  -> client to server transfer
    502 !--                                    recv -> server to client transfer
    503 !--                                    send -> client to server transfer
     509
     510!
     511!-- Naming convention for appendices:  _pc  -> parent to child transfer
     512!--                                    _cp  -> child to parent transfer
     513!--                                    recv -> parent to child transfer
     514!--                                    send -> child to parent transfer
    504515    CHARACTER(LEN=da_namelen) ::  myname  !<
    505516
     
    520531    INTEGER,DIMENSION(1024) ::  req  !<
    521532
    522     REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_sc  !< base array
    523     REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_cs  !< base array
     533    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_pc  !< base array
     534    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_cp  !< base array
    524535
    525536    TYPE(pedef), POINTER    ::  ape       !<
     
    532543
    533544!
    534 !-- Server to client direction.
     545!-- Parent to child direction.
    535546!-- First stride: compute size and set index
    536547    DO  i = 1, me%inter_npes
     
    542553
    543554          ar => ape%array_list(j)
    544 !
    545 !--       Receive index from client
     555
     556!
     557!--       Receive index from child
    546558          tag = tag + 1
    547           CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,     &
     559          CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,      &
    548560                         MPI_STATUS_IGNORE, ierr )
    549561          ar%recvindex = myindex
    550 !
    551 !--       Determine max, because client buffer is allocated only once
     562
     563!
     564!--       Determine max, because child buffer is allocated only once
    552565!--       TODO: give a more meaningful comment
    553566          IF( ar%nrdims == 3 )  THEN
     
    565578!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of
    566579!-- the MPI RMA window
    567     CALL pmc_alloc_mem( base_array_sc, bufsize, base_ptr )
     580    CALL pmc_alloc_mem( base_array_pc, bufsize, base_ptr )
    568581    me%totalbuffersize = bufsize*wp  ! total buffer size in byte
    569582
     
    582595
    583596!
    584 !-- Client to server direction
     597!-- Child to parent direction
    585598    myindex = 1
    586599    rcount  = 0
     
    604617          rcount = rcount + 1
    605618          IF ( ape%nrele > 0 )  THEN
    606              CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
     619             CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,  &
    607620                             req(rcount), ierr )
    608621             ar%sendindex = myindex
    609622          ELSE
    610              CALL MPI_ISEND( noindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
     623             CALL MPI_ISEND( noindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,  &
    611624                             req(rcount), ierr )
    612625             ar%sendindex = noindex
    613626          ENDIF
     627
    614628!
    615629!--       Maximum of 1024 outstanding requests
     
    635649
    636650!
    637 !-- Create RMA (one sided communication) window for data buffer client to server
     651!-- Create RMA (one sided communication) window for data buffer child to parent
    638652!-- transfer.
    639653!-- The buffer of MPI_GET (counter part of transfer) can be PE-local, i.e. it
    640654!-- can but must not be part of the MPI RMA window. Only one RMA window is
    641655!-- required to prepare the data
    642 !--        for server -> client transfer on the server side
     656!--        for parent -> child transfer on the parent side
    643657!-- and
    644 !--        for client -> server transfer on the client side
    645 
    646     CALL pmc_alloc_mem( base_array_cs, bufsize )
     658!--        for child -> parent transfer on the child side
     659    CALL pmc_alloc_mem( base_array_cp, bufsize )
    647660    me%totalbuffersize = bufsize * wp  ! total buffer size in byte
    648661
    649662    winSize = me%totalbuffersize
    650663
    651     CALL MPI_WIN_CREATE( base_array_cs, winsize, wp, MPI_INFO_NULL,            &
    652                          me%intra_comm, me%win_server_client, ierr )
    653     CALL MPI_WIN_FENCE( 0, me%win_server_client, ierr )
     664    CALL MPI_WIN_CREATE( base_array_cp, winsize, wp, MPI_INFO_NULL,             &
     665                         me%intra_comm, me%win_parent_child, ierr )
     666    CALL MPI_WIN_FENCE( 0, me%win_parent_child, ierr )
    654667    CALL MPI_BARRIER( me%intra_comm, ierr )
    655668
     
    665678
    666679          IF ( ape%nrele > 0 )  THEN
    667              ar%sendbuf = C_LOC( base_array_cs(ar%sendindex) )
     680             ar%sendbuf = C_LOC( base_array_cp(ar%sendindex) )
     681
     682!
    668683!--          TODO: if this is an error to be really expected, replace the
    669684!--                following message by a meaningful standard PALM message using
    670685!--                the message-routine
    671686             IF ( ar%sendindex+ar%sendsize > bufsize )  THEN
    672                 WRITE( 0,'(a,i4,4i7,1x,a)') 'Client Buffer too small ', i,     &
    673                           ar%sendindex, ar%sendsize, ar%sendindex+ar%sendsize, &
     687                WRITE( 0,'(a,i4,4i7,1x,a)') 'Child buffer too small ', i,       &
     688                          ar%sendindex, ar%sendsize, ar%sendindex+ar%sendsize,  &
    674689                          bufsize, TRIM( ar%name )
    675690                CALL MPI_ABORT( MPI_COMM_WORLD, istat, ierr )
     
    699714    INTEGER                        ::  myindex  !<
    700715    INTEGER                        ::  nr       !< number of elements to get
    701                                                 !< from server
     716                                                !< from parent
    702717    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp
    703718    INTEGER,DIMENSION(1)           ::  buf_shape
     
    713728
    714729!
    715 !-- Synchronization of the model is done in pmci_client_synchronize and
    716 !-- pmci_server_synchronize. Therefor the RMA window can be filled without
     730!-- Synchronization of the model is done in pmci_synchronize.
     731!-- Therefore the RMA window can be filled without
    717732!-- sychronization at this point and a barrier is not necessary.
    718733!-- Please note that waittime has to be set in pmc_s_fillbuffer AND
     
    724739       waittime = t2 - t1
    725740    ENDIF
    726 !
    727 !-- Wait for buffer is filled
     741
     742!
     743!-- Wait for buffer is filled.
    728744!-- TODO: explain in more detail what is happening here. The barrier seems to
    729 !-- contradict what is said a few lines beforer (i.e. that no barrier is necessary)
     745!-- contradict what is said a few lines before (i.e. that no barrier is necessary)
    730746!-- TODO: In case of PRESENT( waittime ) the barrrier would be calles twice. Why?
    731747!-- Shouldn't it be done the same way as in pmc_putbuffer?
     
    748764          buf_shape(1) = nr
    749765          CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
     766
    750767!
    751768!--       MPI passive target RMA
     
    753770          IF ( nr > 0 )  THEN
    754771             target_disp = ar%recvindex - 1
    755              CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0,                     &
    756                                 me%win_server_client, ierr )
    757              CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, &
    758                                 me%win_server_client, ierr )
    759              CALL MPI_WIN_UNLOCK( ip-1, me%win_server_client, ierr )
     772             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0,                      &
     773                                me%win_parent_child, ierr )
     774             CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL,  &
     775                                me%win_parent_child, ierr )
     776             CALL MPI_WIN_UNLOCK( ip-1, me%win_parent_child, ierr )
    760777          ENDIF
    761778
     
    775792
    776793             DO  ij = 1, ape%nrele
    777                 data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) =                 &
     794                data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) =                  &
    778795                                              buf(myindex:myindex+ar%a_dim(1)-1)
    779796                myindex = myindex+ar%a_dim(1)
     
    804821    INTEGER                        ::  myindex      !<
    805822    INTEGER                        ::  nr           !< number of elements to get
    806                                                     !< from server
     823                                                    !< from parent
    807824    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp  !<
    808825
     
    854871
    855872             DO  ij = 1, ape%nrele
    856                 buf(myindex:myindex+ar%a_dim(1)-1) =                           &
     873                buf(myindex:myindex+ar%a_dim(1)-1) =                            &
    857874                                    data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i)
    858875                myindex = myindex + ar%a_dim(1)
     
    864881
    865882    ENDDO
     883
    866884!
    867885!-- TODO: Fence might do it, test later
    868 !-- Call MPI_WIN_FENCE( 0, me%win_server_client, ierr)      !
     886!-- Call MPI_WIN_FENCE( 0, me%win_parent_child, ierr)      !
    869887!
    870888!-- Buffer is filled
     
    875893
    876894#endif
    877  END MODULE pmc_client
     895 END MODULE pmc_child
Note: See TracChangeset for help on using the changeset viewer.