source: palm/trunk/SOURCE/pmc_server_mod.f90 @ 1851

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

last commit documented

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