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

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

last commit documented

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