Changeset 1933 for palm/trunk/SOURCE/pmc_child_mod.f90

Timestamp:

Jun 13, 2016 7:12:51 AM (8 years ago)

Author:

hellstea

Message:

last commit documented

File:

• palm/trunk/SOURCE/pmc_child_mod.f90 (moved) (moved from palm/trunk/SOURCE/pmc_client_mod.f90) (40 diffs)

palm/trunk/SOURCE/pmc_child_mod.f90

@@ -1 @@
-MODULE pmc_client
-
-!--------------------------------------------------------------------------------!
+MODULE pmc_child
+
+!-------------------------------------------------------------------------------!
 ! This file is part of PALM.
 !
@@ -16 +16 @@
 !
 ! Copyright 1997-2016 Leibniz Universitaet Hannover
-!--------------------------------------------------------------------------------!
+!-------------------------------------------------------------------------------!
 !
 ! Current revisions:
 ! ------------------
 ! 
-!
+! 
 ! Former revisions:
 ! -----------------
 ! $Id$
+!
+! 1897 2016-05-03 08:10:23Z raasch
+! Module renamed. Code clean up. The words server/client changed to parent/child.
 !
 ! 1896 2016-05-03 08:06:41Z raasch
@@ -47 +50 @@
 !
 ! 1786 2016-03-08 05:49:27Z raasch
-! change in client-server data transfer: server now gets data from client
-! instead that client put's it to the server
+! change in child-parent data transfer: parent now gets data from child
+! instead of that child puts it to the parent
 !
 ! 1783 2016-03-06 18:36:17Z raasch
@@ -67 +70 @@
 ! ------------
 !
-! Client part of Palm Model Coupler
-!------------------------------------------------------------------------------!
+! Child part of Palm Model Coupler
+!-------------------------------------------------------------------------------!
 
 #if defined( __parallel )
@@ -81 +84 @@
 
     USE kinds
-    USE pmc_general,                                                           &
-        ONLY:  arraydef, clientdef, da_desclen, da_namedef, da_namelen, pedef, &
+    USE pmc_general,                                                            &
+        ONLY:  arraydef, childdef, da_desclen, da_namedef, da_namelen, pedef,   &
                pmc_da_name_err,  pmc_g_setname, pmc_max_array, pmc_status_ok
 
-    USE pmc_handle_communicator,                                               &
-        ONLY:  m_model_comm, m_model_npes, m_model_rank, m_to_server_comm
-
-    USE pmc_mpi_wrapper,                                                       &
-        ONLY:  pmc_alloc_mem, pmc_bcast, pmc_inter_bcast,                      &
-               pmc_recv_from_server, pmc_send_to_server, pmc_time
+    USE pmc_handle_communicator,                                                &
+        ONLY:  m_model_comm, m_model_npes, m_model_rank, m_to_parent_comm
+
+    USE pmc_mpi_wrapper,                                                        &
+        ONLY:  pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, pmc_time
 
     IMPLICIT NONE
@@ -97 +99 @@
     SAVE
 
-    TYPE(clientdef) ::  me   !<
+    TYPE(childdef) ::  me   !<
 
     INTEGER ::  myindex = 0         !< counter and unique number for data arrays
@@ -103 +105 @@
 
 
-    INTERFACE pmc_clientinit
-        MODULE PROCEDURE pmc_clientinit
-    END INTERFACE PMC_ClientInit
+    INTERFACE pmc_childinit
+        MODULE PROCEDURE pmc_childinit
+    END INTERFACE pmc_childinit
 
     INTERFACE pmc_c_clear_next_array_list
@@ -142 +144 @@
 
 
-    PUBLIC pmc_clientinit, pmc_c_clear_next_array_list, pmc_c_getbuffer,       &
-           pmc_c_getnextarray, pmc_c_putbuffer, pmc_c_setind_and_allocmem,     &
+    PUBLIC pmc_childinit, pmc_c_clear_next_array_list, pmc_c_getbuffer,         &
+           pmc_c_getnextarray, pmc_c_putbuffer, pmc_c_setind_and_allocmem,      &
            pmc_c_set_dataarray, pmc_set_dataarray_name, pmc_c_get_2d_index_list
 
@@ -150 +152 @@
 
 
- SUBROUTINE pmc_clientinit
+ SUBROUTINE pmc_childinit
 
      IMPLICIT NONE
@@ -160 +162 @@
 !--  Get / define the MPI environment
      me%model_comm = m_model_comm
-     me%inter_comm = m_to_server_comm
+     me%inter_comm = m_to_parent_comm
 
      CALL MPI_COMM_RANK( me%model_comm, me%model_rank, istat )
      CALL MPI_COMM_SIZE( me%model_comm, me%model_npes, istat )
      CALL MPI_COMM_REMOTE_SIZE( me%inter_comm, me%inter_npes, istat )
+
 !
 !--  Intra-communicater is used for MPI_GET
@@ -173 +176 @@
 
 !
-!--  Allocate an array of type arraydef for all server PEs to store information
+!--  Allocate an array of type arraydef for all parent PEs to store information
 !--  of then transfer array
      DO  i = 1, me%inter_npes
@@ -179 +182 @@
      ENDDO
 
- END SUBROUTINE pmc_clientinit
-
-
-
- SUBROUTINE pmc_set_dataarray_name( serverarraydesc, serverarrayname,          &
-                                    clientarraydesc, clientarrayname, istat )
-
-    IMPLICIT NONE
-
-    CHARACTER(LEN=*), INTENT(IN) ::  serverarrayname  !<
-    CHARACTER(LEN=*), INTENT(IN) ::  serverarraydesc  !<
-    CHARACTER(LEN=*), INTENT(IN) ::  clientarrayname  !<
-    CHARACTER(LEN=*), INTENT(IN) ::  clientarraydesc  !<
+ END SUBROUTINE pmc_childinit
+
+
+
+ SUBROUTINE pmc_set_dataarray_name( parentarraydesc, parentarrayname,           &
+                                    childarraydesc, childarrayname, istat )
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=*), INTENT(IN) ::  parentarrayname  !<
+    CHARACTER(LEN=*), INTENT(IN) ::  parentarraydesc  !<
+    CHARACTER(LEN=*), INTENT(IN) ::  childarrayname   !<
+    CHARACTER(LEN=*), INTENT(IN) ::  childarraydesc   !<
 
     INTEGER, INTENT(OUT) ::  istat  !<
@@ -204 +207 @@
 
     istat = pmc_status_ok
+
 !
 !-- Check length of array names
-    IF ( LEN( TRIM( serverarrayname) ) > da_namelen  .OR.                     &
-         LEN( TRIM( clientarrayname) ) > da_namelen )  THEN
+    IF ( LEN( TRIM( parentarrayname) ) > da_namelen  .OR.                       &
+         LEN( TRIM( childarrayname) ) > da_namelen )  THEN
        istat = pmc_da_name_err
     ENDIF
@@ -214 +218 @@
        myindex = myindex + 1
        myname%couple_index = myIndex
-       myname%serverdesc   = TRIM( serverarraydesc )
-       myname%nameonserver = TRIM( serverarrayname )
-       myname%clientdesc   = TRIM( clientarraydesc )
-       myname%nameonclient = TRIM( clientarrayname )
+       myname%parentdesc   = TRIM( parentarraydesc )
+       myname%nameonparent = TRIM( parentarrayname )
+       myname%childdesc    = TRIM( childarraydesc )
+       myname%nameonchild  = TRIM( childarrayname )
     ENDIF
 
 !
-!-- Broadcat to all client PEs
+!-- Broadcat to all child PEs
 !-- TODO: describe what is broadcast here and why it is done
     CALL pmc_bcast( myname%couple_index, 0, comm=m_model_comm )
-    CALL pmc_bcast( myname%serverdesc,   0, comm=m_model_comm )
-    CALL pmc_bcast( myname%nameonserver, 0, comm=m_model_comm )
-    CALL pmc_bcast( myname%clientdesc,   0, comm=m_model_comm )
-    CALL pmc_bcast( myname%nameonclient, 0, comm=m_model_comm )
-
-!
-!-- Broadcat to all server PEs
+    CALL pmc_bcast( myname%parentdesc,   0, comm=m_model_comm )
+    CALL pmc_bcast( myname%nameonparent, 0, comm=m_model_comm )
+    CALL pmc_bcast( myname%childdesc,    0, comm=m_model_comm )
+    CALL pmc_bcast( myname%nameonchild,  0, comm=m_model_comm )
+
+!
+!-- Broadcat to all parent PEs
 !-- TODO: describe what is broadcast here and why it is done
     IF ( m_model_rank == 0 )  THEN
@@ -238 +242 @@
     ENDIF
 
-    CALL pmc_bcast( myname%couple_index, mype, comm=m_to_server_comm )
-    CALL pmc_bcast( myname%serverdesc,   mype, comm=m_to_server_comm )
-    CALL pmc_bcast( myname%nameonserver, mype, comm=m_to_server_comm )
-    CALL pmc_bcast( myname%clientdesc,   mype, comm=m_to_server_comm )
-    CALL pmc_bcast( myname%nameonclient, mype, comm=m_to_server_comm )
-
-    CALL pmc_g_setname( me, myname%couple_index, myname%nameonclient )
+    CALL pmc_bcast( myname%couple_index, mype, comm=m_to_parent_comm )
+    CALL pmc_bcast( myname%parentdesc,   mype, comm=m_to_parent_comm )
+    CALL pmc_bcast( myname%nameonparent, mype, comm=m_to_parent_comm )
+    CALL pmc_bcast( myname%childdesc,    mype, comm=m_to_parent_comm )
+    CALL pmc_bcast( myname%nameonchild,  mype, comm=m_to_parent_comm )
+
+    CALL pmc_g_setname( me, myname%couple_index, myname%nameonchild )
 
  END SUBROUTINE pmc_set_dataarray_name
@@ -269 +273 @@
     ENDIF
 
-    CALL pmc_bcast( myname%couple_index, mype, comm=m_to_server_comm )
+    CALL pmc_bcast( myname%couple_index, mype, comm=m_to_parent_comm )
 
  END SUBROUTINE pmc_set_dataarray_name_lastentry
@@ -296 +300 @@
 
     win_size = C_SIZEOF( dummy )
-    CALL MPI_WIN_CREATE( dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm,   &
+    CALL MPI_WIN_CREATE( dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm,    &
                          indwin, ierr )
-!
-!-- Open window on server side
+
+!
+!-- Open window on parent side
 !-- TODO: why is the next MPI routine called twice??
     CALL MPI_WIN_FENCE( 0, indwin, ierr )
-!
-!-- Close window on server side and open on client side
+
+!
+!-- Close window on parent side and open on child side
     CALL MPI_WIN_FENCE( 0, indwin, ierr )
 
     DO  i = 1, me%inter_npes
        disp = me%model_rank * 2
-       CALL MPI_GET( nrele((i-1)*2+1), 2, MPI_INTEGER, i-1, disp, 2,           &
+       CALL MPI_GET( nrele((i-1)*2+1), 2, MPI_INTEGER, i-1, disp, 2,            &
                      MPI_INTEGER, indwin, ierr )
     ENDDO
+
 !
 !-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
@@ -336 +343 @@
 !
 !-- Local buffer used in MPI_GET can but must not be inside the MPI Window.
-!-- Here, we use a dummy for the MPI window because the server PEs do not access
+!-- Here, we use a dummy for the MPI window because the parent PEs do not access
 !-- the RMA window via MPI_GET or MPI_PUT
-    CALL MPI_WIN_CREATE( dummy, winsize, iwp, MPI_INFO_NULL, me%intra_comm,    &
+    CALL MPI_WIN_CREATE( dummy, winsize, iwp, MPI_INFO_NULL, me%intra_comm,     &
                          indwin2, ierr )
+
 !
 !-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
@@ -353 +361 @@
           disp = nrele(2*(i-1)+1)
           CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , i-1, 0, indwin2, ierr )
-          CALL MPI_GET( myind, 2*nr, MPI_INTEGER, i-1, disp, 2*nr,             &
+          CALL MPI_GET( myind, 2*nr, MPI_INTEGER, i-1, disp, 2*nr,              &
                         MPI_INTEGER, indwin2, ierr )
           CALL MPI_WIN_UNLOCK( i-1, indwin2, ierr )
@@ -389 +397 @@
 
  LOGICAL FUNCTION pmc_c_getnextarray( myname )
+
 !
 !--  List handling is still required to get minimal interaction with
@@ -403 +412 @@
 
 !
-!-- Array names are the same on all client PEs, so take first PE to get the name
+!-- Array names are the same on all child PEs, so take first PE to get the name
     ape => me%pes(1)
+
 !
 !-- Check if all arrays have been processed
@@ -497 +507 @@
 
     IMPLICIT NONE
-!
-!-- Naming convention for appendices:  _sc  -> server to client transfer
-!--                                    _cs  -> client to server transfer
-!--                                    recv -> server to client transfer
-!--                                    send -> client to server transfer
+
+!
+!-- Naming convention for appendices:  _pc  -> parent to child transfer
+!--                                    _cp  -> child to parent transfer
+!--                                    recv -> parent to child transfer
+!--                                    send -> child to parent transfer
     CHARACTER(LEN=da_namelen) ::  myname  !<
 
@@ -520 +531 @@
     INTEGER,DIMENSION(1024) ::  req  !<
 
-    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_sc  !< base array
-    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_cs  !< base array
+    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_pc  !< base array
+    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_cp  !< base array
 
     TYPE(pedef), POINTER    ::  ape       !<
@@ -532 +543 @@
 
 !
-!-- Server to client direction.
+!-- Parent to child direction.
 !-- First stride: compute size and set index
     DO  i = 1, me%inter_npes
@@ -542 +553 @@
 
           ar => ape%array_list(j)
-!
-!--       Receive index from client
+
+!
+!--       Receive index from child
           tag = tag + 1
-          CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,     &
+          CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,      &
                          MPI_STATUS_IGNORE, ierr )
           ar%recvindex = myindex
-!
-!--       Determine max, because client buffer is allocated only once
+
+!
+!--       Determine max, because child buffer is allocated only once
 !--       TODO: give a more meaningful comment
           IF( ar%nrdims == 3 )  THEN
@@ -565 +578 @@
 !-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of
 !-- the MPI RMA window
-    CALL pmc_alloc_mem( base_array_sc, bufsize, base_ptr )
+    CALL pmc_alloc_mem( base_array_pc, bufsize, base_ptr )
     me%totalbuffersize = bufsize*wp  ! total buffer size in byte
 
@@ -582 +595 @@
 
 !
-!-- Client to server direction
+!-- Child to parent direction
     myindex = 1
     rcount  = 0
@@ -604 +617 @@
           rcount = rcount + 1
           IF ( ape%nrele > 0 )  THEN
-             CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
+             CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,  &
                              req(rcount), ierr )
              ar%sendindex = myindex
           ELSE
-             CALL MPI_ISEND( noindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
+             CALL MPI_ISEND( noindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,  &
                              req(rcount), ierr )
              ar%sendindex = noindex
           ENDIF
+
 !
 !--       Maximum of 1024 outstanding requests
@@ -635 +649 @@
 
 !
-!-- Create RMA (one sided communication) window for data buffer client to server
+!-- Create RMA (one sided communication) window for data buffer child to parent
 !-- transfer.
 !-- The buffer of MPI_GET (counter part of transfer) can be PE-local, i.e. it
 !-- can but must not be part of the MPI RMA window. Only one RMA window is
 !-- required to prepare the data
-!--        for server -> client transfer on the server side
+!--        for parent -> child transfer on the parent side
 !-- and
-!--        for client -> server transfer on the client side
-
-    CALL pmc_alloc_mem( base_array_cs, bufsize )
+!--        for child -> parent transfer on the child side
+    CALL pmc_alloc_mem( base_array_cp, bufsize )
     me%totalbuffersize = bufsize * wp  ! total buffer size in byte
 
     winSize = me%totalbuffersize
 
-    CALL MPI_WIN_CREATE( base_array_cs, winsize, wp, MPI_INFO_NULL,            &
-                         me%intra_comm, me%win_server_client, ierr )
-    CALL MPI_WIN_FENCE( 0, me%win_server_client, ierr )
+    CALL MPI_WIN_CREATE( base_array_cp, winsize, wp, MPI_INFO_NULL,             &
+                         me%intra_comm, me%win_parent_child, ierr )
+    CALL MPI_WIN_FENCE( 0, me%win_parent_child, ierr )
     CALL MPI_BARRIER( me%intra_comm, ierr )
 
@@ -665 +678 @@
 
           IF ( ape%nrele > 0 )  THEN
-             ar%sendbuf = C_LOC( base_array_cs(ar%sendindex) )
+             ar%sendbuf = C_LOC( base_array_cp(ar%sendindex) )
+
+!
 !--          TODO: if this is an error to be really expected, replace the
 !--                following message by a meaningful standard PALM message using
 !--                the message-routine
              IF ( ar%sendindex+ar%sendsize > bufsize )  THEN
-                WRITE( 0,'(a,i4,4i7,1x,a)') 'Client Buffer too small ', i,     &
-                          ar%sendindex, ar%sendsize, ar%sendindex+ar%sendsize, &
+                WRITE( 0,'(a,i4,4i7,1x,a)') 'Child buffer too small ', i,       &
+                          ar%sendindex, ar%sendsize, ar%sendindex+ar%sendsize,  &
                           bufsize, TRIM( ar%name )
                 CALL MPI_ABORT( MPI_COMM_WORLD, istat, ierr )
@@ -699 +714 @@
     INTEGER                        ::  myindex  !<
     INTEGER                        ::  nr       !< number of elements to get
-                                                !< from server
+                                                !< from parent
     INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp
     INTEGER,DIMENSION(1)           ::  buf_shape
@@ -713 +728 @@
 
 !
-!-- Synchronization of the model is done in pmci_client_synchronize and
-!-- pmci_server_synchronize. Therefor the RMA window can be filled without
+!-- Synchronization of the model is done in pmci_synchronize. 
+!-- Therefore the RMA window can be filled without
 !-- sychronization at this point and a barrier is not necessary.
 !-- Please note that waittime has to be set in pmc_s_fillbuffer AND
@@ -724 +739 @@
        waittime = t2 - t1
     ENDIF
-!
-!-- Wait for buffer is filled
+
+!
+!-- Wait for buffer is filled.
 !-- TODO: explain in more detail what is happening here. The barrier seems to
-!-- contradict what is said a few lines beforer (i.e. that no barrier is necessary)
+!-- contradict what is said a few lines before (i.e. that no barrier is necessary)
 !-- TODO: In case of PRESENT( waittime ) the barrrier would be calles twice. Why?
 !-- Shouldn't it be done the same way as in pmc_putbuffer?
@@ -748 +764 @@
           buf_shape(1) = nr
           CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
+
 !
 !--       MPI passive target RMA
@@ -753 +770 @@
           IF ( nr > 0 )  THEN
              target_disp = ar%recvindex - 1
-             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0,                     &
-                                me%win_server_client, ierr )
-             CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, &
-                                me%win_server_client, ierr )
-             CALL MPI_WIN_UNLOCK( ip-1, me%win_server_client, ierr )
+             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0,                      &
+                                me%win_parent_child, ierr )
+             CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL,  &
+                                me%win_parent_child, ierr )
+             CALL MPI_WIN_UNLOCK( ip-1, me%win_parent_child, ierr )
           ENDIF
 
@@ -775 +792 @@
 
              DO  ij = 1, ape%nrele
-                data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) =                 &
+                data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) =                  &
                                               buf(myindex:myindex+ar%a_dim(1)-1)
                 myindex = myindex+ar%a_dim(1)
@@ -804 +821 @@
     INTEGER                        ::  myindex      !<
     INTEGER                        ::  nr           !< number of elements to get
-                                                    !< from server
+                                                    !< from parent
     INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp  !<
 
@@ -854 +871 @@
 
              DO  ij = 1, ape%nrele
-                buf(myindex:myindex+ar%a_dim(1)-1) =                           &
+                buf(myindex:myindex+ar%a_dim(1)-1) =                            &
                                     data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i)
                 myindex = myindex + ar%a_dim(1)
@@ -864 +881 @@
 
     ENDDO
+
 !
 !-- TODO: Fence might do it, test later
-!-- Call MPI_WIN_FENCE( 0, me%win_server_client, ierr)      !
+!-- Call MPI_WIN_FENCE( 0, me%win_parent_child, ierr)      !
 !
 !-- Buffer is filled
@@ -875 +893 @@
 
 #endif
- END MODULE pmc_client
+ END MODULE pmc_child