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

Last change on this file since 1834 was 1834, checked in by raasch, 5 years ago

last commit documented

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