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

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

pmc now runs with pointer version too

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