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

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

pmc array management changed from linked list to sequential loop; further small changes and cosmetics for the pmc

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