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

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

last commit documented

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