source: palm/trunk/SOURCE/pmc_client.f90 @ 1786

Last change on this file since 1786 was 1786, checked in by raasch, 6 years ago

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

  • Property svn:keywords set to Id
File size: 24.1 KB
Line 
1MODULE pmc_client
2
3!--------------------------------------------------------------------------------!
4! This file is part of PALM.
5!
6! PALM is free software: you can redistribute it and/or modify it under the terms
7! of the GNU General Public License as published by the Free Software Foundation,
8! either version 3 of the License, or (at your option) any later version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 1997-2015 Leibniz Universitaet Hannover
18!--------------------------------------------------------------------------------!
19!
20! Current revisions:
21! ------------------
22! change in client-server data transfer: server now gets data from client
23! instead that client put's it to the server
24!
25! Former revisions:
26! -----------------
27! $Id: pmc_client.f90 1786 2016-03-08 05:49:27Z raasch $
28!
29! 1783 2016-03-06 18:36:17Z raasch
30! Bugfix: wrong data-type in MPI_WIN_CREATE replaced
31!
32! 1779 2016-03-03 08:01:28Z raasch
33! kind=dp replaced by wp, dim_order removed
34! array management changed from linked list to sequential loop
35!
36! 1764 2016-02-28 12:45:19Z raasch
37! cpp-statement added (nesting can only be used in parallel mode),
38! all kinds given in PALM style
39!
40! 1762 2016-02-25 12:31:13Z hellstea
41! Initial revision by K. Ketelsen
42!
43! Description:
44! ------------
45!
46! Client part of Palm Model Coupler
47!------------------------------------------------------------------------------!
48
49#if defined( __parallel )
50
51    use, intrinsic :: iso_c_binding
52
53#if defined( __lc )
54    USE MPI
55#else
56    INCLUDE "mpif.h"
57#endif
58    USE  kinds
59    USE  PMC_general,   ONLY: ClientDef, DA_NameDef, DA_Namelen, PMC_STATUS_OK, PMC_DA_NAME_ERR, PeDef, ArrayDef, &
60                                         DA_Desclen, DA_Namelen, PMC_G_SetName, PMC_MAX_ARRAY
61    USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_server_comm
62    USE  PMC_MPI_wrapper,           ONLY: PMC_Send_to_Server, PMC_Recv_from_Server, PMC_Time,                     &
63                                              PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem
64    IMPLICIT none
65    PRIVATE
66    SAVE
67
68    Type(ClientDef)                       :: me
69
70    INTEGER                               :: next_array_in_list = 0
71    INTEGER                               :: myIndex = 0                !Counter and unique number for Data Arrays
72
73    ! INTERFACE section
74
75    INTERFACE PMC_ClientInit
76        MODULE procedure PMC_ClientInit
77    END INTERFACE PMC_ClientInit
78
79    INTERFACE PMC_Set_DataArray_Name
80        MODULE procedure PMC_Set_DataArray_Name
81        MODULE procedure PMC_Set_DataArray_Name_LastEntry
82    END INTERFACE PMC_Set_DataArray_Name
83
84    INTERFACE PMC_C_Get_2D_index_list
85        MODULE procedure PMC_C_Get_2D_index_list
86    END INTERFACE PMC_C_Get_2D_index_list
87
88    INTERFACE PMC_C_clear_next_array_list
89        MODULE procedure PMC_C_clear_next_array_list
90    END INTERFACE PMC_C_clear_next_array_list
91
92    INTERFACE PMC_C_GetNextArray
93        MODULE procedure PMC_C_GetNextArray
94    END INTERFACE PMC_C_GetNextArray
95
96    INTERFACE PMC_C_Set_DataArray
97        MODULE procedure PMC_C_Set_DataArray_2d
98        MODULE procedure PMC_C_Set_DataArray_3d
99    END INTERFACE PMC_C_Set_DataArray
100
101    INTERFACE PMC_C_setInd_and_AllocMem
102        MODULE procedure PMC_C_setInd_and_AllocMem
103    END INTERFACE PMC_C_setInd_and_AllocMem
104
105    INTERFACE PMC_C_GetBuffer
106        MODULE procedure PMC_C_GetBuffer
107    END INTERFACE PMC_C_GetBuffer
108
109    INTERFACE PMC_C_PutBuffer
110        MODULE procedure PMC_C_PutBuffer
111    END INTERFACE PMC_C_PutBuffer
112
113    ! Public section
114
115    PUBLIC PMC_ClientInit , PMC_Set_DataArray_Name, PMC_C_Get_2D_index_list
116    PUBLIC PMC_C_GetNextArray, PMC_C_Set_DataArray, PMC_C_clear_next_array_list
117    PUBLIC PMC_C_setInd_and_AllocMem , PMC_C_GetBuffer, PMC_C_PutBuffer
118
119CONTAINS
120
121    SUBROUTINE PMC_ClientInit
122        IMPLICIT none
123
124        INTEGER                       :: i
125        INTEGER                       :: istat
126
127
128        ! Tailor MPI environment
129
130        me%model_comm = m_model_comm
131        me%inter_comm = m_to_server_comm
132
133        ! Get rank and size
134        CALL MPI_Comm_rank (me%model_comm, me%model_rank, istat);
135        CALL MPI_Comm_size (me%model_comm, me%model_npes, istat);
136        CALL MPI_Comm_remote_size (me%inter_comm, me%inter_npes, istat);
137
138        ! intra communicater is used for MPI_Get
139        CALL MPI_Intercomm_merge (me%inter_comm, .true., me%intra_comm, istat);
140        CALL MPI_Comm_rank (me%intra_comm, me%intra_rank, istat);
141        ALLOCATE (me%PEs(me%inter_npes))
142
143!
144!--     Allocate for all Server PEs an array of TYPE ArrayDef to store information of transfer array
145        do i=1,me%inter_npes
146           ALLOCATE(me%PEs(i)%array_list(PMC_MAX_ARRAY))
147        end do
148
149        if(me%model_rank == 0) write(0,'(a,5i6)') 'PMC_ClientInit ',me%model_rank,me%model_npes,me%inter_npes,me%intra_rank
150
151        return
152    END SUBROUTINE PMC_ClientInit
153
154    SUBROUTINE PMC_Set_DataArray_Name (ServerArrayDesc, ServerArrayName, ClientArrayDesc, ClientArrayName, istat)
155        IMPLICIT none
156        character(len=*),INTENT(IN)           :: ServerArrayName
157        character(len=*),INTENT(IN)           :: ServerArrayDesc
158        character(len=*),INTENT(IN)           :: ClientArrayName
159        character(len=*),INTENT(IN)           :: ClientArrayDesc
160        INTEGER,INTENT(OUT)                   :: istat
161
162        !-- local variables
163        type(DA_NameDef)                      :: myName
164        INTEGER                               :: myPe
165        INTEGER                               :: my_AddiArray=0
166
167        istat = PMC_STATUS_OK
168        if(len(trim(ServerArrayName)) > DA_Namelen .or.                                         &
169            len(trim(ClientArrayName)) > DA_Namelen)  then !Name too long
170            istat = PMC_DA_NAME_ERR
171        end if
172
173        if(m_model_rank == 0) then
174            myIndex = myIndex+1
175            myName%couple_index  = myIndex
176            myName%ServerDesc    = trim(ServerArrayDesc)
177            myName%NameOnServer  = trim(ServerArrayName)
178            myName%ClientDesc    = trim(ClientArrayDesc)
179            myName%NameOnClient  = trim(ClientArrayName)
180        end if
181
182        !   Broadcat to all Client PEs
183
184        CALL PMC_Bcast ( myName%couple_index,  0,   comm=m_model_comm)
185        CALL PMC_Bcast ( myName%ServerDesc, 0,      comm=m_model_comm)
186        CALL PMC_Bcast ( myName%NameOnServer,    0, comm=m_model_comm)
187        CALL PMC_Bcast ( myName%ClientDesc, 0,      comm=m_model_comm)
188        CALL PMC_Bcast ( myName%NameOnClient,    0, comm=m_model_comm)
189
190        !   Broadcat to all Server PEs
191
192        if(m_model_rank == 0) then
193            myPE = MPI_ROOT
194        else
195            myPE = MPI_PROC_NULL
196        endif
197        CALL PMC_Bcast ( myName%couple_index, myPE, comm=m_to_server_comm)
198        CALL PMC_Bcast ( myName%ServerDesc,   myPE, comm=m_to_server_comm)
199        CALL PMC_Bcast ( myName%NameOnServer, myPE, comm=m_to_server_comm)
200        CALL PMC_Bcast ( myName%ClientDesc,   myPE, comm=m_to_server_comm)
201        CALL PMC_Bcast ( myName%NameOnClient, myPE, comm=m_to_server_comm)
202
203        CALL PMC_G_SetName (me, myName%couple_index, myName%NameOnClient)
204
205        return
206    END SUBROUTINE PMC_Set_DataArray_Name
207
208    SUBROUTINE PMC_Set_DataArray_Name_LastEntry (LastEntry)
209        IMPLICIT none
210        LOGICAL,INTENT(IN),optional           :: LastEntry
211
212        !-- local variables
213        type(DA_NameDef)                      :: myName
214        INTEGER                               :: myPe
215
216        myName%couple_index  = -1
217
218        if(m_model_rank == 0) then
219            myPE = MPI_ROOT
220        else
221            myPE = MPI_PROC_NULL
222        endif
223        CALL PMC_Bcast ( myName%couple_index,  myPE, comm=m_to_server_comm)
224
225        return
226    END SUBROUTINE PMC_Set_DataArray_Name_LastEntry
227
228    SUBROUTINE PMC_C_Get_2D_index_list
229       IMPLICIT none
230
231       INTEGER                                 :: i,j,i2,nr,ierr
232       INTEGER                                 :: dummy
233       INTEGER                                 :: indWin          !: MPI window object
234       INTEGER                                 :: indWin2         !: MPI window object
235       INTEGER(KIND=MPI_ADDRESS_KIND)          :: win_size        !: Size of MPI window 1 (in bytes)
236       INTEGER(KIND=MPI_ADDRESS_KIND)          :: disp            !: Displacement Unit (Integer = 4, floating poit = 8
237       INTEGER,DIMENSION(me%inter_npes*2)      :: NrEle           !: Number of Elements of a horizontal slice
238       TYPE(PeDef),POINTER                     :: aPE             !: Pointer to PeDef structure
239       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize         !: Size of MPI window 2 (in bytes)
240       INTEGER,DIMENSION(:),POINTER            :: myInd
241
242!      CALL PMC_C_CGet_Rem_index_list
243
244       win_size = c_sizeof(dummy)
245       CALL MPI_Win_create (dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm, indWin, ierr);
246       CALL MPI_Win_fence (0, indWin, ierr)                ! Open Window on Server side
247       CALL MPI_Win_fence (0, indWin, ierr)                ! Close Window on Server Side and opem on Client side
248
249       do i=1,me%inter_npes
250          disp = me%model_rank*2
251          CALL MPI_Get (NrEle((i-1)*2+1),2,MPI_INTEGER,i-1,disp,2,MPI_INTEGER,indWin, ierr)
252       end do
253       CALL MPI_Win_fence (0, indWin, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
254
255       WinSize = 0
256       do i=1,me%inter_npes                         !Allocate memory for index array
257         aPE => me%PEs(i)
258         i2 = (i-1)*2+1
259         nr = NrEle(i2+1)
260         if(nr > 0)  then
261            ALLOCATE(aPE%locInd(nr))
262         else
263            NULLIFY (aPE%locInd)
264         endif
265         WinSize = max(nr,WinSize)                  !Maximum window size
266       end do
267
268       ALLOCATE(myInd(2*WinSize))
269       WinSize = 1
270
271!      local Buffer used in MPI_Get can but must not be inside the MPI Window
272!      Here, we use a dummy for MPI Window because the server PEs do not access the RMA window via MPI_get or MPI_Put
273
274       CALL MPI_Win_create (dummy, WinSize, iwp, MPI_INFO_NULL, me%intra_comm, indWin2, ierr);
275
276       CALL MPI_Win_fence (0, indWin2, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
277       CALL MPI_Win_fence (0, indWin2, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
278
279       do i=1,me%inter_npes
280          aPE => me%PEs(i)
281          nr = NrEle(i*2)
282          if(nr > 0 )  then
283             disp = NrEle(2*(i-1)+1)
284             CALL MPI_Win_lock (MPI_LOCK_SHARED , i-1, 0, indWin2, ierr)
285             CALL MPI_Get (myInd,2*nr,MPI_INTEGER,i-1,disp,2*nr,MPI_INTEGER,indWin2, ierr)
286             CALL MPI_Win_unlock (i-1, indWin2, ierr)
287             do j=1,nr
288                aPE%locInd(j)%i = myInd(2*j-1)
289                aPE%locInd(j)%j = myInd(2*j)
290             end do
291             aPE%NrEle = nr
292          else
293             aPE%NrEle = -1
294          end if
295       end do
296
297       CALL MPI_Barrier(me%intra_comm, ierr)   ! Dont know why, but this barrier is necessary before we can free the windows
298
299       CALL MPI_Win_free(indWin, ierr);
300       CALL MPI_Win_free(indWin2, ierr);
301       DEALLOCATE (myInd)
302
303       return
304    END SUBROUTINE PMC_C_Get_2D_index_list
305
306    SUBROUTINE PMC_C_clear_next_array_list
307       IMPLICIT none
308
309       next_array_in_list = 0
310
311       return
312    END SUBROUTINE PMC_C_clear_next_array_list
313
314!   List handling is still required to get minimal interaction with pmc_interface
315    LOGICAL function PMC_C_GetNextArray (myName)
316        character(len=*),INTENT(OUT)               :: myName
317
318        !-- local variables
319       TYPE(PeDef),POINTER          :: aPE
320       TYPE(ArrayDef),POINTER       :: ar
321
322       next_array_in_list = next_array_in_list+1
323
324!--    Array Names are the same on all client PE, so take first PE to get the name
325       aPE => me%PEs(1)
326
327       if(next_array_in_list > aPE%Nr_arrays) then
328          PMC_C_GetNextArray = .false.             !all arrays done
329          return
330       end if
331
332       ar  => aPE%array_list(next_array_in_list)
333
334       myName = ar%name
335
336       PMC_C_GetNextArray =  .true.                ! Return true if legal array
337       return
338    END function PMC_C_GetNextArray
339
340    SUBROUTINE PMC_C_Set_DataArray_2d (array)
341
342       IMPLICIT none
343
344       REAL(wp), INTENT(IN) ,DIMENSION(:,:) ::  array
345
346       INTEGER                              :: NrDims
347       INTEGER,DIMENSION (4)                :: dims
348       TYPE(c_ptr)                          :: array_adr
349       INTEGER                              :: i
350       TYPE(PeDef),POINTER                  :: aPE
351       TYPE(ArrayDef),POINTER               :: ar
352
353
354       dims = 1
355
356       NrDims    = 2
357       dims(1)   = size(array,1)
358       dims(2)   = size(array,2)
359
360       array_adr = c_loc(array)
361
362       do i=1,me%inter_npes
363          aPE => me%PEs(i)
364          ar  => aPE%array_list(next_array_in_list)
365          ar%NrDims    = NrDims
366          ar%A_dim     = dims
367          ar%data      = array_adr
368       end do
369
370       return
371    END SUBROUTINE PMC_C_Set_DataArray_2d
372
373    SUBROUTINE PMC_C_Set_DataArray_3d (array)
374
375       IMPLICIT none
376
377       REAL(wp),INTENT(IN),DIMENSION(:,:,:) ::  array
378
379       INTEGER                              ::  NrDims
380       INTEGER,DIMENSION (4)                ::  dims
381       TYPE(c_ptr)                          ::  array_adr
382       INTEGER                              ::  i
383       TYPE(PeDef),POINTER                  ::  aPE
384       TYPE(ArrayDef),POINTER               ::  ar
385
386       dims = 1
387
388       NrDims    = 3
389       dims(1)   = size(array,1)
390       dims(2)   = size(array,2)
391       dims(3)   = size(array,3)
392
393       array_adr = c_loc(array)
394
395       do i=1,me%inter_npes
396          aPE => me%PEs(i)
397          ar  => aPE%array_list(next_array_in_list)    !actual array is last array in list
398          ar%NrDims    = NrDims
399          ar%A_dim     = dims
400          ar%data      = array_adr
401       end do
402
403       return
404    END SUBROUTINE PMC_C_Set_DataArray_3d
405
406   SUBROUTINE PMC_C_setInd_and_AllocMem
407
408      IMPLICIT none
409
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
418      INTEGER                                 :: arlen, myIndex, tag
419      INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
420      TYPE(PeDef),POINTER                     :: aPE
421      TYPE(ArrayDef),POINTER                  :: ar
422      INTEGER,DIMENSION(1024)                 :: req
423      character(len=DA_Namelen)               :: myName
424      Type(c_ptr)                             :: base_ptr
425      REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_sc             !Base array
426      REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_cs             !Base array
427      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
428
429      myIndex = 0
430      bufsize = 8
431
432!--   Server to client direction
433
434!--   First stride, Compute size and set index
435
436      do i=1,me%inter_npes
437         aPE => me%PEs(i)
438         tag = 200
439
440         do j=1,aPE%Nr_arrays
441            ar  => aPE%array_list(j)
442
443            ! Receive Index from client
444            tag = tag+1
445            CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, MPI_STATUS_IGNORE, ierr)
446
447            if(ar%NrDims == 3) then
448               bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2)*ar%A_dim(3))    ! determine max, because client buffer is allocated only once
449            else
450               bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2))
451            end if
452            ar%RecvIndex = myIndex
453
454           end do
455      end do
456
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
465
466      do i=1,me%inter_npes
467         aPE => me%PEs(i)
468
469         do j=1,aPE%Nr_arrays
470            ar  => aPE%array_list(j)
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
545         end do
546      end do
547
548      return
549   END SUBROUTINE PMC_C_setInd_and_AllocMem
550
551   SUBROUTINE PMC_C_GetBuffer (WaitTime)
552
553      IMPLICIT none
554
555      REAL(wp), INTENT(OUT), optional   ::  WaitTime
556
557      !-- local variables
558      INTEGER                           ::  ip, ij, ierr, j
559      INTEGER                           ::  nr  ! Number of Elements to getb from server
560      INTEGER                           ::  myIndex
561      REAL(wp)                          ::  t1,t2
562      TYPE(PeDef),POINTER               ::  aPE
563      TYPE(ArrayDef),POINTER            ::  ar
564      INTEGER,DIMENSION(1)              ::  buf_shape
565      REAL(wp),POINTER,DIMENSION(:)     ::  buf
566      REAL(wp),POINTER,DIMENSION(:,:)   ::  data_2d
567      REAL(wp),POINTER,DIMENSION(:,:,:) ::  data_3d
568      character(len=DA_Namelen)         ::  myName
569      INTEGER(kind=MPI_ADDRESS_KIND)    ::  target_disp
570
571      t1 = PMC_Time()
572      CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for server to fill buffer
573      t2 = PMC_Time()-t1
574      if(present(WaitTime)) WaitTime = t2
575
576      CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for buffer is filled
577
578      do ip=1,me%inter_npes
579         aPE => me%PEs(ip)
580
581         do j=1,aPE%Nr_arrays
582            ar  => aPE%array_list(j)
583            if(ar%NrDims == 2) then
584               nr = aPE%NrEle
585            else if(ar%NrDims == 3) then
586               nr = aPE%NrEle*ar%A_dim(1)
587            end if
588
589            buf_shape(1) = nr
590            CALL c_f_pointer(ar%RecvBuf, buf, buf_shape)
591!
592!--         MPI passive target RMA
593            if(nr > 0)   then
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)
598            end if
599
600            myIndex = 1
601            if(ar%NrDims == 2) then
602
603               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
604               do ij=1,aPE%NrEle
605                  data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex)
606                  myIndex = myIndex+1
607               end do
608            else if(ar%NrDims == 3) then
609               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
610               do ij=1,aPE%NrEle
611                  data_3d(:,aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex:myIndex+ar%A_dim(1)-1)
612                  myIndex = myIndex+ar%A_dim(1)
613               end do
614            end if
615
616         end do
617      end do
618      return
619   END SUBROUTINE PMC_C_GetBuffer
620
621   SUBROUTINE PMC_C_PutBuffer (WaitTime)
622
623      IMPLICIT none
624
625      REAL(wp), INTENT(OUT), optional   :: WaitTime
626
627      !-- local variables
628      INTEGER                           ::  ip, ij, ierr, j
629      INTEGER                           ::  nr  ! Number of Elements to getb from server
630      INTEGER                           ::  myIndex
631      REAL(wp)                          ::  t1,t2
632      TYPE(PeDef),POINTER               ::  aPE
633      TYPE(ArrayDef),POINTER            ::  ar
634      INTEGER,DIMENSION(1)              ::  buf_shape
635      REAL(wp),POINTER,DIMENSION(:)     ::  buf
636      REAL(wp),POINTER,DIMENSION(:,:)   ::  data_2d
637      REAL(wp),POINTER,DIMENSION(:,:,:) ::  data_3d
638      character(len=DA_Namelen)         ::  myName
639      INTEGER(kind=MPI_ADDRESS_KIND)    ::  target_disp
640
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
645
646      do ip=1,me%inter_npes
647         aPE => me%PEs(ip)
648
649         do j=1,aPE%Nr_arrays
650            ar  => aPE%array_list(j)
651            myIndex=1
652            if(ar%NrDims == 2) then
653               buf_shape(1) = aPE%NrEle
654               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
655               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
656               do ij=1,aPE%NrEle
657                  buf(myIndex) = data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i)
658                  myIndex = myIndex+1
659               end do
660            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)
663               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
664               do ij=1,aPE%NrEle
665                  buf(myIndex:myIndex+ar%A_dim(1)-1) = data_3d(:,aPE%locInd(ij)%j,aPE%locInd(ij)%i)
666                  myIndex = myIndex+ar%A_dim(1)
667               end do
668            end if
669          end do
670      end do
671
672
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
675
676      return
677    END SUBROUTINE PMC_C_PutBuffer
678
679#endif
680END MODULE pmc_client
Note: See TracBrowser for help on using the repository browser.