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

Last change on this file since 1833 was 1833, checked in by raasch, 5 years ago

spectrum renamed spactra_par and further modularized, POINTER-attributes added in coupler-routines to avoid gfortran error messages

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