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

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

update of the nested domain system + some bugfixes

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