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

Last change on this file since 1763 was 1763, checked in by hellstea, 6 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 23.9 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!
23!
24! Former revisions:
25! -----------------
26! $Id: pmc_server.f90 1763 2016-02-25 13:00:19Z hellstea $
27!
28! 1762 2016-02-25 12:31:13Z hellstea
29! Initial revision by K. Ketelsen
30!
31! Description:
32! ------------
33!
34! Server part of Palm Model Coupler
35!------------------------------------------------------------------------------!
36
37   use, intrinsic :: iso_c_binding
38
39   USE  mpi
40   USE  kinds,                     ONLY: wp, iwp
41   USE  PMC_general,               ONLY: ClientDef, PMC_MAX_MODELL,PMC_sort, DA_NameDef, DA_Desclen, DA_Namelen,       &
42                                         PMC_G_SetName, PMC_G_GetName, PeDef, ArrayDef
43   USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm,                     &
44                                         PMC_Server_for_Client, m_world_rank
45   USE   PMC_MPI_wrapper,          ONLY: PMC_Send_to_Client, PMC_Recv_from_Client, PMC_Bcast, PMC_Inter_Bcast,         &
46                                         PMC_Alloc_mem, PMC_Time
47
48   IMPLICIT none
49   PRIVATE
50   SAVE
51
52   TYPE ClientIndexDef
53      INTEGER                                        :: NrPoints
54      INTEGER,DIMENSION(:,:),allocatable             :: index_list_2d
55   END TYPE ClientIndexDef
56
57   TYPE(ClientDef),DIMENSION(PMC_MAX_MODELL)          :: Clients
58   TYPE(ClientIndexDef),DIMENSION(PMC_MAX_MODELL)     :: indClients
59
60   PUBLIC PMC_Server_for_Client
61
62   INTEGER, PARAMETER :: dp = wp
63
64   ! INTERFACE section
65
66   INTERFACE PMC_ServerInit
67      MODULE procedure  PMC_ServerInit
68   END INTERFACE PMC_ServerInit
69
70    INTERFACE PMC_S_Set_2D_index_list
71        MODULE procedure PMC_S_Set_2D_index_list
72    END INTERFACE PMC_S_Set_2D_index_list
73
74    INTERFACE PMC_S_GetNextArray
75        MODULE procedure PMC_S_GetNextArray
76    END INTERFACE PMC_S_GetNextArray
77
78    INTERFACE PMC_S_Set_DataArray
79        MODULE procedure PMC_S_Set_DataArray_2d
80        MODULE procedure PMC_S_Set_DataArray_3d
81    END INTERFACE PMC_S_Set_DataArray
82
83    INTERFACE PMC_S_setInd_and_AllocMem
84        MODULE procedure PMC_S_setInd_and_AllocMem
85    END INTERFACE PMC_S_setInd_and_AllocMem
86
87    INTERFACE PMC_S_FillBuffer
88        MODULE procedure PMC_S_FillBuffer
89    END INTERFACE PMC_S_FillBuffer
90
91    INTERFACE PMC_S_GetData_from_Buffer
92        MODULE procedure PMC_S_GetData_from_Buffer
93    END INTERFACE PMC_S_GetData_from_Buffer
94
95    ! PUBLIC section
96
97    PUBLIC PMC_ServerInit, PMC_S_Set_2D_index_list, PMC_S_GetNextArray, PMC_S_Set_DataArray
98    PUBLIC PMC_S_setInd_and_AllocMem, PMC_S_FillBuffer, PMC_S_GetData_from_Buffer
99
100CONTAINS
101
102   SUBROUTINE PMC_ServerInit
103      IMPLICIT none
104      INTEGER                 :: i
105      INTEGER                 :: j
106      INTEGER                 :: ClientId
107      INTEGER                 :: istat
108
109      do i=1,size(PMC_Server_for_Client)-1
110         if(m_model_comm == 0) write(0,*) 'PMC_Server: Initialize client Id',PMC_Server_for_Client(i)
111
112         ClientId = PMC_Server_for_Client(i)
113
114         Clients(ClientId)%model_comm = m_model_comm
115         Clients(ClientId)%inter_comm = m_to_client_comm(ClientId)
116
117         ! Get rank and size
118         CALL MPI_Comm_rank (Clients(ClientId)%model_comm, Clients(ClientId)%model_rank, istat);
119         CALL MPI_Comm_size (Clients(ClientId)%model_comm, Clients(ClientId)%model_npes, istat);
120         CALL MPI_Comm_remote_size (Clients(ClientId)%inter_comm, Clients(ClientId)%inter_npes, istat);
121
122         ! Intra communicater is used for MPI_Get
123         CALL MPI_Intercomm_merge (Clients(ClientId)%inter_comm, .false., Clients(ClientId)%intra_comm, istat);
124         CALL MPI_Comm_rank (Clients(ClientId)%intra_comm, Clients(ClientId)%intra_rank, istat);
125
126         write(9,*) 'ClientId ',i,ClientId,m_world_rank, Clients(ClientId)%inter_npes
127
128         ALLOCATE (Clients(ClientId)%PEs(Clients(ClientId)%inter_npes))
129
130         do j=1,Clients(ClientId)%inter_npes                                ! Loop over all client PEs
131           NULLIFY(Clients(ClientId)%PEs(j)%Arrays)
132         end do
133
134         CALL Get_DA_names_from_client (ClientId)
135      end do
136
137      return
138   END SUBROUTINE PMC_ServerInit
139
140    SUBROUTINE PMC_S_Set_2D_index_list (ClientId, index_list)
141        IMPLICIT none
142        INTEGER,INTENT(IN)                         :: ClientId
143        INTEGER,DIMENSION(:,:),INTENT(INOUT)       :: index_list      !Index list will be modified in sort, therefore INOUT
144
145        !-- Local variables
146        INTEGER                 :: ip,is,ie,ian,ic,n
147        INTEGER                 :: istat
148
149        if(m_model_rank == 0)   then
150            CALL PMC_sort (index_list, 6)                       ! Sort to ascending Server PE
151            is = 1
152
153            do ip=0,m_model_npes-1
154
155                !       Split into Server PEs
156                ie = is-1                                     !there may be no entry for this PE
157                if(is <= size(index_list,2) .and. ie >= 0)  then
158                    do while ( index_list(6,ie+1) == ip)
159                        ie = ie+1
160                        if( ie == size(index_list,2)) EXIT
161                    end do
162
163                    ian = ie-is+1
164                else
165                    is  = -1
166                    ie  = -2
167                    ian = 0
168                end if
169
170                !       Send data to other server PEs
171
172                if(ip == 0)   then
173                    indClients(ClientId)%NrPoints = ian
174                    if(ian > 0)   then
175                        ALLOCATE (indClients(ClientId)%index_list_2d(6,ian))
176                        indClients(ClientId)%index_list_2d(:,1:ian) = index_list(:,is:ie)
177                    end if
178                else
179                    CALL MPI_Send (ian, 1, MPI_INTEGER, ip, 1000, m_model_comm, istat)
180                    if(ian > 0) then
181                        CALL MPI_Send (index_list(1,is), 6*ian, MPI_INTEGER, ip, 1001,                  &
182                            m_model_comm, istat)
183                    end if
184                end if
185                is = ie+1
186            end do
187        else
188            CALL MPI_Recv (indClients(ClientId)%NrPoints, 1, MPI_INTEGER, 0, 1000, m_model_comm,     &
189                MPI_STATUS_IGNORE, istat)
190            ian = indClients(ClientId)%NrPoints
191             if(ian > 0) then
192                ALLOCATE(indClients(ClientId)%index_list_2d(6,ian))
193                CALL MPI_RECV (indClients(ClientId)%index_list_2d, 6*ian, MPI_INTEGER, 0, 1001,        &
194                    m_model_comm, MPI_STATUS_IGNORE, istat)
195            end if
196        end if
197
198        CALL Set_PE_index_list (ClientId,Clients(ClientId),indClients(ClientId)%index_list_2d,indClients(ClientId)%NrPoints)
199
200        return
201    END SUBROUTINE PMC_S_Set_2D_index_list
202
203    logical function PMC_S_GetNextArray (ClientId, myName,Client_PeIndex)
204        INTEGER,INTENT(IN)                         :: ClientId
205        CHARACTER(len=*),INTENT(OUT)               :: myName
206
207        !-- local variables
208        INTEGER                      :: MyCoupleIndex
209        logical                      :: MyLast
210        CHARACTER(len=DA_Namelen)    :: loName
211        INTEGER,INTENT(IN),optional  :: Client_PeIndex
212
213        loName = ' '
214
215        CALL PMC_G_GetName (clients(ClientId), MyCoupleIndex, loName, MyLast, Client_PeIndex)
216
217        myName    = loName
218
219        PMC_S_GetNextArray = .NOT. MyLast                   ! Return true if valid array
220
221        return
222    END function PMC_S_GetNextArray
223
224    SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array)
225        IMPLICIT none
226        INTEGER,INTENT(IN)                         :: ClientId
227        REAL(kind=dp),INTENT(IN),DIMENSION(:,:)    :: array
228        !-- local variables
229        INTEGER                           :: NrDims
230        INTEGER,DIMENSION (4)             :: dims
231        INTEGER                           :: dim_order
232        TYPE(c_ptr)                       :: array_adr
233
234        dims = 1
235
236        NrDims    = 2
237        dims(1)   = size(array,1)
238        dims(2)   = size(array,2)
239        dim_order = 2
240
241        array_adr = c_loc(array)
242
243        CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
244
245        return
246    END SUBROUTINE PMC_S_Set_DataArray_2d
247
248    SUBROUTINE PMC_S_Set_DataArray_3d (ClientId, array, nz_cl, nz)
249        IMPLICIT none
250        INTEGER,INTENT(IN)                         :: ClientId
251        REAL(kind=dp),INTENT(IN),DIMENSION(:,:,:)  :: array
252        INTEGER,INTENT(IN)                         :: nz_cl
253        INTEGER,INTENT(IN)                         :: nz
254        !-- local variables
255        INTEGER                           :: NrDims
256        INTEGER,DIMENSION (4)             :: dims
257        INTEGER                           :: dim_order
258        TYPE(c_ptr)                       :: array_adr
259
260        dims = 1
261
262        dims      = 0
263        NrDims    = 3
264        dims(1)   = size(array,1)
265        dims(2)   = size(array,2)
266        dims(3)   = size(array,3)
267        dim_order = 33
268        dims(4)   = nz_cl+dims(1)-nz                        ! works for first dimension 1:nz and 0:nz+1
269
270        array_adr = c_loc(array)
271
272        CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
273
274        return
275   END SUBROUTINE PMC_S_Set_DataArray_3d
276
277   SUBROUTINE PMC_S_setInd_and_AllocMem (ClientId)
278      IMPLICIT none
279      INTEGER,INTENT(IN)                      :: ClientId
280
281      INTEGER                                 :: i, istat, ierr
282      INTEGER                                 :: arlen, myIndex, tag
283      INTEGER                                 :: rCount                    ! count MPI requests
284      INTEGER(kind=8)                         :: bufsize                   ! Size of MPI data Window
285      TYPE(PeDef),POINTER                     :: aPE
286      TYPE(ArrayDef),POINTER                  :: ar
287      CHARACTER(len=DA_Namelen)               :: myName
288      INTEGER,DIMENSION(1024)                 :: req
289      Type(c_ptr)                             :: base_ptr
290      REAL(kind=wp),DIMENSION(:),POINTER      :: base_array
291      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
292
293      myIndex = 1
294      rCount  = 0
295      bufsize = 8
296
297      ! First stride, Compute size and set index
298
299      do i=1,Clients(ClientId)%inter_npes
300         aPE => Clients(ClientId)%PEs(i)
301         tag = 200
302         do while (PMC_S_GetNextArray ( ClientId, myName,i))
303            ar  => aPE%Arrays
304            if(ar%dim_order == 2) then
305               arlen     = aPE%NrEle;                             ! 2D
306            else if(ar%dim_order == 33) then
307               arlen     = aPE%NrEle * ar%A_dim(4);               ! PALM 3D
308            else
309               arlen     = -1
310            end if
311            ar%BufIndex = myIndex
312
313            tag    = tag+1
314            rCount = rCount+1
315            CALL MPI_Isend (myIndex, 1, MPI_INTEGER, i-1, tag, Clients(ClientId)%inter_comm, req(rCount),ierr)
316
317            if(rCount == 1024) then                                  ! Maximum of 1024 outstanding requests
318               CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
319               rCount = 0;
320            end if
321
322            myIndex = myIndex+arlen
323            bufsize = bufsize+arlen
324            ar%BufSize = arlen
325
326         end do
327         if(rCount > 0) then                                          ! Wait for all send completed
328            CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
329         end if
330      end do
331
332      ! Create RMA (One Sided Communication) window for data buffer
333
334      CALL PMC_Alloc_mem (base_array, bufsize, base_ptr)
335      Clients(ClientId)%TotalBufferSize = bufsize*wp       !Total buffer size in Byte
336
337      WinSize = bufsize*wp
338!      write(9,*) 'PMC_S_SetInd_and_Mem ',m_model_rank,Clients(ClientId)%inter_npes,WinSize,bufsize
339      CALL MPI_Win_create (base_array, WinSize, wp, MPI_INFO_NULL, Clients(ClientId)%intra_comm, Clients(ClientId)%BufWin, ierr);
340      CALL MPI_Win_fence (0, Clients(ClientId)%BufWin, ierr);                    !  Open Window to set data
341      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)
342
343      ! Second stride, Set Buffer pointer
344
345      do i=1,Clients(ClientId)%inter_npes
346         aPE => Clients(ClientId)%PEs(i)
347         do while (PMC_S_GetNextArray ( ClientId, myName,i))
348            ar  => aPE%Arrays
349            ar%SendBuf = c_loc(base_array(ar%BufIndex))                         !kk Adressrechnung ueberlegen
350            if(ar%BufIndex+ar%BufSize > bufsize) then
351               write(0,'(a,i4,4i7,1x,a)') 'Buffer too small ',i,ar%BufIndex,ar%BufSize,ar%BufIndex+ar%BufSize,bufsize,trim(myName)
352               CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
353            end if
354         end do
355      end do
356
357      return
358   END SUBROUTINE PMC_S_setInd_and_AllocMem
359
360   SUBROUTINE PMC_S_FillBuffer (ClientId, WaitTime)
361      IMPLICIT none
362      INTEGER,INTENT(IN)                      :: ClientId
363      REAL(kind=dp),INTENT(OUT),optional      :: WaitTime
364
365      !-- local variables
366      INTEGER                                 :: ip,ij,istat,ierr
367      INTEGER                                 :: myIndex
368      REAL(kind=dp)                           :: t1,t2
369      TYPE(PeDef),POINTER                     :: aPE
370      TYPE(ArrayDef),POINTER                  :: ar
371      CHARACTER(len=DA_Namelen)               :: myName
372      INTEGER,DIMENSION(1)                    :: buf_shape
373      REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
374      REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
375      REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
376
377      t1 = PMC_Time()
378      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)              ! Wait for buffer empty
379      t2 = PMC_Time()
380      if(present(WaitTime)) WaitTime = t2-t1
381
382      do ip=1,Clients(ClientId)%inter_npes
383         aPE => Clients(ClientId)%PEs(ip)
384         do while (PMC_S_GetNextArray ( ClientId, myName,ip))
385            ar  => aPE%Arrays
386            myIndex=1
387            if(ar%dim_order == 2) then
388               buf_shape(1) = aPE%NrEle
389               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
390               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
391               do ij=1,aPE%NrEle
392                  buf(myIndex) = data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i)
393                  myIndex = myIndex+1
394               end do
395            else if(ar%dim_order == 33) then
396               buf_shape(1) = aPE%NrEle*ar%A_dim(4)
397               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
398               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
399               do ij=1,aPE%NrEle
400                  buf(myIndex:myIndex+ar%A_dim(4)-1) = data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i)
401                  myIndex = myIndex+ar%A_dim(4)
402               end do
403            else
404               write(0,*) "Illegal Order of Dimension ",ar%dim_order
405               CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
406
407            end if
408          end do
409      end do
410
411      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)              ! buffer is full
412
413      return
414   END SUBROUTINE PMC_S_FillBuffer
415
416   SUBROUTINE PMC_S_GetData_from_Buffer (ClientId, WaitTime)
417      IMPLICIT none
418      INTEGER,INTENT(IN)                      :: ClientId
419      REAL(kind=dp),INTENT(OUT),optional      :: WaitTime
420
421      !-- local variables
422      INTEGER                                 :: ip,ij,istat,ierr
423      INTEGER                                 :: myIndex
424      REAL(kind=dp)                           :: t1,t2
425      TYPE(PeDef),POINTER                     :: aPE
426      TYPE(ArrayDef),POINTER                  :: ar
427      CHARACTER(len=DA_Namelen)               :: myName
428      INTEGER,DIMENSION(1)                    :: buf_shape
429      REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
430      REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
431      REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
432
433      t1 = PMC_Time()
434      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)              ! Wait for MPI_Put from client
435      t2 = PMC_Time()
436      if(present(WaitTime)) WaitTime = t2-t1
437
438      do ip=1,Clients(ClientId)%inter_npes
439         aPE => Clients(ClientId)%PEs(ip)
440         do while (PMC_S_GetNextArray ( ClientId, myName,ip))
441            ar  => aPE%Arrays
442            myIndex=1
443            if(ar%dim_order == 2) then
444               buf_shape(1) = aPE%NrEle
445               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
446               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
447               do ij=1,aPE%NrEle
448                  data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex)
449                  myIndex = myIndex+1
450               end do
451            else if(ar%dim_order == 33) then
452               buf_shape(1) = aPE%NrEle*ar%A_dim(4)
453               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
454               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
455               do ij=1,aPE%NrEle
456                  data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex:myIndex+ar%A_dim(4)-1)
457                  myIndex = myIndex+ar%A_dim(4)
458               end do
459            else
460               write(0,*) "Illegal Order of Dimension ",ar%dim_order
461               CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
462
463            end if
464          end do
465      end do
466
467      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)              ! data copy finished, buffer is free for use agein
468
469        return
470   END SUBROUTINE PMC_S_GetData_from_Buffer
471
472! Private SUBROUTINEs
473
474   SUBROUTINE Get_DA_names_from_client (ClientId)
475        IMPLICIT none
476        INTEGER,INTENT(IN)                    :: ClientId
477        !-- local variables
478        type(DA_NameDef)                      :: myName
479
480        !   Get Data Array Description and Name from Client
481
482        do
483            CALL PMC_Bcast ( myName%couple_index, 0, comm=m_to_client_comm(ClientId))
484            if(myName%couple_index == -1) EXIT
485            CALL PMC_Bcast ( myName%ServerDesc,   0, comm=m_to_client_comm(ClientId))
486            CALL PMC_Bcast ( myName%NameOnServer, 0, comm=m_to_client_comm(ClientId))
487            CALL PMC_Bcast ( myName%ClientDesc,   0, comm=m_to_client_comm(ClientId))
488            CALL PMC_Bcast ( myName%NameOnClient, 0, comm=m_to_client_comm(ClientId))
489
490            CALL PMC_G_SetName (clients(ClientID), myName%couple_index, myName%NameOnServer )
491        end do
492
493        return
494   END SUBROUTINE Get_DA_names_from_client
495
496   SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
497      IMPLICIT none
498
499      INTEGER,INTENT(IN)                      :: ClientId
500      INTEGER,INTENT(IN)                      :: NrDims
501      INTEGER,INTENT(IN),DIMENSION(:)         :: dims
502      INTEGER,INTENT(IN)                      :: dim_order
503      TYPE(c_ptr),INTENT(IN)                  :: array_adr
504
505      INTEGER                                 :: i
506      TYPE(PeDef),POINTER                     :: aPE
507      TYPE(ArrayDef),POINTER                  :: ar
508      CHARACTER(len=DA_Namelen)               :: myName
509
510      !  Set Array for Client interPE 0
511
512       do i=1,Clients(ClientId)%inter_npes
513          aPE => Clients(ClientId)%PEs(i)
514          ar  => aPE%Arrays
515          ar%NrDims    = NrDims
516          ar%A_dim     = dims
517          ar%dim_order = dim_order
518          ar%data      = array_adr
519       end do
520
521      return
522   END SUBROUTINE PMC_S_SetArray
523
524
525    SUBROUTINE Set_PE_index_list (ClientId, myClient,index_list,NrP)
526       IMPLICIT none
527
528       INTEGER,INTENT(IN)                      :: ClientId
529       TYPE(ClientDef),INTENT(INOUT)           :: myClient
530       INTEGER,INTENT(IN),DIMENSION(:,:)       :: index_list
531       INTEGER,INTENT(IN)                      :: NrP
532
533!--    local variables
534       INTEGER                                 :: i,j,ind,ierr,i2
535       TYPE(PeDef),POINTER                     :: aPE
536       INTEGER                                 :: RemPE
537       INTEGER,DIMENSION(myClient%inter_npes)  :: RemInd
538       INTEGER,DIMENSION(:),POINTER            :: RemIndw
539       INTEGER,DIMENSION(:),POINTER            :: RLdef
540       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
541       INTEGER                                 :: indWin,indWin2
542
543       ! First, count entries for every remote client PE
544
545       do i=1,myClient%inter_npes
546          aPE => myClient%PEs(i)
547          aPE%NrEle = 0
548       end do
549
550       do j=1,NrP                                ! loop over number of cells coarse grid
551          RemPE = index_list(5,j)+1              ! Pe number remote PE
552          aPE => myClient%PEs(RemPE)
553          aPE% NrEle = aPE% NrEle+1              ! Increment Number of elements for this client Pe
554       end do
555
556       do i=1,myClient%inter_npes
557          aPE => myClient%PEs(i)
558          ALLOCATE(aPE%locInd(aPE%NrEle))
559       end do
560
561       RemInd = 0
562
563       ! Second, Create lists
564
565       do j=1,NrP                                ! loop over number of cells coarse grid
566          RemPE = index_list(5,j)+1              ! Pe number remote PE
567          aPE => myClient%PEs(RemPE)
568          RemInd(RemPE)     = RemInd(RemPE)+1
569          ind               = RemInd(RemPE)
570          aPE%locInd(ind)%i = index_list(1,j)
571          aPE%locInd(ind)%j = index_list(2,j)
572       end do
573
574       !  Prepare Number of Elements for Client PEs
575       CALL PMC_Alloc_mem (RLdef, myClient%inter_npes*2)
576       WinSize = myClient%inter_npes*c_sizeof(i)*2   ! Number of Client PEs * size of INTEGER (i just arbitrary INTEGER)
577
578       CALL MPI_Win_create (RLdef, WinSize, iwp, MPI_INFO_NULL, myClient%intra_comm, indWin, ierr);
579       CALL MPI_Win_fence (0, indWin, ierr);         !  Open Window to set data
580
581       RLdef(1) = 0                                  ! Index on Remote PE 0
582       RLdef(2) = RemInd(1)                          ! Number of Elements on Rem PE 0
583
584       do i=2,myClient%inter_npes                    ! Reserve Buffer for index array
585          i2          = (i-1)*2+1
586          RLdef(i2)   = RLdef(i2-2) + RLdef(i2-1)*2  ! Index on Remote PE
587          RLdef(i2+1) = RemInd(i)                    ! Number of Elements on Remote PE
588       end do
589
590       CALL MPI_Win_fence (0, indWin, ierr);         ! Close Window to allow client to access data
591       CALL MPI_Win_fence (0, indWin, ierr);         ! Client has retrieved data
592
593       i2 = 2*myClient%inter_npes-1
594       WinSize = (RLdef(i2)+RLdef(i2+1))*2
595       WinSize = max(WinSize,1)                      ! Make sure, MPI_Alloc_mem works
596
597       CALL PMC_Alloc_mem (RemIndw, int(WinSize))
598
599       CALL MPI_Barrier (m_model_comm, ierr)
600       CALL MPI_Win_create (RemIndw, WinSize*c_sizeof(i), iwp, MPI_INFO_NULL, myClient%intra_comm, indWin2, ierr);
601
602       CALL MPI_Win_fence (0, indWin2, ierr);         !  Open Window to set data
603       do j=1,NrP                                ! this loop creates the 2D index list
604          RemPE = index_list(5,j)+1              ! Pe number remote PE
605          aPE => myClient%PEs(RemPE)
606          i2    = RemPE*2-1
607          ind   = RLdef(i2)+1
608          RemIndw(ind)   = index_list(3,j)
609          RemIndw(ind+1) = index_list(4,j)
610          RLdef(i2) = RLdef(i2)+2
611       end do
612       CALL MPI_Win_fence (0, indWin2, ierr);      !all data set
613
614       CALL MPI_Barrier(myClient%intra_comm, ierr) ! Dont know why, but this barrier is necessary before we can free the windows
615
616       CALL MPI_Win_free(indWin, ierr)
617       CALL MPI_Win_free(indWin2, ierr)
618
619!      Sollte funktionieren, Problem mit MPI implementation
620!      https://www.lrz.de/services/software/parallel/mpi/onesided
621!       CALL MPI_Free_mem (RemIndw, ierr)
622
623       return
624    END SUBROUTINE Set_PE_index_list
625
626END MODULE pmc_server
Note: See TracBrowser for help on using the repository browser.