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

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

preprocessor directives using machine dependent flags (lc, ibm, etc.) mostly removed from the code

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