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

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

NetCDF routines modularized; new parameter netcdf_deflate; further changes in the pmc

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