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

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

update of the nested domain system + some bugfixes

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