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

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

last commit documented

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