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

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

spectrum renamed spactra_par and further modularized, POINTER-attributes added in coupler-routines to avoid gfortran error messages

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