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

Last change on this file since 1792 was 1792, checked in by raasch, 6 years ago

last commit documented

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