Changeset 1786 for palm/trunk/SOURCE/pmc_server.f90

Timestamp:

Mar 8, 2016 5:49:27 AM (8 years ago)

Author:

raasch

Message:

pmc-change in server-client get-put, spectra-directives removed, spectra-package modularized

File:

• palm/trunk/SOURCE/pmc_server.f90 (modified) (11 diffs)

palm/trunk/SOURCE/pmc_server.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! change in client-server data transfer: server now gets data from client
+! instead that client put's it to the server
 !
 ! Former revisions:
@@ -336 +337 @@
       IMPLICIT none
 
+!
+!--   Naming convention for appendices:   _sc  -> server to client transfer
+!--                                       _cs  -> client to server transfer
+!--                                       Send -> Server to client transfer
+!--                                       Recv -> client to server transfer
       INTEGER,INTENT(IN)                      :: ClientId
 
@@ -347 +353 @@
       INTEGER,DIMENSION(1024)                 :: req
       Type(c_ptr)                             :: base_ptr
-      REAL(kind=wp),DIMENSION(:),POINTER      :: base_array
+      REAL(wp),DIMENSION(:),POINTER,SAVE :: base_array_sc  !Base array for server to client transfer
+      REAL(wp),DIMENSION(:),POINTER,SAVE :: base_array_cs  !Base array for client to server transfer
       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
 
+!
+!--   Server to client direction
       myIndex = 1
       rCount  = 0
       bufsize = 8
 
-      ! First stride, Compute size and set index
-
+!
+!--   First stride: Compute size and set index
       do i=1,Clients(ClientId)%inter_npes
          aPE => Clients(ClientId)%PEs(i)
@@ -362 +371 @@
             ar  => aPE%array_list(j)
             if(ar%NrDims == 2) then
-               arlen     = aPE%NrEle;                             ! 2D
+               arlen     = aPE%NrEle                              ! 2D
             else if(ar%NrDims == 3) then
-               arlen     = aPE%NrEle * ar%A_dim(4);               ! PALM 3D
+               arlen     = aPE%NrEle * ar%A_dim(4);               ! 3D
             else
                arlen     = -1
             end if
-            ar%BufIndex = myIndex
+            ar%SendIndex = myIndex
 
             tag    = tag+1
@@ -381 +390 @@
             myIndex = myIndex+arlen
             bufsize = bufsize+arlen
-            ar%BufSize = arlen
+            ar%SendSize = arlen
 
          end do
-         if(rCount > 0) then                                          ! Wait for all send completed
+         if(rCount > 0) then                       ! Wait for all send completed
             CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
          end if
       end do
 
-      ! Create RMA (One Sided Communication) window for data buffer
-
-      CALL PMC_Alloc_mem (base_array, bufsize, base_ptr)
-      Clients(ClientId)%TotalBufferSize = bufsize*wp       !Total buffer size in Byte
+!
+!--   Create RMA (One Sided Communication) window for data buffer server to
+!--   client 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 and
+!--   for client -> server transfer on the client side
+      CALL PMC_Alloc_mem (base_array_sc, bufsize)
+      Clients(ClientId)%TotalBufferSize = bufsize*wp   !Total buffer size in Byte
 
       WinSize = bufsize*wp
-!      write(9,*) 'PMC_S_SetInd_and_Mem ',m_model_rank,Clients(ClientId)%inter_npes,WinSize,bufsize
-      CALL MPI_Win_create (base_array, WinSize, wp, MPI_INFO_NULL, Clients(ClientId)%intra_comm, Clients(ClientId)%BufWin, ierr);
-      CALL MPI_Win_fence (0, Clients(ClientId)%BufWin, ierr);                    !  Open Window to set data
-      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)
-
-      ! Second stride, Set Buffer pointer
-
+      CALL MPI_Win_create (base_array_sc, WinSize, wp, MPI_INFO_NULL,          &
+                  Clients(ClientId)%intra_comm,  Clients(ClientId)%win_server_client, ierr)
+      CALL MPI_Win_fence (0, Clients(ClientId)%win_server_client, ierr);        !  Open Window to set data
+!
+!--   Second stride: Set Buffer pointer
       do i=1,Clients(ClientId)%inter_npes
          aPE => Clients(ClientId)%PEs(i)
          do j=1,aPE%Nr_arrays
             ar  => aPE%array_list(j)
-!--         TO_DO:  Adressrechnung ueberlegen?
-            ar%SendBuf = c_loc(base_array(ar%BufIndex))                         !kk Adressrechnung ueberlegen
-            if(ar%BufIndex+ar%BufSize > bufsize) then
-!--            TO_DO: can this error really happen, and what can be the reason?
-               write(0,'(a,i4,4i7,1x,a)') 'Buffer too small ',i,ar%BufIndex,ar%BufSize,ar%BufIndex+ar%BufSize,bufsize,trim(ar%name)
+            ar%SendBuf = c_loc(base_array_sc(ar%SendIndex))
+            if(ar%SendIndex+ar%SendSize > bufsize) then
+               write(0,'(a,i4,4i7,1x,a)') 'Server Buffer too small ',i,ar%SendIndex,ar%SendSize,ar%SendIndex+ar%SendSize,bufsize,trim(ar%name)
                CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
             end if
+         end do
+      end do
+
+!--   Client to server direction
+
+      bufsize  = 8
+
+!--   First stride, Compute size and set index
+
+      do i=1,Clients(ClientId)%inter_npes
+         aPE => Clients(ClientId)%PEs(i)
+         tag = 300
+
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+
+            ! Receive Index from client
+            tag = tag+1
+            CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, Clients(ClientId)%inter_comm, MPI_STATUS_IGNORE, ierr)
+
+            if(ar%NrDims == 3) then
+               bufsize = max(bufsize,aPE%NrEle * ar%A_dim(4))               ! 3D
+            else
+               bufsize = max(bufsize,aPE%NrEle)                             ! 2D
+            end if
+            ar%RecvIndex = myIndex
+          end do
+
+      end do
+
+!--   Create RMA (One Sided Communication) data buffer
+!--   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_cs, bufsize, base_ptr)
+      Clients(ClientId)%TotalBufferSize = bufsize*wp       !Total buffer size in Byte
+
+      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)
+
+!--   Second stride, Set Buffer pointer
+
+      do i=1,Clients(ClientId)%inter_npes
+         aPE => Clients(ClientId)%PEs(i)
+
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            ar%RecvBuf = base_ptr
          end do
       end do
@@ -465 +522 @@
       end do
 
-      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)    ! buffer is full
+      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)    ! buffer is filled
 
       return
@@ -480 +537 @@
       INTEGER                             ::  ip,ij,istat,ierr,j
       INTEGER                             ::  myIndex
+      INTEGER                             ::  nr
       REAL(wp)                            ::  t1,t2
       TYPE(PeDef),POINTER                 ::  aPE
@@ -488 +546 @@
       REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
       REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
+      INTEGER                             ::  target_pe
+      INTEGER(kind=MPI_ADDRESS_KIND)      ::  target_disp
 
       t1 = PMC_Time()
-      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)              ! Wait for MPI_Put from client
-      t2 = PMC_Time()
-      if(present(WaitTime)) WaitTime = t2-t1
+      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)                         ! Wait for client to fill buffer
+      t2 = PMC_Time()-t1
+      if(present(WaitTime)) WaitTime = t2
+
+!      CALL MPI_Win_fence (0, Clients(ClientId)%win_server_client, ierr)            ! Fence might do it, test later
+      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)                         ! Wait for buffer is filled
 
       do ip=1,Clients(ClientId)%inter_npes
@@ -498 +561 @@
          do j=1,aPE%Nr_arrays
             ar  => aPE%array_list(j)
+
+            if(ar%RecvIndex < 0)  CYCLE
+
+            if(ar%NrDims == 2) then
+               nr = aPE%NrEle
+            else if(ar%NrDims == 3) then
+               nr = aPE%NrEle*ar%A_dim(4)
+            end if
+
+            buf_shape(1) = nr
+            CALL c_f_pointer(ar%RecvBuf, buf, buf_shape)
+!
+!--         MPI passive target RMA
+
+            if(nr > 0)   then
+               target_disp = ar%RecvIndex-1
+               target_pe = ip-1+m_model_npes                         ! client PEs are located behind server PEs
+               CALL MPI_Win_lock (MPI_LOCK_SHARED , target_pe, 0, Clients(ClientId)%win_server_client, ierr)
+               CALL MPI_Get (buf, nr, MPI_REAL, target_pe, target_disp, nr, MPI_REAL, Clients(ClientId)%win_server_client, ierr)
+               CALL MPI_Win_unlock (target_pe, Clients(ClientId)%win_server_client, ierr)
+            end if
+
             myIndex=1
             if(ar%NrDims == 2) then
-               buf_shape(1) = aPE%NrEle
-               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
                CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
                do ij=1,aPE%NrEle
@@ -508 +591 @@
                end do
             else if(ar%NrDims == 3) then
-               buf_shape(1) = aPE%NrEle*ar%A_dim(4)
-               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
                CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
                do ij=1,aPE%NrEle
@@ -519 +600 @@
       end do
 
-      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)              ! data copy finished, buffer is free for use agein
-
-        return
    END SUBROUTINE PMC_S_GetData_from_Buffer