Ignore:
Timestamp:
Mar 8, 2016 5:49:27 AM (6 years ago)
Author:
raasch
Message:

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

File:
1 edited

Legend:

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

    r1784 r1786  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! change in client-server data transfer: server now gets data from client
     23! instead that client put's it to the server
    2324!
    2425! Former revisions:
     
    361362       do i=1,me%inter_npes
    362363          aPE => me%PEs(i)
    363           ar  => aPE%array_list(next_array_in_list)    !actual array is last array in list
     364          ar  => aPE%array_list(next_array_in_list)
    364365          ar%NrDims    = NrDims
    365366          ar%A_dim     = dims
     
    407408      IMPLICIT none
    408409
    409       INTEGER                                 :: i, ierr, j
     410!--   naming convention:  appending       _sc  -> server to client transfer
     411!--                                       _cs  -> client to server transfer
     412!--                                       Recv -> server to client transfer
     413!--                                       Send -> client to server transfer
     414
     415      INTEGER                                 :: i, istat, ierr, j
     416      INTEGER,PARAMETER                       :: NoINdex=-1
     417      INTEGER                                 :: rcount
    410418      INTEGER                                 :: arlen, myIndex, tag
    411419      INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
    412420      TYPE(PeDef),POINTER                     :: aPE
    413421      TYPE(ArrayDef),POINTER                  :: ar
     422      INTEGER,DIMENSION(1024)                 :: req
    414423      character(len=DA_Namelen)               :: myName
    415424      Type(c_ptr)                             :: base_ptr
    416       REAL(kind=wp),DIMENSION(:),POINTER      :: base_array
     425      REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_sc             !Base array
     426      REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_cs             !Base array
    417427      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
    418428
     
    420430      bufsize = 8
    421431
    422       ! First stride, Compute size and set index
     432!--   Server to client direction
     433
     434!--   First stride, Compute size and set index
    423435
    424436      do i=1,me%inter_npes
     
    433445            CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, MPI_STATUS_IGNORE, ierr)
    434446
    435             if(ar%NrDims == 3) then                    ! PALM has k in first dimension
     447            if(ar%NrDims == 3) then
    436448               bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2)*ar%A_dim(3))    ! determine max, because client buffer is allocated only once
    437449            else
    438450               bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2))
    439451            end if
    440             ar%BufIndex = myIndex
    441           end do
     452            ar%RecvIndex = myIndex
     453
     454           end do
    442455      end do
    443456
    444       ! Create RMA (One Sided Communication) window for data buffer
    445 
    446       CALL PMC_Alloc_mem (base_array, bufsize, base_ptr)
    447       me%TotalBufferSize = bufsize*wp                          !Total buffer size in Byte
    448 
    449       WinSize = me%TotalBufferSize
    450 !      write(9,'(a,8i7)') 'PMC_S_SetInd_and_Mem ',m_model_rank,me%inter_npes,WinSize,ar%A_dim
    451       CALL MPI_Win_create (base_array, WinSize, wp, MPI_INFO_NULL, me%intra_comm, me%BufWin, ierr);
    452       CALL MPI_Win_fence (0, me%BufWin, ierr);                    !  Open Window to set data
    453       CALL MPI_Barrier(me%intra_comm, ierr)
     457
     458!--   Create RMA (One Sided Communication) data buffer
     459!--   The buffer for MPI_Get can be PE local, i.e. it can but must not be part of the MPI RMA window
     460
     461      CALL PMC_Alloc_mem (base_array_sc, bufsize, base_ptr)
     462      me%TotalBufferSize = bufsize*wp                          ! Total buffer size in Byte
     463
     464!--   Second stride, Set Buffer pointer
    454465
    455466      do i=1,me%inter_npes
     
    458469         do j=1,aPE%Nr_arrays
    459470            ar  => aPE%array_list(j)
    460             ar%SendBuf = base_ptr
     471            ar%RecvBuf = base_ptr
     472         end do
     473      end do
     474
     475!--   Client to server direction
     476
     477      myIndex = 1
     478      rCount  = 0
     479      bufsize = 8
     480
     481      do i=1,me%inter_npes
     482         aPE => me%PEs(i)
     483         tag = 300
     484         do j=1,aPE%Nr_arrays
     485            ar  => aPE%array_list(j)
     486            if(ar%NrDims == 2) then
     487               arlen     = aPE%NrEle                        ! 2D
     488            else if(ar%NrDims == 3) then
     489               arlen     = aPE%NrEle*ar%A_dim(1)            ! 3D
     490            end if
     491
     492            tag    = tag+1
     493            rCount = rCount+1
     494            if(aPE%NrEle > 0)  then
     495               CALL MPI_Isend (myIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, req(rCount),ierr)
     496               ar%SendIndex = myIndex
     497            else
     498               CALL MPI_Isend (NoIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, req(rCount),ierr)
     499               ar%SendIndex = NoIndex
     500            end if
     501
     502            if(rCount == 1024) then                                  ! Maximum of 1024 outstanding requests
     503               CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
     504               rCount = 0;
     505            end if
     506
     507            if(aPE%NrEle > 0)  then
     508               ar%SendSize  = arlen
     509               myIndex     = myIndex+arlen
     510               bufsize     = bufsize+arlen
     511            end if
     512          end do
     513         if(rCount > 0) then                                          ! Wait for all send completed
     514            CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
     515         end if
     516      end do
     517
     518!--   Create RMA (One Sided Communication) window for data buffer client to server transfer
     519!--   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
     520!--   Only one RMA window is required to prepare the data for server -> client transfer on the server side and
     521!--                                                       for client -> server transfer on the client side
     522
     523      CALL PMC_Alloc_mem (base_array_cs, bufsize)
     524      me%TotalBufferSize = bufsize*wp                          !Total buffer size in Byte
     525
     526      WinSize = me%TotalBufferSize
     527      CALL MPI_Win_create (base_array_cs, WinSize, wp, MPI_INFO_NULL, me%intra_comm, me%win_server_client, ierr);
     528      CALL MPI_Win_fence (0, me%win_server_client, ierr);                    !  Open Window to set data
     529      CALL MPI_Barrier(me%intra_comm, ierr)
     530
     531!--   Second stride, Set Buffer pointer
     532
     533      do i=1,me%inter_npes
     534         aPE => me%PEs(i)
     535
     536         do j=1,aPE%Nr_arrays
     537            ar  => aPE%array_list(j)
     538            if(aPE%NrEle > 0)  then
     539              ar%SendBuf = c_loc(base_array_cs(ar%SendIndex))
     540              if(ar%SendIndex+ar%SendSize > bufsize) then
     541                 write(0,'(a,i4,4i7,1x,a)') 'Client Buffer too small ',i,ar%SendIndex,ar%SendSize,ar%SendIndex+ar%SendSize,bufsize,trim(ar%name)
     542                 CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
     543              end if
     544            end if
    461545         end do
    462546      end do
     
    504588
    505589            buf_shape(1) = nr
    506             CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
     590            CALL c_f_pointer(ar%RecvBuf, buf, buf_shape)
    507591!
    508592!--         MPI passive target RMA
    509593            if(nr > 0)   then
    510                target_disp = (ar%BufIndex-1)
    511                CALL MPI_Win_lock (MPI_LOCK_SHARED , ip-1, 0, me%BufWin, ierr)
    512                CALL MPI_Get (buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, me%BufWin, ierr)
    513                CALL MPI_Win_unlock (ip-1, me%BufWin, ierr)
     594               target_disp = (ar%RecvIndex-1)
     595               CALL MPI_Win_lock (MPI_LOCK_SHARED , ip-1, 0, me%win_server_client, ierr)
     596               CALL MPI_Get (buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, me%win_server_client, ierr)
     597               CALL MPI_Win_unlock (ip-1, me%win_server_client, ierr)
    514598            end if
    515599
     
    555639      INTEGER(kind=MPI_ADDRESS_KIND)    ::  target_disp
    556640
     641      t1 = PMC_Time()
     642      CALL MPI_Barrier(me%intra_comm, ierr)              ! Wait for empty buffer
     643      t2 = PMC_Time()
     644      if(present(WaitTime)) WaitTime = t2-t1
    557645
    558646      do ip=1,me%inter_npes
     
    561649         do j=1,aPE%Nr_arrays
    562650            ar  => aPE%array_list(j)
     651            myIndex=1
    563652            if(ar%NrDims == 2) then
    564                nr = aPE%NrEle
    565             else if(ar%NrDims == 3) then
    566                nr = aPE%NrEle*ar%A_dim(1)
    567             end if
    568 
    569             buf_shape(1) = nr
    570             CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
    571 
    572             myIndex = 1
    573             if(ar%NrDims == 2) then
     653               buf_shape(1) = aPE%NrEle
     654               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
    574655               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
    575656               do ij=1,aPE%NrEle
     
    578659               end do
    579660            else if(ar%NrDims == 3) then
     661               buf_shape(1) = aPE%NrEle*ar%A_dim(1)
     662               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
    580663               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
    581664               do ij=1,aPE%NrEle
     
    584667               end do
    585668            end if
    586 !
    587 !--         MPI passiv target RMA
    588             if(nr > 0)   then
    589                target_disp = (ar%BufIndex-1)
    590                CALL MPI_Win_lock (MPI_LOCK_SHARED , ip-1, 0, me%BufWin, ierr)
    591                CALL MPI_Put (buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, me%BufWin, ierr)
    592                CALL MPI_Win_unlock (ip-1, me%BufWin, ierr)
    593             end if
    594 
    595669          end do
    596670      end do
    597671
    598672
    599       t1 = PMC_Time()
    600       CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for server to fill buffer
    601       t2 = PMC_Time()
    602       if(present(WaitTime)) WaitTime = t2-t1
    603 
    604       CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for buffer is filled
    605 
     673!      CALL MPI_Win_fence (0, me%win_server_client, ierr)      ! Fence might do it, test later
     674      CALL MPI_Barrier(me%intra_comm, ierr)                   ! buffer is filled
    606675
    607676      return
Note: See TracChangeset for help on using the changeset viewer.