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

Last change on this file since 1818 was 1818, checked in by maronga, 6 years ago

last commit documented / copyright update

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