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

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

pmc-change in server-client get-put, spectra-directives removed, spectra-package modularized

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