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

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

last commit documented

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