source: palm/trunk/SOURCE/pmc_server.f90 @ 1791

Last change on this file since 1791 was 1791, checked in by raasch, 8 years ago

output of nesting informations of all domains; filling up redundant ghost points; renaming of variables, etc.; formatting cleanup

  • Property svn:keywords set to Id
File size: 29.4 KB
Line 
1MODULE pmc_server
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! Debug write-statements commented out
23!
24! Former revisions:
25! -----------------
26! $Id: pmc_server.f90 1791 2016-03-11 10:41:25Z 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! 1779 2016-03-03 08:01:28Z raasch
33! kind=dp replaced by wp,
34! error messages removed or changed to PALM style, dim_order removed
35! array management changed from linked list to sequential loop
36!
37! 1766 2016-02-29 08:37:15Z raasch
38! modifications to allow for using PALM's pointer version
39! +new routine pmc_s_set_active_data_array
40!
41! 1764 2016-02-28 12:45:19Z raasch
42! cpp-statement added (nesting can only be used in parallel mode)
43!
44! 1762 2016-02-25 12:31:13Z hellstea
45! Initial revision by K. Ketelsen
46!
47! Description:
48! ------------
49!
50! Server part of Palm Model Coupler
51!------------------------------------------------------------------------------!
52
53#if defined( __parallel )
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, PMC_MAX_MODELL,PMC_sort, DA_NameDef, DA_Desclen, DA_Namelen,       &
63                                         PMC_G_SetName, PeDef, ArrayDef, PMC_MAX_ARRAY
64   USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm,                     &
65                                         PMC_Server_for_Client, m_world_rank
66   USE   PMC_MPI_wrapper,          ONLY: PMC_Send_to_Client, PMC_Recv_from_Client, PMC_Bcast, PMC_Inter_Bcast,         &
67                                         PMC_Alloc_mem, PMC_Time
68
69   IMPLICIT none
70   PRIVATE
71   SAVE
72
73   TYPE ClientIndexDef
74      INTEGER                                        :: NrPoints
75      INTEGER,DIMENSION(:,:),allocatable             :: index_list_2d
76   END TYPE ClientIndexDef
77
78   TYPE(ClientDef),DIMENSION(PMC_MAX_MODELL)          :: Clients
79   TYPE(ClientIndexDef),DIMENSION(PMC_MAX_MODELL)     :: indClients
80
81   INTEGER                                            :: next_array_in_list = 0
82
83   PUBLIC PMC_Server_for_Client
84
85   INTERFACE PMC_ServerInit
86      MODULE procedure  PMC_ServerInit
87   END INTERFACE PMC_ServerInit
88
89    INTERFACE PMC_S_Set_2D_index_list
90        MODULE procedure PMC_S_Set_2D_index_list
91    END INTERFACE PMC_S_Set_2D_index_list
92
93    INTERFACE PMC_S_clear_next_array_list
94        MODULE procedure PMC_S_clear_next_array_list
95    END INTERFACE PMC_S_clear_next_array_list
96
97    INTERFACE PMC_S_GetNextArray
98        MODULE procedure PMC_S_GetNextArray
99    END INTERFACE PMC_S_GetNextArray
100
101    INTERFACE PMC_S_Set_DataArray
102        MODULE procedure PMC_S_Set_DataArray_2d
103        MODULE procedure PMC_S_Set_DataArray_3d
104    END INTERFACE PMC_S_Set_DataArray
105
106    INTERFACE PMC_S_setInd_and_AllocMem
107        MODULE procedure PMC_S_setInd_and_AllocMem
108    END INTERFACE PMC_S_setInd_and_AllocMem
109
110    INTERFACE PMC_S_FillBuffer
111        MODULE procedure PMC_S_FillBuffer
112    END INTERFACE PMC_S_FillBuffer
113
114    INTERFACE PMC_S_GetData_from_Buffer
115        MODULE procedure PMC_S_GetData_from_Buffer
116    END INTERFACE PMC_S_GetData_from_Buffer
117
118    INTERFACE PMC_S_Set_Active_data_array
119        MODULE procedure PMC_S_Set_Active_data_array
120    END INTERFACE PMC_S_Set_Active_data_array
121
122    ! PUBLIC section
123
124    PUBLIC PMC_ServerInit, PMC_S_Set_2D_index_list, PMC_S_GetNextArray, PMC_S_Set_DataArray
125    PUBLIC PMC_S_setInd_and_AllocMem, PMC_S_FillBuffer, PMC_S_GetData_from_Buffer, PMC_S_Set_Active_data_array
126    PUBLIC PMC_S_clear_next_array_list
127
128CONTAINS
129
130   SUBROUTINE PMC_ServerInit
131      IMPLICIT none
132      INTEGER                 :: i
133      INTEGER                 :: j
134      INTEGER                 :: ClientId
135      INTEGER                 :: istat
136
137      do i=1,size(PMC_Server_for_Client)-1
138!         if(m_model_comm == 0) write(0,*) 'PMC_Server: Initialize client Id',PMC_Server_for_Client(i)
139
140         ClientId = PMC_Server_for_Client(i)
141
142         Clients(ClientId)%model_comm = m_model_comm
143         Clients(ClientId)%inter_comm = m_to_client_comm(ClientId)
144
145         ! Get rank and size
146         CALL MPI_Comm_rank (Clients(ClientId)%model_comm, Clients(ClientId)%model_rank, istat);
147         CALL MPI_Comm_size (Clients(ClientId)%model_comm, Clients(ClientId)%model_npes, istat);
148         CALL MPI_Comm_remote_size (Clients(ClientId)%inter_comm, Clients(ClientId)%inter_npes, istat);
149
150         ! Intra communicater is used for MPI_Get
151         CALL MPI_Intercomm_merge (Clients(ClientId)%inter_comm, .false., Clients(ClientId)%intra_comm, istat);
152         CALL MPI_Comm_rank (Clients(ClientId)%intra_comm, Clients(ClientId)%intra_rank, istat);
153
154!         write(9,*) 'ClientId ',i,ClientId,m_world_rank, Clients(ClientId)%inter_npes
155
156         ALLOCATE (Clients(ClientId)%PEs(Clients(ClientId)%inter_npes))
157!
158!--      Allocate for all client PEs an array of TYPE ArrayDef to store information of transfer array
159         do j=1,Clients(ClientId)%inter_npes
160           Allocate(Clients(ClientId)%PEs(j)%array_list(PMC_MAX_ARRAY))
161         end do
162
163         CALL Get_DA_names_from_client (ClientId)
164      end do
165
166      return
167   END SUBROUTINE PMC_ServerInit
168
169    SUBROUTINE PMC_S_Set_2D_index_list (ClientId, index_list)
170        IMPLICIT none
171        INTEGER,INTENT(IN)                         :: ClientId
172        INTEGER,DIMENSION(:,:),INTENT(INOUT)       :: index_list      !Index list will be modified in sort, therefore INOUT
173
174        !-- Local variables
175        INTEGER                 :: ip,is,ie,ian,ic,n
176        INTEGER                 :: istat
177
178        if(m_model_rank == 0)   then
179            CALL PMC_sort (index_list, 6)                       ! Sort to ascending Server PE
180            is = 1
181
182            do ip=0,m_model_npes-1
183
184                !       Split into Server PEs
185                ie = is-1                                     !there may be no entry for this PE
186                if(is <= size(index_list,2) .and. ie >= 0)  then
187                    do while ( index_list(6,ie+1) == ip)
188                        ie = ie+1
189                        if( ie == size(index_list,2)) EXIT
190                    end do
191
192                    ian = ie-is+1
193                else
194                    is  = -1
195                    ie  = -2
196                    ian = 0
197                end if
198
199                !       Send data to other server PEs
200
201                if(ip == 0)   then
202                    indClients(ClientId)%NrPoints = ian
203                    if(ian > 0)   then
204                        ALLOCATE (indClients(ClientId)%index_list_2d(6,ian))
205                        indClients(ClientId)%index_list_2d(:,1:ian) = index_list(:,is:ie)
206                    end if
207                else
208                    CALL MPI_Send (ian, 1, MPI_INTEGER, ip, 1000, m_model_comm, istat)
209                    if(ian > 0) then
210                        CALL MPI_Send (index_list(1,is), 6*ian, MPI_INTEGER, ip, 1001,                  &
211                            m_model_comm, istat)
212                    end if
213                end if
214                is = ie+1
215            end do
216        else
217            CALL MPI_Recv (indClients(ClientId)%NrPoints, 1, MPI_INTEGER, 0, 1000, m_model_comm,     &
218                MPI_STATUS_IGNORE, istat)
219            ian = indClients(ClientId)%NrPoints
220             if(ian > 0) then
221                ALLOCATE(indClients(ClientId)%index_list_2d(6,ian))
222                CALL MPI_RECV (indClients(ClientId)%index_list_2d, 6*ian, MPI_INTEGER, 0, 1001,        &
223                    m_model_comm, MPI_STATUS_IGNORE, istat)
224            end if
225        end if
226
227        CALL Set_PE_index_list (ClientId,Clients(ClientId),indClients(ClientId)%index_list_2d,indClients(ClientId)%NrPoints)
228
229        return
230    END SUBROUTINE PMC_S_Set_2D_index_list
231
232    SUBROUTINE PMC_S_clear_next_array_list
233       IMPLICIT none
234
235       next_array_in_list = 0
236
237       return
238    END SUBROUTINE PMC_S_clear_next_array_list
239
240!   List handling is still required to get minimal interaction with pmc_interface
241    logical function PMC_S_GetNextArray (ClientId, myName)
242       INTEGER(iwp),INTENT(IN)                    :: ClientId
243       CHARACTER(len=*),INTENT(OUT)               :: myName
244
245!--    local variables
246       TYPE(PeDef),POINTER          :: aPE
247       TYPE(ArrayDef),POINTER       :: ar
248
249       next_array_in_list = next_array_in_list+1
250
251!--    Array Names are the same on all client PE, so take first PE to get the name
252       aPE => Clients(ClientId)%PEs(1)
253
254       if(next_array_in_list > aPE%Nr_arrays) then
255          PMC_S_GetNextArray = .false.              ! all arrays done
256          return
257       end if
258
259       ar  => aPE%array_list(next_array_in_list)
260       myName = ar%name
261
262       PMC_S_GetNextArray =  .true.                 ! Return true if legal array
263       return
264    END function PMC_S_GetNextArray
265
266    SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array, array_2 )
267
268        IMPLICIT none
269
270        INTEGER,INTENT(IN)                         :: ClientId
271        REAL(wp), INTENT(IN), DIMENSION(:,:)           ::  array
272        REAL(wp), INTENT(IN), DIMENSION(:,:), OPTIONAL ::  array_2
273
274        INTEGER                           :: NrDims
275        INTEGER,DIMENSION (4)             :: dims
276        TYPE(c_ptr)                       :: array_adr
277        TYPE(c_ptr)                       :: second_adr
278
279        dims = 1
280
281        NrDims    = 2
282        dims(1)   = size(array,1)
283        dims(2)   = size(array,2)
284        array_adr = c_loc(array)
285
286        IF ( PRESENT( array_2 ) )  THEN
287           second_adr = c_loc(array_2)
288           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
289        ELSE
290           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
291        ENDIF
292
293        return
294    END SUBROUTINE PMC_S_Set_DataArray_2d
295
296    SUBROUTINE PMC_S_Set_DataArray_3d (ClientId, array, nz_cl, nz, array_2 )
297
298        IMPLICIT none
299
300        INTEGER,INTENT(IN)                         :: ClientId
301        REAL(wp), INTENT(IN), DIMENSION(:,:,:)           ::  array
302        REAL(wp), INTENT(IN), DIMENSION(:,:,:), OPTIONAL ::  array_2
303        INTEGER,INTENT(IN)                         :: nz_cl
304        INTEGER,INTENT(IN)                         :: nz
305
306        INTEGER                           :: NrDims
307        INTEGER,DIMENSION (4)             :: dims
308        TYPE(c_ptr)                       :: array_adr
309        TYPE(c_ptr)                       :: second_adr
310
311        dims = 1
312
313        dims      = 0
314        NrDims    = 3
315        dims(1)   = size(array,1)
316        dims(2)   = size(array,2)
317        dims(3)   = size(array,3)
318        dims(4)   = nz_cl+dims(1)-nz                        ! works for first dimension 1:nz and 0:nz+1
319
320        array_adr = c_loc(array)
321
322!
323!--     In PALM's pointer version, two indices have to be stored internally.
324!--     The active address of the data array is set in swap_timelevel
325        IF ( PRESENT( array_2 ) )  THEN
326          second_adr = c_loc(array_2)
327          CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
328        ELSE
329           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
330        ENDIF
331
332        return
333   END SUBROUTINE PMC_S_Set_DataArray_3d
334
335   SUBROUTINE PMC_S_setInd_and_AllocMem (ClientId)
336
337      USE control_parameters,                                                  &
338          ONLY:  message_string
339
340      IMPLICIT none
341
342!
343!--   Naming convention for appendices:   _sc  -> server to client transfer
344!--                                       _cs  -> client to server transfer
345!--                                       Send -> Server to client transfer
346!--                                       Recv -> client to server transfer
347      INTEGER,INTENT(IN)                      :: ClientId
348
349      INTEGER                                 :: i, istat, ierr, j
350      INTEGER                                 :: arlen, myIndex, tag
351      INTEGER                                 :: rCount                    ! count MPI requests
352      INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
353      TYPE(PeDef),POINTER                     :: aPE
354      TYPE(ArrayDef),POINTER                  :: ar
355      CHARACTER(len=DA_Namelen)               :: myName
356      INTEGER,DIMENSION(1024)                 :: req
357      Type(c_ptr)                             :: base_ptr
358      REAL(wp),DIMENSION(:),POINTER,SAVE :: base_array_sc  !Base array for server to client transfer
359      REAL(wp),DIMENSION(:),POINTER,SAVE :: base_array_cs  !Base array for client to server transfer
360      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
361
362!
363!--   Server to client direction
364      myIndex = 1
365      rCount  = 0
366      bufsize = 8
367
368!
369!--   First stride: Compute size and set index
370      do i=1,Clients(ClientId)%inter_npes
371         aPE => Clients(ClientId)%PEs(i)
372         tag = 200
373         do j=1,aPE%Nr_arrays
374            ar  => aPE%array_list(j)
375            if(ar%NrDims == 2) then
376               arlen     = aPE%NrEle                              ! 2D
377            else if(ar%NrDims == 3) then
378               arlen     = aPE%NrEle * ar%A_dim(4);               ! 3D
379            else
380               arlen     = -1
381            end if
382            ar%SendIndex = myIndex
383
384            tag    = tag+1
385            rCount = rCount+1
386            CALL MPI_Isend (myIndex, 1, MPI_INTEGER, i-1, tag, Clients(ClientId)%inter_comm, req(rCount),ierr)
387
388            if(rCount == 1024) then                                  ! Maximum of 1024 outstanding requests
389               CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
390               rCount = 0;
391            end if
392
393            myIndex = myIndex+arlen
394            bufsize = bufsize+arlen
395            ar%SendSize = arlen
396
397         end do
398         if(rCount > 0) then                       ! Wait for all send completed
399            CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
400         end if
401      end do
402
403!
404!--   Create RMA (One Sided Communication) window for data buffer server to
405!--   client transfer.
406!--   The buffer of MPI_Get (counter part of transfer) can be PE-local, i.e.
407!--   it can but must not be part of the MPI RMA window.
408!--   Only one RMA window is required to prepare the data
409!--   for server -> client transfer on the server side and
410!--   for client -> server transfer on the client side
411      CALL PMC_Alloc_mem (base_array_sc, bufsize)
412      Clients(ClientId)%TotalBufferSize = bufsize*wp   !Total buffer size in Byte
413
414      WinSize = bufsize*wp
415      CALL MPI_Win_create (base_array_sc, WinSize, wp, MPI_INFO_NULL,          &
416                  Clients(ClientId)%intra_comm,  Clients(ClientId)%win_server_client, ierr)
417      CALL MPI_Win_fence (0, Clients(ClientId)%win_server_client, ierr);        !  Open Window to set data
418!
419!--   Second stride: Set Buffer pointer
420      do i=1,Clients(ClientId)%inter_npes
421         aPE => Clients(ClientId)%PEs(i)
422         do j=1,aPE%Nr_arrays
423            ar  => aPE%array_list(j)
424            ar%SendBuf = c_loc(base_array_sc(ar%SendIndex))
425            if(ar%SendIndex+ar%SendSize > bufsize) then
426               write(0,'(a,i4,4i7,1x,a)') 'Server Buffer too small ',i,ar%SendIndex,ar%SendSize,ar%SendIndex+ar%SendSize,bufsize,trim(ar%name)
427               CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
428            end if
429         end do
430      end do
431
432!--   Client to server direction
433
434      bufsize  = 8
435
436!--   First stride, Compute size and set index
437
438      do i=1,Clients(ClientId)%inter_npes
439         aPE => Clients(ClientId)%PEs(i)
440         tag = 300
441
442         do j=1,aPE%Nr_arrays
443            ar  => aPE%array_list(j)
444
445            ! Receive Index from client
446            tag = tag+1
447            CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, Clients(ClientId)%inter_comm, MPI_STATUS_IGNORE, ierr)
448
449            if(ar%NrDims == 3) then
450               bufsize = max(bufsize,aPE%NrEle * ar%A_dim(4))               ! 3D
451            else
452               bufsize = max(bufsize,aPE%NrEle)                             ! 2D
453            end if
454            ar%RecvIndex = myIndex
455          end do
456
457      end do
458
459!--   Create RMA (One Sided Communication) data buffer
460!--   The buffer for MPI_Get can be PE local, i.e. it can but must not be part of the MPI RMA window
461
462      CALL PMC_Alloc_mem (base_array_cs, bufsize, base_ptr)
463      Clients(ClientId)%TotalBufferSize = bufsize*wp       !Total buffer size in Byte
464
465      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)
466
467!--   Second stride, Set Buffer pointer
468
469      do i=1,Clients(ClientId)%inter_npes
470         aPE => Clients(ClientId)%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      return
479   END SUBROUTINE PMC_S_setInd_and_AllocMem
480
481   SUBROUTINE PMC_S_FillBuffer (ClientId, WaitTime)
482      IMPLICIT none
483      INTEGER,INTENT(IN)                  ::  ClientId
484      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
485
486      INTEGER                             ::  ip,ij,istat,ierr,j
487      INTEGER                             ::  myIndex
488      REAL(wp)                            ::  t1,t2
489      TYPE(PeDef),POINTER                 ::  aPE
490      TYPE(ArrayDef),POINTER              ::  ar
491      CHARACTER(len=DA_Namelen)           ::  myName
492      INTEGER,DIMENSION(1)                ::  buf_shape
493      REAL(wp), POINTER, DIMENSION(:)     ::  buf
494      REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
495      REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
496
497      t1 = PMC_Time()
498      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)              ! Wait for buffer empty
499      t2 = PMC_Time()
500      if(present(WaitTime)) WaitTime = t2-t1
501
502      do ip=1,Clients(ClientId)%inter_npes
503         aPE => Clients(ClientId)%PEs(ip)
504         do j=1,aPE%Nr_arrays
505            ar  => aPE%array_list(j)
506            myIndex=1
507            if(ar%NrDims == 2) then
508               buf_shape(1) = aPE%NrEle
509               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
510               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
511               do ij=1,aPE%NrEle
512                  buf(myIndex) = data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i)
513                  myIndex = myIndex+1
514               end do
515            else if(ar%NrDims == 3) then
516               buf_shape(1) = aPE%NrEle*ar%A_dim(4)
517               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
518               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
519               do ij=1,aPE%NrEle
520                  buf(myIndex:myIndex+ar%A_dim(4)-1) = data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i)
521                  myIndex = myIndex+ar%A_dim(4)
522               end do
523            end if
524          end do
525      end do
526
527      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)    ! buffer is filled
528
529      return
530   END SUBROUTINE PMC_S_FillBuffer
531
532   SUBROUTINE PMC_S_GetData_from_Buffer (ClientId, WaitTime)
533
534      IMPLICIT none
535
536      INTEGER,INTENT(IN)                  ::  ClientId
537      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
538
539      !-- local variables
540      INTEGER                             ::  ip,ij,istat,ierr,j
541      INTEGER                             ::  myIndex
542      INTEGER                             ::  nr
543      REAL(wp)                            ::  t1,t2
544      TYPE(PeDef),POINTER                 ::  aPE
545      TYPE(ArrayDef),POINTER              ::  ar
546      CHARACTER(len=DA_Namelen)           ::  myName
547      INTEGER,DIMENSION(1)                ::  buf_shape
548      REAL(wp), POINTER, DIMENSION(:)     ::  buf
549      REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
550      REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
551      INTEGER                             ::  target_pe
552      INTEGER(kind=MPI_ADDRESS_KIND)      ::  target_disp
553
554      t1 = PMC_Time()
555      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)                         ! Wait for client to fill buffer
556      t2 = PMC_Time()-t1
557      if(present(WaitTime)) WaitTime = t2
558
559!      CALL MPI_Win_fence (0, Clients(ClientId)%win_server_client, ierr)            ! Fence might do it, test later
560      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)                         ! Wait for buffer is filled
561
562      do ip=1,Clients(ClientId)%inter_npes
563         aPE => Clients(ClientId)%PEs(ip)
564         do j=1,aPE%Nr_arrays
565            ar  => aPE%array_list(j)
566
567            if(ar%RecvIndex < 0)  CYCLE
568
569            if(ar%NrDims == 2) then
570               nr = aPE%NrEle
571            else if(ar%NrDims == 3) then
572               nr = aPE%NrEle*ar%A_dim(4)
573            end if
574
575            buf_shape(1) = nr
576            CALL c_f_pointer(ar%RecvBuf, buf, buf_shape)
577!
578!--         MPI passive target RMA
579
580            if(nr > 0)   then
581               target_disp = ar%RecvIndex-1
582               target_pe = ip-1+m_model_npes                         ! client PEs are located behind server PEs
583               CALL MPI_Win_lock (MPI_LOCK_SHARED , target_pe, 0, Clients(ClientId)%win_server_client, ierr)
584               CALL MPI_Get (buf, nr, MPI_REAL, target_pe, target_disp, nr, MPI_REAL, Clients(ClientId)%win_server_client, ierr)
585               CALL MPI_Win_unlock (target_pe, Clients(ClientId)%win_server_client, ierr)
586            end if
587
588            myIndex=1
589            if(ar%NrDims == 2) then
590               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
591               do ij=1,aPE%NrEle
592                  data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex)
593                  myIndex = myIndex+1
594               end do
595            else if(ar%NrDims == 3) then
596               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
597               do ij=1,aPE%NrEle
598                  data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex:myIndex+ar%A_dim(4)-1)
599                  myIndex = myIndex+ar%A_dim(4)
600               end do
601            end if
602          end do
603      end do
604
605   END SUBROUTINE PMC_S_GetData_from_Buffer
606
607! Private SUBROUTINEs
608
609   SUBROUTINE Get_DA_names_from_client (ClientId)
610        IMPLICIT none
611        INTEGER,INTENT(IN)                    :: ClientId
612        !-- local variables
613        type(DA_NameDef)                      :: myName
614
615        !   Get Data Array Description and Name from Client
616
617        do
618            CALL PMC_Bcast ( myName%couple_index, 0, comm=m_to_client_comm(ClientId))
619            if(myName%couple_index == -1) EXIT
620            CALL PMC_Bcast ( myName%ServerDesc,   0, comm=m_to_client_comm(ClientId))
621            CALL PMC_Bcast ( myName%NameOnServer, 0, comm=m_to_client_comm(ClientId))
622            CALL PMC_Bcast ( myName%ClientDesc,   0, comm=m_to_client_comm(ClientId))
623            CALL PMC_Bcast ( myName%NameOnClient, 0, comm=m_to_client_comm(ClientId))
624
625            CALL PMC_G_SetName (clients(ClientID), myName%couple_index, myName%NameOnServer )
626        end do
627
628        return
629   END SUBROUTINE Get_DA_names_from_client
630
631   SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr)
632      IMPLICIT none
633
634      INTEGER,INTENT(IN)                      :: ClientId
635      INTEGER,INTENT(IN)                      :: NrDims
636      INTEGER,INTENT(IN),DIMENSION(:)         :: dims
637      TYPE(c_ptr),INTENT(IN)                  :: array_adr
638      TYPE(c_ptr),INTENT(IN),OPTIONAL         :: second_adr
639
640      INTEGER                                 :: i
641      TYPE(PeDef),POINTER                     :: aPE
642      TYPE(ArrayDef),POINTER                  :: ar
643      CHARACTER(len=DA_Namelen)               :: myName
644
645      !  Set Array for Client interPE 0
646
647       do i=1,Clients(ClientId)%inter_npes
648          aPE => Clients(ClientId)%PEs(i)
649          ar  => aPE%array_list(next_array_in_list)
650          ar%NrDims    = NrDims
651          ar%A_dim     = dims
652          ar%data      = array_adr
653          if(present(second_adr)) then
654             ar%po_data(1) = array_adr
655             ar%po_data(2) = second_adr
656          else
657             ar%po_data(1) = C_NULL_PTR
658             ar%po_data(2) = C_NULL_PTR
659          end if
660       end do
661
662      return
663   END SUBROUTINE PMC_S_SetArray
664
665
666   SUBROUTINE PMC_S_Set_Active_data_array (ClientId,iactive)
667      IMPLICIT none
668
669      INTEGER,INTENT(IN)                      :: ClientId
670      INTEGER,INTENT(IN)                      :: iactive
671
672!--   local variables
673      INTEGER                                 :: i, ip, j
674      TYPE(PeDef),POINTER                     :: aPE
675      TYPE(ArrayDef),POINTER                  :: ar
676      CHARACTER(len=DA_Namelen)               :: myName
677
678      do ip=1,Clients(ClientId)%inter_npes
679         aPE => Clients(ClientId)%PEs(ip)
680         do j=1,aPE%Nr_arrays
681            ar  => aPE%array_list(j)
682            if(iactive == 1 .OR. iactive == 2)   then
683               ar%data = ar%po_data(iactive)
684            end if
685         end do
686      end do
687
688      return
689   END SUBROUTINE PMC_S_Set_Active_data_array
690
691
692    SUBROUTINE Set_PE_index_list (ClientId, myClient,index_list,NrP)
693       IMPLICIT none
694
695       INTEGER,INTENT(IN)                      :: ClientId
696       TYPE(ClientDef),INTENT(INOUT)           :: myClient
697       INTEGER,INTENT(IN),DIMENSION(:,:)       :: index_list
698       INTEGER,INTENT(IN)                      :: NrP
699
700!--    local variables
701       INTEGER                                 :: i,j,ind,ierr,i2
702       TYPE(PeDef),POINTER                     :: aPE
703       INTEGER                                 :: RemPE
704       INTEGER,DIMENSION(myClient%inter_npes)  :: RemInd
705       INTEGER,DIMENSION(:),POINTER            :: RemIndw
706       INTEGER,DIMENSION(:),POINTER            :: RLdef
707       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
708       INTEGER                                 :: indWin,indWin2
709
710       ! First, count entries for every remote client PE
711
712       do i=1,myClient%inter_npes
713          aPE => myClient%PEs(i)
714          aPE%NrEle = 0
715       end do
716
717       do j=1,NrP                                ! loop over number of cells coarse grid
718          RemPE = index_list(5,j)+1              ! Pe number remote PE
719          aPE => myClient%PEs(RemPE)
720          aPE% NrEle = aPE% NrEle+1              ! Increment Number of elements for this client Pe
721       end do
722
723       do i=1,myClient%inter_npes
724          aPE => myClient%PEs(i)
725          ALLOCATE(aPE%locInd(aPE%NrEle))
726       end do
727
728       RemInd = 0
729
730       ! Second, Create lists
731
732       do j=1,NrP                                ! loop over number of cells coarse grid
733          RemPE = index_list(5,j)+1              ! Pe number remote PE
734          aPE => myClient%PEs(RemPE)
735          RemInd(RemPE)     = RemInd(RemPE)+1
736          ind               = RemInd(RemPE)
737          aPE%locInd(ind)%i = index_list(1,j)
738          aPE%locInd(ind)%j = index_list(2,j)
739       end do
740
741       !  Prepare Number of Elements for Client PEs
742       CALL PMC_Alloc_mem (RLdef, myClient%inter_npes*2)
743       WinSize = myClient%inter_npes*c_sizeof(i)*2   ! Number of Client PEs * size of INTEGER (i just arbitrary INTEGER)
744
745       CALL MPI_Win_create (RLdef, WinSize, iwp, MPI_INFO_NULL, myClient%intra_comm, indWin, ierr);
746       CALL MPI_Win_fence (0, indWin, ierr);         !  Open Window to set data
747
748       RLdef(1) = 0                                  ! Index on Remote PE 0
749       RLdef(2) = RemInd(1)                          ! Number of Elements on Rem PE 0
750
751       do i=2,myClient%inter_npes                    ! Reserve Buffer for index array
752          i2          = (i-1)*2+1
753          RLdef(i2)   = RLdef(i2-2) + RLdef(i2-1)*2  ! Index on Remote PE
754          RLdef(i2+1) = RemInd(i)                    ! Number of Elements on Remote PE
755       end do
756
757       CALL MPI_Win_fence (0, indWin, ierr);         ! Close Window to allow client to access data
758       CALL MPI_Win_fence (0, indWin, ierr);         ! Client has retrieved data
759
760       i2 = 2*myClient%inter_npes-1
761       WinSize = (RLdef(i2)+RLdef(i2+1))*2
762       WinSize = max(WinSize,1)                      ! Make sure, MPI_Alloc_mem works
763
764       CALL PMC_Alloc_mem (RemIndw, int(WinSize))
765
766       CALL MPI_Barrier (m_model_comm, ierr)
767       CALL MPI_Win_create (RemIndw, WinSize*c_sizeof(i), iwp, MPI_INFO_NULL, myClient%intra_comm, indWin2, ierr);
768
769       CALL MPI_Win_fence (0, indWin2, ierr);         !  Open Window to set data
770       do j=1,NrP                                ! this loop creates the 2D index list
771          RemPE = index_list(5,j)+1              ! Pe number remote PE
772          aPE => myClient%PEs(RemPE)
773          i2    = RemPE*2-1
774          ind   = RLdef(i2)+1
775          RemIndw(ind)   = index_list(3,j)
776          RemIndw(ind+1) = index_list(4,j)
777          RLdef(i2) = RLdef(i2)+2
778       end do
779       CALL MPI_Win_fence (0, indWin2, ierr);      !all data set
780
781       CALL MPI_Barrier(myClient%intra_comm, ierr) ! Dont know why, but this barrier is necessary before we can free the windows
782
783       CALL MPI_Win_free(indWin, ierr)
784       CALL MPI_Win_free(indWin2, ierr)
785
786!      Sollte funktionieren, Problem mit MPI implementation
787!      https://www.lrz.de/services/software/parallel/mpi/onesided
788!       CALL MPI_Free_mem (RemIndw, ierr)
789
790       return
791    END SUBROUTINE Set_PE_index_list
792
793#endif
794END MODULE pmc_server
Note: See TracBrowser for help on using the repository browser.