source: palm/trunk/SOURCE/pmc_client_mod.f90 @ 1881

Last change on this file since 1881 was 1851, checked in by maronga, 8 years ago

last commit documented

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