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

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

added _mod string to several filenames to meet the naming convection for modules

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