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

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

last commit documented

  • Property svn:keywords set to Id
File size: 21.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!
23!
24! Former revisions:
25! -----------------
26! $Id: pmc_client.f90 1784 2016-03-06 19:14:40Z raasch $
27!
28! 1783 2016-03-06 18:36:17Z raasch
29! Bugfix: wrong data-type in MPI_WIN_CREATE replaced
30!
31! 1779 2016-03-03 08:01:28Z raasch
32! kind=dp replaced by wp, dim_order removed
33! array management changed from linked list to sequential loop
34!
35! 1764 2016-02-28 12:45:19Z raasch
36! cpp-statement added (nesting can only be used in parallel mode),
37! all kinds given in PALM style
38!
39! 1762 2016-02-25 12:31:13Z hellstea
40! Initial revision by K. Ketelsen
41!
42! Description:
43! ------------
44!
45! Client part of Palm Model Coupler
46!------------------------------------------------------------------------------!
47
48#if defined( __parallel )
49
50    use, intrinsic :: iso_c_binding
51
52#if defined( __lc )
53    USE MPI
54#else
55    INCLUDE "mpif.h"
56#endif
57    USE  kinds
58    USE  PMC_general,   ONLY: ClientDef, DA_NameDef, DA_Namelen, PMC_STATUS_OK, PMC_DA_NAME_ERR, PeDef, ArrayDef, &
59                                         DA_Desclen, DA_Namelen, PMC_G_SetName, PMC_MAX_ARRAY
60    USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_server_comm
61    USE  PMC_MPI_wrapper,           ONLY: PMC_Send_to_Server, PMC_Recv_from_Server, PMC_Time,                     &
62                                              PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem
63    IMPLICIT none
64    PRIVATE
65    SAVE
66
67    Type(ClientDef)                       :: me
68
69    INTEGER                               :: next_array_in_list = 0
70    INTEGER                               :: myIndex = 0                !Counter and unique number for Data Arrays
71
72    ! INTERFACE section
73
74    INTERFACE PMC_ClientInit
75        MODULE procedure PMC_ClientInit
76    END INTERFACE PMC_ClientInit
77
78    INTERFACE PMC_Set_DataArray_Name
79        MODULE procedure PMC_Set_DataArray_Name
80        MODULE procedure PMC_Set_DataArray_Name_LastEntry
81    END INTERFACE PMC_Set_DataArray_Name
82
83    INTERFACE PMC_C_Get_2D_index_list
84        MODULE procedure PMC_C_Get_2D_index_list
85    END INTERFACE PMC_C_Get_2D_index_list
86
87    INTERFACE PMC_C_clear_next_array_list
88        MODULE procedure PMC_C_clear_next_array_list
89    END INTERFACE PMC_C_clear_next_array_list
90
91    INTERFACE PMC_C_GetNextArray
92        MODULE procedure PMC_C_GetNextArray
93    END INTERFACE PMC_C_GetNextArray
94
95    INTERFACE PMC_C_Set_DataArray
96        MODULE procedure PMC_C_Set_DataArray_2d
97        MODULE procedure PMC_C_Set_DataArray_3d
98    END INTERFACE PMC_C_Set_DataArray
99
100    INTERFACE PMC_C_setInd_and_AllocMem
101        MODULE procedure PMC_C_setInd_and_AllocMem
102    END INTERFACE PMC_C_setInd_and_AllocMem
103
104    INTERFACE PMC_C_GetBuffer
105        MODULE procedure PMC_C_GetBuffer
106    END INTERFACE PMC_C_GetBuffer
107
108    INTERFACE PMC_C_PutBuffer
109        MODULE procedure PMC_C_PutBuffer
110    END INTERFACE PMC_C_PutBuffer
111
112    ! Public section
113
114    PUBLIC PMC_ClientInit , PMC_Set_DataArray_Name, PMC_C_Get_2D_index_list
115    PUBLIC PMC_C_GetNextArray, PMC_C_Set_DataArray, PMC_C_clear_next_array_list
116    PUBLIC PMC_C_setInd_and_AllocMem , PMC_C_GetBuffer, PMC_C_PutBuffer
117
118CONTAINS
119
120    SUBROUTINE PMC_ClientInit
121        IMPLICIT none
122
123        INTEGER                       :: i
124        INTEGER                       :: istat
125
126
127        ! Tailor MPI environment
128
129        me%model_comm = m_model_comm
130        me%inter_comm = m_to_server_comm
131
132        ! Get rank and size
133        CALL MPI_Comm_rank (me%model_comm, me%model_rank, istat);
134        CALL MPI_Comm_size (me%model_comm, me%model_npes, istat);
135        CALL MPI_Comm_remote_size (me%inter_comm, me%inter_npes, istat);
136
137        ! intra communicater is used for MPI_Get
138        CALL MPI_Intercomm_merge (me%inter_comm, .true., me%intra_comm, istat);
139        CALL MPI_Comm_rank (me%intra_comm, me%intra_rank, istat);
140        ALLOCATE (me%PEs(me%inter_npes))
141
142!
143!--     Allocate for all Server PEs an array of TYPE ArrayDef to store information of transfer array
144        do i=1,me%inter_npes
145           ALLOCATE(me%PEs(i)%array_list(PMC_MAX_ARRAY))
146        end do
147
148        if(me%model_rank == 0) write(0,'(a,5i6)') 'PMC_ClientInit ',me%model_rank,me%model_npes,me%inter_npes,me%intra_rank
149
150        return
151    END SUBROUTINE PMC_ClientInit
152
153    SUBROUTINE PMC_Set_DataArray_Name (ServerArrayDesc, ServerArrayName, ClientArrayDesc, ClientArrayName, istat)
154        IMPLICIT none
155        character(len=*),INTENT(IN)           :: ServerArrayName
156        character(len=*),INTENT(IN)           :: ServerArrayDesc
157        character(len=*),INTENT(IN)           :: ClientArrayName
158        character(len=*),INTENT(IN)           :: ClientArrayDesc
159        INTEGER,INTENT(OUT)                   :: istat
160
161        !-- local variables
162        type(DA_NameDef)                      :: myName
163        INTEGER                               :: myPe
164        INTEGER                               :: my_AddiArray=0
165
166        istat = PMC_STATUS_OK
167        if(len(trim(ServerArrayName)) > DA_Namelen .or.                                         &
168            len(trim(ClientArrayName)) > DA_Namelen)  then !Name too long
169            istat = PMC_DA_NAME_ERR
170        end if
171
172        if(m_model_rank == 0) then
173            myIndex = myIndex+1
174            myName%couple_index  = myIndex
175            myName%ServerDesc    = trim(ServerArrayDesc)
176            myName%NameOnServer  = trim(ServerArrayName)
177            myName%ClientDesc    = trim(ClientArrayDesc)
178            myName%NameOnClient  = trim(ClientArrayName)
179        end if
180
181        !   Broadcat to all Client PEs
182
183        CALL PMC_Bcast ( myName%couple_index,  0,   comm=m_model_comm)
184        CALL PMC_Bcast ( myName%ServerDesc, 0,      comm=m_model_comm)
185        CALL PMC_Bcast ( myName%NameOnServer,    0, comm=m_model_comm)
186        CALL PMC_Bcast ( myName%ClientDesc, 0,      comm=m_model_comm)
187        CALL PMC_Bcast ( myName%NameOnClient,    0, comm=m_model_comm)
188
189        !   Broadcat to all Server PEs
190
191        if(m_model_rank == 0) then
192            myPE = MPI_ROOT
193        else
194            myPE = MPI_PROC_NULL
195        endif
196        CALL PMC_Bcast ( myName%couple_index, myPE, comm=m_to_server_comm)
197        CALL PMC_Bcast ( myName%ServerDesc,   myPE, comm=m_to_server_comm)
198        CALL PMC_Bcast ( myName%NameOnServer, myPE, comm=m_to_server_comm)
199        CALL PMC_Bcast ( myName%ClientDesc,   myPE, comm=m_to_server_comm)
200        CALL PMC_Bcast ( myName%NameOnClient, myPE, comm=m_to_server_comm)
201
202        CALL PMC_G_SetName (me, myName%couple_index, myName%NameOnClient)
203
204        return
205    END SUBROUTINE PMC_Set_DataArray_Name
206
207    SUBROUTINE PMC_Set_DataArray_Name_LastEntry (LastEntry)
208        IMPLICIT none
209        LOGICAL,INTENT(IN),optional           :: LastEntry
210
211        !-- local variables
212        type(DA_NameDef)                      :: myName
213        INTEGER                               :: myPe
214
215        myName%couple_index  = -1
216
217        if(m_model_rank == 0) then
218            myPE = MPI_ROOT
219        else
220            myPE = MPI_PROC_NULL
221        endif
222        CALL PMC_Bcast ( myName%couple_index,  myPE, comm=m_to_server_comm)
223
224        return
225    END SUBROUTINE PMC_Set_DataArray_Name_LastEntry
226
227    SUBROUTINE PMC_C_Get_2D_index_list
228       IMPLICIT none
229
230       INTEGER                                 :: i,j,i2,nr,ierr
231       INTEGER                                 :: dummy
232       INTEGER                                 :: indWin          !: MPI window object
233       INTEGER                                 :: indWin2         !: MPI window object
234       INTEGER(KIND=MPI_ADDRESS_KIND)          :: win_size        !: Size of MPI window 1 (in bytes)
235       INTEGER(KIND=MPI_ADDRESS_KIND)          :: disp            !: Displacement Unit (Integer = 4, floating poit = 8
236       INTEGER,DIMENSION(me%inter_npes*2)      :: NrEle           !: Number of Elements of a horizontal slice
237       TYPE(PeDef),POINTER                     :: aPE             !: Pointer to PeDef structure
238       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize         !: Size of MPI window 2 (in bytes)
239       INTEGER,DIMENSION(:),POINTER            :: myInd
240
241!      CALL PMC_C_CGet_Rem_index_list
242
243       win_size = c_sizeof(dummy)
244       CALL MPI_Win_create (dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm, indWin, ierr);
245       CALL MPI_Win_fence (0, indWin, ierr)                ! Open Window on Server side
246       CALL MPI_Win_fence (0, indWin, ierr)                ! Close Window on Server Side and opem on Client side
247
248       do i=1,me%inter_npes
249          disp = me%model_rank*2
250          CALL MPI_Get (NrEle((i-1)*2+1),2,MPI_INTEGER,i-1,disp,2,MPI_INTEGER,indWin, ierr)
251       end do
252       CALL MPI_Win_fence (0, indWin, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
253
254       WinSize = 0
255       do i=1,me%inter_npes                         !Allocate memory for index array
256         aPE => me%PEs(i)
257         i2 = (i-1)*2+1
258         nr = NrEle(i2+1)
259         if(nr > 0)  then
260            ALLOCATE(aPE%locInd(nr))
261         else
262            NULLIFY (aPE%locInd)
263         endif
264         WinSize = max(nr,WinSize)                  !Maximum window size
265       end do
266
267       ALLOCATE(myInd(2*WinSize))
268       WinSize = 1
269
270!      local Buffer used in MPI_Get can but must not be inside the MPI Window
271!      Here, we use a dummy for MPI Window because the server PEs do not access the RMA window via MPI_get or MPI_Put
272
273       CALL MPI_Win_create (dummy, WinSize, iwp, MPI_INFO_NULL, me%intra_comm, indWin2, ierr);
274
275       CALL MPI_Win_fence (0, indWin2, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
276       CALL MPI_Win_fence (0, indWin2, ierr)    ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
277
278       do i=1,me%inter_npes
279          aPE => me%PEs(i)
280          nr = NrEle(i*2)
281          if(nr > 0 )  then
282             disp = NrEle(2*(i-1)+1)
283             CALL MPI_Win_lock (MPI_LOCK_SHARED , i-1, 0, indWin2, ierr)
284             CALL MPI_Get (myInd,2*nr,MPI_INTEGER,i-1,disp,2*nr,MPI_INTEGER,indWin2, ierr)
285             CALL MPI_Win_unlock (i-1, indWin2, ierr)
286             do j=1,nr
287                aPE%locInd(j)%i = myInd(2*j-1)
288                aPE%locInd(j)%j = myInd(2*j)
289             end do
290             aPE%NrEle = nr
291          else
292             aPE%NrEle = -1
293          end if
294       end do
295
296       CALL MPI_Barrier(me%intra_comm, ierr)   ! Dont know why, but this barrier is necessary before we can free the windows
297
298       CALL MPI_Win_free(indWin, ierr);
299       CALL MPI_Win_free(indWin2, ierr);
300       DEALLOCATE (myInd)
301
302       return
303    END SUBROUTINE PMC_C_Get_2D_index_list
304
305    SUBROUTINE PMC_C_clear_next_array_list
306       IMPLICIT none
307
308       next_array_in_list = 0
309
310       return
311    END SUBROUTINE PMC_C_clear_next_array_list
312
313!   List handling is still required to get minimal interaction with pmc_interface
314    LOGICAL function PMC_C_GetNextArray (myName)
315        character(len=*),INTENT(OUT)               :: myName
316
317        !-- local variables
318       TYPE(PeDef),POINTER          :: aPE
319       TYPE(ArrayDef),POINTER       :: ar
320
321       next_array_in_list = next_array_in_list+1
322
323!--    Array Names are the same on all client PE, so take first PE to get the name
324       aPE => me%PEs(1)
325
326       if(next_array_in_list > aPE%Nr_arrays) then
327          PMC_C_GetNextArray = .false.             !all arrays done
328          return
329       end if
330
331       ar  => aPE%array_list(next_array_in_list)
332
333       myName = ar%name
334
335       PMC_C_GetNextArray =  .true.                ! Return true if legal array
336       return
337    END function PMC_C_GetNextArray
338
339    SUBROUTINE PMC_C_Set_DataArray_2d (array)
340
341       IMPLICIT none
342
343       REAL(wp), INTENT(IN) ,DIMENSION(:,:) ::  array
344
345       INTEGER                              :: NrDims
346       INTEGER,DIMENSION (4)                :: dims
347       TYPE(c_ptr)                          :: array_adr
348       INTEGER                              :: i
349       TYPE(PeDef),POINTER                  :: aPE
350       TYPE(ArrayDef),POINTER               :: ar
351
352
353       dims = 1
354
355       NrDims    = 2
356       dims(1)   = size(array,1)
357       dims(2)   = size(array,2)
358
359       array_adr = c_loc(array)
360
361       do i=1,me%inter_npes
362          aPE => me%PEs(i)
363          ar  => aPE%array_list(next_array_in_list)    !actual array is last array in list
364          ar%NrDims    = NrDims
365          ar%A_dim     = dims
366          ar%data      = array_adr
367       end do
368
369       return
370    END SUBROUTINE PMC_C_Set_DataArray_2d
371
372    SUBROUTINE PMC_C_Set_DataArray_3d (array)
373
374       IMPLICIT none
375
376       REAL(wp),INTENT(IN),DIMENSION(:,:,:) ::  array
377
378       INTEGER                              ::  NrDims
379       INTEGER,DIMENSION (4)                ::  dims
380       TYPE(c_ptr)                          ::  array_adr
381       INTEGER                              ::  i
382       TYPE(PeDef),POINTER                  ::  aPE
383       TYPE(ArrayDef),POINTER               ::  ar
384
385       dims = 1
386
387       NrDims    = 3
388       dims(1)   = size(array,1)
389       dims(2)   = size(array,2)
390       dims(3)   = size(array,3)
391
392       array_adr = c_loc(array)
393
394       do i=1,me%inter_npes
395          aPE => me%PEs(i)
396          ar  => aPE%array_list(next_array_in_list)    !actual array is last array in list
397          ar%NrDims    = NrDims
398          ar%A_dim     = dims
399          ar%data      = array_adr
400       end do
401
402       return
403    END SUBROUTINE PMC_C_Set_DataArray_3d
404
405   SUBROUTINE PMC_C_setInd_and_AllocMem
406
407      IMPLICIT none
408
409      INTEGER                                 :: i, ierr, j
410      INTEGER                                 :: arlen, myIndex, tag
411      INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
412      TYPE(PeDef),POINTER                     :: aPE
413      TYPE(ArrayDef),POINTER                  :: ar
414      character(len=DA_Namelen)               :: myName
415      Type(c_ptr)                             :: base_ptr
416      REAL(kind=wp),DIMENSION(:),POINTER      :: base_array
417      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
418
419      myIndex = 0
420      bufsize = 8
421
422      ! First stride, Compute size and set index
423
424      do i=1,me%inter_npes
425         aPE => me%PEs(i)
426         tag = 200
427
428         do j=1,aPE%Nr_arrays
429            ar  => aPE%array_list(j)
430
431            ! Receive Index from client
432            tag = tag+1
433            CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, MPI_STATUS_IGNORE, ierr)
434
435            if(ar%NrDims == 3) then                    ! PALM has k in first dimension
436               bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2)*ar%A_dim(3))    ! determine max, because client buffer is allocated only once
437            else
438               bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2))
439            end if
440            ar%BufIndex = myIndex
441          end do
442      end do
443
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)
454
455      do i=1,me%inter_npes
456         aPE => me%PEs(i)
457
458         do j=1,aPE%Nr_arrays
459            ar  => aPE%array_list(j)
460            ar%SendBuf = base_ptr
461         end do
462      end do
463
464      return
465   END SUBROUTINE PMC_C_setInd_and_AllocMem
466
467   SUBROUTINE PMC_C_GetBuffer (WaitTime)
468
469      IMPLICIT none
470
471      REAL(wp), INTENT(OUT), optional   ::  WaitTime
472
473      !-- local variables
474      INTEGER                           ::  ip, ij, ierr, j
475      INTEGER                           ::  nr  ! Number of Elements to getb from server
476      INTEGER                           ::  myIndex
477      REAL(wp)                          ::  t1,t2
478      TYPE(PeDef),POINTER               ::  aPE
479      TYPE(ArrayDef),POINTER            ::  ar
480      INTEGER,DIMENSION(1)              ::  buf_shape
481      REAL(wp),POINTER,DIMENSION(:)     ::  buf
482      REAL(wp),POINTER,DIMENSION(:,:)   ::  data_2d
483      REAL(wp),POINTER,DIMENSION(:,:,:) ::  data_3d
484      character(len=DA_Namelen)         ::  myName
485      INTEGER(kind=MPI_ADDRESS_KIND)    ::  target_disp
486
487      t1 = PMC_Time()
488      CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for server to fill buffer
489      t2 = PMC_Time()-t1
490      if(present(WaitTime)) WaitTime = t2
491
492      CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for buffer is filled
493
494      do ip=1,me%inter_npes
495         aPE => me%PEs(ip)
496
497         do j=1,aPE%Nr_arrays
498            ar  => aPE%array_list(j)
499            if(ar%NrDims == 2) then
500               nr = aPE%NrEle
501            else if(ar%NrDims == 3) then
502               nr = aPE%NrEle*ar%A_dim(1)
503            end if
504
505            buf_shape(1) = nr
506            CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
507!
508!--         MPI passive target RMA
509            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)
514            end if
515
516            myIndex = 1
517            if(ar%NrDims == 2) then
518
519               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
520               do ij=1,aPE%NrEle
521                  data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex)
522                  myIndex = myIndex+1
523               end do
524            else if(ar%NrDims == 3) then
525               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
526               do ij=1,aPE%NrEle
527                  data_3d(:,aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex:myIndex+ar%A_dim(1)-1)
528                  myIndex = myIndex+ar%A_dim(1)
529               end do
530            end if
531
532         end do
533      end do
534      return
535   END SUBROUTINE PMC_C_GetBuffer
536
537   SUBROUTINE PMC_C_PutBuffer (WaitTime)
538
539      IMPLICIT none
540
541      REAL(wp), INTENT(OUT), optional   :: WaitTime
542
543      !-- local variables
544      INTEGER                           ::  ip, ij, ierr, j
545      INTEGER                           ::  nr  ! Number of Elements to getb from server
546      INTEGER                           ::  myIndex
547      REAL(wp)                          ::  t1,t2
548      TYPE(PeDef),POINTER               ::  aPE
549      TYPE(ArrayDef),POINTER            ::  ar
550      INTEGER,DIMENSION(1)              ::  buf_shape
551      REAL(wp),POINTER,DIMENSION(:)     ::  buf
552      REAL(wp),POINTER,DIMENSION(:,:)   ::  data_2d
553      REAL(wp),POINTER,DIMENSION(:,:,:) ::  data_3d
554      character(len=DA_Namelen)         ::  myName
555      INTEGER(kind=MPI_ADDRESS_KIND)    ::  target_disp
556
557
558      do ip=1,me%inter_npes
559         aPE => me%PEs(ip)
560
561         do j=1,aPE%Nr_arrays
562            ar  => aPE%array_list(j)
563            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
574               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
575               do ij=1,aPE%NrEle
576                  buf(myIndex) = data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i)
577                  myIndex = myIndex+1
578               end do
579            else if(ar%NrDims == 3) then
580               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
581               do ij=1,aPE%NrEle
582                  buf(myIndex:myIndex+ar%A_dim(1)-1) = data_3d(:,aPE%locInd(ij)%j,aPE%locInd(ij)%i)
583                  myIndex = myIndex+ar%A_dim(1)
584               end do
585            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
595          end do
596      end do
597
598
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
606
607      return
608    END SUBROUTINE PMC_C_PutBuffer
609
610#endif
611END MODULE pmc_client
Note: See TracBrowser for help on using the repository browser.