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

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

last commit documented

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