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

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

last commit documented

  • Property svn:keywords set to Id
File size: 30.2 KB
Line 
1 MODULE 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 1901 2016-05-04 15:39:38Z raasch $
27!
28! 1900 2016-05-04 15:27:53Z raasch
29! re-formatted to match PALM style
30!
31! 1850 2016-04-08 13:29:27Z maronga
32! Module renamed
33!
34!
35! 1833 2016-04-07 14:23:03Z raasch
36! gfortran requires pointer attributes for some array declarations,
37! long line wrapped
38!
39! 1808 2016-04-05 19:44:00Z raasch
40! MPI module used by default on all machines
41!
42! 1797 2016-03-21 16:50:28Z raasch
43! introduction of different datatransfer modes
44!
45! 1791 2016-03-11 10:41:25Z raasch
46! Debug write-statements commented out
47!
48! 1786 2016-03-08 05:49:27Z raasch
49! change in client-server data transfer: server now gets data from client
50! instead that client put's it to the server
51!
52! 1779 2016-03-03 08:01:28Z raasch
53! kind=dp replaced by wp,
54! error messages removed or changed to PALM style, dim_order removed
55! array management changed from linked list to sequential loop
56!
57! 1766 2016-02-29 08:37:15Z raasch
58! modifications to allow for using PALM's pointer version
59! +new routine pmc_s_set_active_data_array
60!
61! 1764 2016-02-28 12:45:19Z raasch
62! cpp-statement added (nesting can only be used in parallel mode)
63!
64! 1762 2016-02-25 12:31:13Z hellstea
65! Initial revision by K. Ketelsen
66!
67! Description:
68! ------------
69!
70! Server part of Palm Model Coupler
71!------------------------------------------------------------------------------!
72
73#if defined( __parallel )
74    USE, INTRINSIC ::  ISO_C_BINDING
75
76#if defined( __mpifh )
77    INCLUDE "mpif.h"
78#else
79    USE MPI
80#endif
81    USE kinds
82    USE pmc_general,                                                           &
83        ONLY: arraydef, clientdef, da_namedef, da_namelen, pedef,              &
84              pmc_g_setname, pmc_max_array, pmc_max_models, pmc_sort
85
86    USE pmc_handle_communicator,                                               &
87        ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm,        &
88              m_world_rank, pmc_server_for_client
89
90    USE pmc_mpi_wrapper,                                                       &
91        ONLY: pmc_alloc_mem, pmc_bcast, pmc_time
92
93   IMPLICIT NONE
94
95   PRIVATE
96   SAVE
97
98   TYPE clientindexdef
99      INTEGER                              ::  nrpoints       !<
100      INTEGER, DIMENSION(:,:), ALLOCATABLE ::  index_list_2d  !<
101   END TYPE clientindexdef
102
103   TYPE(clientdef), DIMENSION(pmc_max_models)      ::  clients     !<
104   TYPE(clientindexdef), DIMENSION(pmc_max_models) ::  indclients  !<
105
106   INTEGER ::  next_array_in_list = 0  !<
107
108
109   PUBLIC pmc_server_for_client
110
111
112   INTERFACE pmc_serverinit
113      MODULE PROCEDURE  pmc_serverinit
114   END INTERFACE pmc_serverinit
115
116    INTERFACE pmc_s_set_2d_index_list
117        MODULE PROCEDURE pmc_s_set_2d_index_list
118    END INTERFACE pmc_s_set_2d_index_list
119
120    INTERFACE pmc_s_clear_next_array_list
121        MODULE PROCEDURE pmc_s_clear_next_array_list
122    END INTERFACE pmc_s_clear_next_array_list
123
124    INTERFACE pmc_s_getnextarray
125        MODULE PROCEDURE pmc_s_getnextarray
126    END INTERFACE pmc_s_getnextarray
127
128    INTERFACE pmc_s_set_dataarray
129        MODULE PROCEDURE pmc_s_set_dataarray_2d
130        MODULE PROCEDURE pmc_s_set_dataarray_3d
131    END INTERFACE pmc_s_set_dataarray
132
133    INTERFACE pmc_s_setind_and_allocmem
134        MODULE PROCEDURE pmc_s_setind_and_allocmem
135    END INTERFACE pmc_s_setind_and_allocmem
136
137    INTERFACE pmc_s_fillbuffer
138        MODULE PROCEDURE pmc_s_fillbuffer
139    END INTERFACE pmc_s_fillbuffer
140
141    INTERFACE pmc_s_getdata_from_buffer
142        MODULE PROCEDURE pmc_s_getdata_from_buffer
143    END INTERFACE pmc_s_getdata_from_buffer
144
145    INTERFACE pmc_s_set_active_data_array
146        MODULE PROCEDURE pmc_s_set_active_data_array
147    END INTERFACE pmc_s_set_active_data_array
148
149    PUBLIC pmc_serverinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer,      &
150           pmc_s_getdata_from_buffer, pmc_s_getnextarray,                      &
151           pmc_s_setind_and_allocmem, pmc_s_set_active_data_array,             &
152           pmc_s_set_dataarray, pmc_s_set_2d_index_list
153
154 CONTAINS
155
156
157 SUBROUTINE pmc_serverinit
158
159    IMPLICIT NONE
160
161    INTEGER ::  clientid  !<
162    INTEGER ::  i         !<
163    INTEGER ::  j         !<
164    INTEGER ::  istat     !<
165
166
167    DO  i = 1, SIZE( pmc_server_for_client )-1
168
169       clientid = pmc_server_for_client( i )
170
171       clients(clientid)%model_comm = m_model_comm
172       clients(clientid)%inter_comm = m_to_client_comm(clientid)
173!
174!--    Get rank and size
175       CALL MPI_COMM_RANK( clients(clientid)%model_comm,                       &
176                           clients(clientid)%model_rank, istat )
177       CALL MPI_COMM_SIZE( clients(clientid)%model_comm,                       &
178                           clients(clientid)%model_npes, istat )
179       CALL MPI_COMM_REMOTE_SIZE( clients(clientid)%inter_comm,                &
180                                  clients(clientid)%inter_npes, istat )
181!
182!--    Intra communicater is used for MPI_GET
183       CALL MPI_INTERCOMM_MERGE( clients(clientid)%inter_comm, .FALSE.,        &
184                                 clients(clientid)%intra_comm, istat )
185       CALL MPI_COMM_RANK( clients(clientid)%intra_comm,                       &
186                           clients(clientid)%intra_rank, istat )
187
188       ALLOCATE( clients(clientid)%pes(clients(clientid)%inter_npes))
189!
190!--    Allocate array of TYPE arraydef for all client PEs to store information
191!--    of the transfer array
192       DO  j = 1, clients(clientid)%inter_npes
193         ALLOCATE( clients(clientid)%pes(j)%array_list(pmc_max_array) )
194       ENDDO
195
196       CALL get_da_names_from_client (clientid)
197
198    ENDDO
199
200 END SUBROUTINE pmc_serverinit
201
202
203
204 SUBROUTINE pmc_s_set_2d_index_list( clientid, index_list )
205
206     IMPLICIT NONE
207
208     INTEGER, INTENT(IN)                    :: clientid    !<
209     INTEGER, DIMENSION(:,:), INTENT(INOUT) :: index_list  !<
210
211     INTEGER ::  ian    !<
212     INTEGER ::  ic     !<
213     INTEGER ::  ie     !<
214     INTEGER ::  ip     !<
215     INTEGER ::  is     !<
216     INTEGER ::  istat  !<
217     INTEGER ::  n      !<
218
219
220     IF ( m_model_rank == 0 )  THEN
221!
222!--     Sort to ascending server PE
223        CALL pmc_sort( index_list, 6 )
224
225        is = 1
226        DO  ip = 0, m_model_npes-1
227!
228!--        Split into server PEs
229           ie = is - 1
230!
231!--        There may be no entry for this PE
232           IF ( is <= SIZE( index_list,2 )  .AND.  ie >= 0 )  THEN
233
234              DO WHILE ( index_list(6,ie+1 ) == ip )
235                 ie = ie + 1
236                 IF ( ie == SIZE( index_list,2 ) )  EXIT
237              ENDDO
238
239              ian = ie - is + 1
240
241           ELSE
242              is  = -1
243              ie  = -2
244              ian =  0
245           ENDIF
246!
247!--        Send data to other server PEs
248           IF ( ip == 0 )  THEN
249              indclients(clientid)%nrpoints = ian
250              IF ( ian > 0)  THEN
251                  ALLOCATE( indclients(clientid)%index_list_2d(6,ian) )
252                  indclients(clientid)%index_list_2d(:,1:ian) =                &
253                                                             index_list(:,is:ie)
254              ENDIF
255           ELSE
256              CALL MPI_SEND( ian, 1, MPI_INTEGER, ip, 1000, m_model_comm,      &
257                             istat )
258              IF ( ian > 0)  THEN
259                  CALL MPI_SEND( index_list(1,is), 6*ian, MPI_INTEGER, ip,  &
260                                 1001, m_model_comm, istat )
261              ENDIF
262           ENDIF
263           is = ie + 1
264
265        ENDDO
266
267     ELSE
268
269        CALL MPI_RECV( indclients(clientid)%nrpoints, 1, MPI_INTEGER, 0, 1000, &
270                       m_model_comm, MPI_STATUS_IGNORE, istat )
271        ian = indclients(clientid)%nrpoints
272
273        IF ( ian > 0 )  THEN
274           ALLOCATE( indclients(clientid)%index_list_2d(6,ian) )
275           CALL MPI_RECV( indclients(clientid)%index_list_2d, 6*ian,           &
276                          MPI_INTEGER, 0, 1001, m_model_comm,                  &
277                          MPI_STATUS_IGNORE, istat)
278        ENDIF
279
280     ENDIF
281
282     CALL set_pe_index_list( clientid, clients(clientid),                      &
283                             indclients(clientid)%index_list_2d,               &
284                             indclients(clientid)%nrpoints )
285
286 END SUBROUTINE pmc_s_set_2d_index_list
287
288
289
290 SUBROUTINE pmc_s_clear_next_array_list
291
292    IMPLICIT NONE
293
294    next_array_in_list = 0
295
296 END SUBROUTINE pmc_s_clear_next_array_list
297
298
299
300 LOGICAL FUNCTION pmc_s_getnextarray( clientid, myname )
301!
302!-- List handling is still required to get minimal interaction with
303!-- pmc_interface
304!-- TODO: what does "still" mean? Is there a chance to change this!
305    CHARACTER(LEN=*), INTENT(OUT) ::  myname    !<
306    INTEGER(iwp), INTENT(IN)      ::  clientid  !<
307
308    TYPE(arraydef), POINTER :: ar
309    TYPE(pedef), POINTER    :: ape
310
311    next_array_in_list = next_array_in_list + 1
312!
313!-- Array names are the same on all client PEs, so take first PE to get the name
314    ape => clients(clientid)%pes(1)
315
316    IF ( next_array_in_list > ape%nr_arrays )  THEN
317!
318!--    All arrays are done
319       pmc_s_getnextarray = .FALSE.
320       RETURN
321    ENDIF
322
323    ar => ape%array_list(next_array_in_list)
324    myname = ar%name
325!
326!-- Return true if legal array
327!-- TODO: what does this comment mean? Can there be non-legal arrays??
328    pmc_s_getnextarray = .TRUE.
329
330 END FUNCTION pmc_s_getnextarray
331
332
333
334 SUBROUTINE pmc_s_set_dataarray_2d( clientid, array, array_2 )
335
336    IMPLICIT NONE
337
338    INTEGER,INTENT(IN) ::  clientid  !<
339
340    REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER           ::  array    !<
341    REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER, OPTIONAL ::  array_2  !<
342
343    INTEGER               ::  nrdims      !<
344    INTEGER, DIMENSION(4) ::  dims        !<
345    TYPE(C_PTR)           ::  array_adr   !<
346    TYPE(C_PTR)           ::  second_adr  !<
347
348
349    dims      = 1
350    nrdims    = 2
351    dims(1)   = SIZE( array,1 )
352    dims(2)   = SIZE( array,2 )
353    array_adr = C_LOC( array )
354
355    IF ( PRESENT( array_2 ) )  THEN
356       second_adr = C_LOC(array_2)
357       CALL pmc_s_setarray( clientid, nrdims, dims, array_adr,                 &
358                            second_adr = second_adr)
359    ELSE
360       CALL pmc_s_setarray( clientid, nrdims, dims, array_adr )
361    ENDIF
362
363 END SUBROUTINE pmc_s_set_dataarray_2d
364
365
366
367 SUBROUTINE pmc_s_set_dataarray_3d( clientid, array, nz_cl, nz, array_2 )
368
369    IMPLICIT NONE
370
371    INTEGER, INTENT(IN) ::  clientid  !<
372    INTEGER, INTENT(IN) ::  nz        !<
373    INTEGER, INTENT(IN) ::  nz_cl     !<
374
375    REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER           ::  array    !<
376    REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER, OPTIONAL ::  array_2  !<
377
378    INTEGER               ::  nrdims      !<
379    INTEGER, DIMENSION(4) ::  dims        !<
380    TYPE(C_PTR)           ::  array_adr   !<
381    TYPE(C_PTR)           ::  second_adr  !<
382
383!-- TODO: the next assignment seems to be obsolete. Please check!
384    dims      = 1
385    dims      = 0
386    nrdims    = 3
387    dims(1)   = SIZE( array,1 )
388    dims(2)   = SIZE( array,2 )
389    dims(3)   = SIZE( array,3 )
390    dims(4)   = nz_cl+dims(1)-nz  ! works for first dimension 1:nz and 0:nz+1
391
392    array_adr = C_LOC(array)
393
394!
395!-- In PALM's pointer version, two indices have to be stored internally.
396!-- The active address of the data array is set in swap_timelevel.
397    IF ( PRESENT( array_2 ) )  THEN
398      second_adr = C_LOC( array_2 )
399      CALL pmc_s_setarray( clientid, nrdims, dims, array_adr,                  &
400                           second_adr = second_adr)
401    ELSE
402       CALL pmc_s_setarray( clientid, nrdims, dims, array_adr )
403    ENDIF
404
405 END SUBROUTINE pmc_s_set_dataarray_3d
406
407
408
409 SUBROUTINE pmc_s_setind_and_allocmem( clientid )
410
411    USE control_parameters,                                                    &
412        ONLY:  message_string
413
414    IMPLICIT NONE
415
416!
417!-- Naming convention for appendices:   _sc  -> server to client transfer
418!--                                     _cs  -> client to server transfer
419!--                                     send -> server to client transfer
420!--                                     recv -> client to server transfer
421    INTEGER, INTENT(IN) ::  clientid  !<
422
423    INTEGER                        ::  arlen    !<
424    INTEGER                        ::  i        !<
425    INTEGER                        ::  ierr     !<
426    INTEGER                        ::  istat    !<
427    INTEGER                        ::  j        !<
428    INTEGER                        ::  myindex  !<
429    INTEGER                        ::  rcount   !< count MPI requests
430    INTEGER                        ::  tag      !<
431
432    INTEGER(idp)                   ::  bufsize  !< size of MPI data window
433    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
434
435    INTEGER, DIMENSION(1024)       ::  req      !<
436
437    TYPE(C_PTR)             ::  base_ptr  !<
438    TYPE(pedef), POINTER    ::  ape       !<
439    TYPE(arraydef), POINTER ::  ar        !<
440
441    REAL(wp),DIMENSION(:), POINTER, SAVE ::  base_array_sc  !< base array for server to client transfer
442    REAL(wp),DIMENSION(:), POINTER, SAVE ::  base_array_cs  !< base array for client to server transfer
443
444!
445!-- Server to client direction
446    myindex = 1
447    rcount  = 0
448    bufsize = 8
449
450!
451!-- First stride: compute size and set index
452    DO  i = 1, clients(clientid)%inter_npes
453
454       ape => clients(clientid)%pes(i)
455       tag = 200
456
457       DO  j = 1, ape%nr_arrays
458
459          ar  => ape%array_list(j)
460          IF ( ar%nrdims == 2 )  THEN
461             arlen = ape%nrele
462          ELSEIF ( ar%nrdims == 3 )  THEN
463             arlen = ape%nrele * ar%a_dim(4)
464          ELSE
465             arlen = -1
466          ENDIF
467          ar%sendindex = myindex
468
469          tag    = tag + 1
470          rcount = rcount + 1
471          CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag,                   &
472                          clients(clientid)%inter_comm, req(rcount), ierr )
473!
474!--       Maximum of 1024 outstanding requests
475!--       TODO: what does this limit means?
476          IF ( rcount == 1024 )  THEN
477             CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
478             rcount = 0
479          ENDIF
480
481          myindex = myindex + arlen
482          bufsize = bufsize + arlen
483          ar%sendsize = arlen
484
485       ENDDO
486
487       IF ( rcount > 0 )  THEN
488          CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
489       ENDIF
490
491    ENDDO
492
493!
494!-- Create RMA (One Sided Communication) window for data buffer server to
495!-- client transfer.
496!-- The buffer of MPI_GET (counterpart of transfer) can be PE-local, i.e.
497!-- it can but must not be part of the MPI RMA window. Only one RMA window is
498!-- required to prepare the data for
499!--                       server -> client transfer on the server side
500!-- and for
501!--                       client -> server transfer on the client side
502    CALL pmc_alloc_mem( base_array_sc, bufsize )
503    clients(clientid)%totalbuffersize = bufsize * wp
504
505    winsize = bufsize * wp
506    CALL MPI_WIN_CREATE( base_array_sc, winsize, wp, MPI_INFO_NULL,            &
507                         clients(clientid)%intra_comm,                         &
508                         clients(clientid)%win_server_client, ierr )
509!
510!-- Open window to set data
511    CALL MPI_WIN_FENCE( 0, clients(clientid)%win_server_client, ierr )
512!
513!-- Second stride: set buffer pointer
514    DO  i = 1, clients(clientid)%inter_npes
515
516       ape => clients(clientid)%pes(i)
517
518       DO  j = 1, ape%nr_arrays
519
520          ar => ape%array_list(j)
521          ar%sendbuf = C_LOC( base_array_sc(ar%sendindex) )
522
523!--       TODO: replace this by standard PALM error message using the message routine
524          IF ( ar%sendindex + ar%sendsize > bufsize )  THEN
525             write(0,'(a,i4,4i7,1x,a)') 'Server Buffer too small ',i,        &
526                ar%sendindex,ar%sendsize,ar%sendindex+ar%sendsize,bufsize,trim(ar%name)
527             CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
528          ENDIF
529       ENDDO
530    ENDDO
531
532!
533!-- Client to server direction
534    bufsize = 8
535!
536!-- First stride: compute size and set index
537    DO  i = 1, clients(clientid)%inter_npes
538
539       ape => clients(clientid)%pes(i)
540       tag = 300
541
542       DO  j = 1, ape%nr_arrays
543
544          ar => ape%array_list(j)
545!
546!--       Receive index from client
547          tag = tag + 1
548          CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag,                    &
549                         clients(clientid)%inter_comm, MPI_STATUS_IGNORE, ierr )
550
551          IF ( ar%nrdims == 3 )  THEN
552             bufsize = MAX( bufsize, ape%nrele * ar%a_dim(4) )
553          ELSE
554             bufsize = MAX( bufsize, ape%nrele )
555          ENDIF
556          ar%recvindex = myindex
557
558        ENDDO
559
560    ENDDO
561
562!
563!-- Create RMA (one sided communication) data buffer.
564!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of
565!-- the MPI RMA window
566    CALL pmc_alloc_mem( base_array_cs, bufsize, base_ptr )
567    clients(clientid)%totalbuffersize = bufsize * wp
568
569    CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
570!
571!-- Second stride: set buffer pointer
572    DO  i = 1, clients(clientid)%inter_npes
573
574       ape => clients(clientid)%pes(i)
575
576       DO  j = 1, ape%nr_arrays
577          ar => ape%array_list(j)
578          ar%recvbuf = base_ptr
579       ENDDO
580
581    ENDDO
582
583 END SUBROUTINE pmc_s_setind_and_allocmem
584
585
586
587 SUBROUTINE pmc_s_fillbuffer( clientid, waittime )
588
589    IMPLICIT NONE
590
591    INTEGER, INTENT(IN)             ::  clientid  !<
592
593    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
594
595    INTEGER               ::  ierr     !<
596    INTEGER               ::  ij       !<
597    INTEGER               ::  ip       !<
598    INTEGER               ::  istat    !<
599    INTEGER               ::  j        !<
600    INTEGER               ::  myindex  !<
601
602    INTEGER, DIMENSION(1) ::  buf_shape
603
604    REAL(wp)                            ::  t1       !<
605    REAL(wp)                            ::  t2       !<
606    REAL(wp), POINTER, DIMENSION(:)     ::  buf      !<
607    REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d  !<
608    REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d  !<
609
610    TYPE(pedef), POINTER    ::  ape  !<
611    TYPE(arraydef), POINTER ::  ar   !<
612
613!
614!-- Synchronization of the model is done in pmci_client_synchronize and
615!-- pmci_server_synchronize. Therefor the RMA window can be filled without
616!-- sychronization at this point and a barrier is not necessary.
617!-- Please note that waittime has to be set in pmc_s_fillbuffer AND
618!-- pmc_c_getbuffer
619    IF ( PRESENT( waittime) )  THEN
620      t1 = pmc_time()
621      CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
622      t2 = pmc_time()
623      waittime = t2- t1
624    ENDIF
625
626    DO  ip = 1, clients(clientid)%inter_npes
627
628       ape => clients(clientid)%pes(ip)
629
630       DO  j = 1, ape%nr_arrays
631
632          ar => ape%array_list(j)
633          myindex = 1
634
635          IF ( ar%nrdims == 2 )  THEN
636
637             buf_shape(1) = ape%nrele
638             CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
639             CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
640             DO  ij = 1, ape%nrele
641                buf(myindex) = data_2d(ape%locind(ij)%j,ape%locind(ij)%i)
642                myindex = myindex + 1
643             ENDDO
644
645          ELSEIF ( ar%nrdims == 3 )  THEN
646
647             buf_shape(1) = ape%nrele*ar%a_dim(4)
648             CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
649             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
650             DO  ij = 1, ape%nrele
651                buf(myindex:myindex+ar%a_dim(4)-1) =                           &
652                        data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i)
653                myindex = myindex + ar%a_dim(4)
654             ENDDO
655
656          ENDIF
657
658        ENDDO
659
660    ENDDO
661!
662!-- Buffer is filled
663    CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
664
665 END SUBROUTINE pmc_s_fillbuffer
666
667
668
669 SUBROUTINE pmc_s_getdata_from_buffer( clientid, waittime )
670
671    IMPLICIT NONE
672
673    INTEGER, INTENT(IN)             ::  clientid  !<
674    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
675
676    INTEGER                        ::  ierr         !<
677    INTEGER                        ::  ij           !<
678    INTEGER                        ::  ip           !<
679    INTEGER                        ::  istat        !<
680    INTEGER                        ::  j            !<
681    INTEGER                        ::  myindex      !<
682    INTEGER                        ::  nr           !<
683    INTEGER                        ::  target_pe    !<
684    INTEGER(kind=MPI_ADDRESS_KIND) ::  target_disp  !<
685
686    INTEGER, DIMENSION(1)          ::  buf_shape    !<
687
688    REAL(wp)                            ::  t1       !<
689    REAL(wp)                            ::  t2       !<
690    REAL(wp), POINTER, DIMENSION(:)     ::  buf      !<
691    REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d  !<
692    REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d  !<
693
694    TYPE(pedef), POINTER    ::  ape  !<
695    TYPE(arraydef), POINTER ::  ar   !<
696
697
698    t1 = pmc_time()
699!
700!-- Wait for client to fill buffer
701    CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
702    t2 = pmc_time() - t1
703    IF ( PRESENT( waittime ) )  waittime = t2
704!
705!-- TODO: check next statement
706!-- Fence might do it, test later
707!-- CALL MPI_WIN_FENCE( 0, clients(clientid)%win_server_client, ierr)
708    CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
709
710    DO  ip = 1, clients(clientid)%inter_npes
711
712       ape => clients(clientid)%pes(ip)
713
714       DO  j = 1, ape%nr_arrays
715
716          ar => ape%array_list(j)
717
718          IF ( ar%recvindex < 0 )  CYCLE
719
720          IF ( ar%nrdims == 2 )  THEN
721             nr = ape%nrele
722          ELSEIF ( ar%nrdims == 3 )  THEN
723             nr = ape%nrele * ar%a_dim(4)
724          ENDIF
725
726          buf_shape(1) = nr
727          CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
728
729!
730!--       MPI passive target RMA
731          IF ( nr > 0 )  THEN
732             target_disp = ar%recvindex - 1
733!
734!--          Client PEs are located behind server PEs
735             target_pe = ip - 1 + m_model_npes
736             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED, target_pe, 0,                 &
737                                clients(clientid)%win_server_client, ierr )
738             CALL MPI_GET( buf, nr, MPI_REAL, target_pe, target_disp, nr,      &
739                           MPI_REAL, clients(clientid)%win_server_client, ierr )
740             CALL MPI_WIN_UNLOCK( target_pe,                                   &
741                                  clients(clientid)%win_server_client, ierr )
742          ENDIF
743
744          myindex = 1
745          IF ( ar%nrdims == 2 )  THEN
746
747             CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
748             DO  ij = 1, ape%nrele
749                data_2d(ape%locind(ij)%j,ape%locind(ij)%i) = buf(myindex)
750                myindex = myindex + 1
751             ENDDO
752
753          ELSEIF ( ar%nrdims == 3 )  THEN
754
755             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3))
756             DO  ij = 1, ape%nrele
757                data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i) =     &
758                                              buf(myindex:myindex+ar%a_dim(4)-1)
759                myindex = myindex + ar%a_dim(4)
760             ENDDO
761
762          ENDIF
763
764       ENDDO
765
766    ENDDO
767
768 END SUBROUTINE pmc_s_getdata_from_buffer
769
770
771
772 SUBROUTINE get_da_names_from_client( clientid )
773!
774!-- Get data array description and name from client
775    IMPLICIT NONE
776
777    INTEGER, INTENT(IN) ::  clientid  !<
778
779    TYPE(da_namedef) ::  myname  !<
780
781    DO
782       CALL pmc_bcast( myname%couple_index, 0, comm=m_to_client_comm(clientid) )
783       IF ( myname%couple_index == -1 )  EXIT
784       CALL pmc_bcast( myname%serverdesc,   0, comm=m_to_client_comm(clientid) )
785       CALL pmc_bcast( myname%nameonserver, 0, comm=m_to_client_comm(clientid) )
786       CALL pmc_bcast( myname%clientdesc,   0, comm=m_to_client_comm(clientid) )
787       CALL pmc_bcast( myname%nameonclient, 0, comm=m_to_client_comm(clientid) )
788
789       CALL pmc_g_setname( clients(clientid), myname%couple_index,             &
790                           myname%nameonserver )
791   ENDDO
792
793 END SUBROUTINE get_da_names_from_client
794
795
796
797 SUBROUTINE pmc_s_setarray(clientid, nrdims, dims, array_adr, second_adr )
798!
799!-- Set array for client interPE 0
800    IMPLICIT NONE
801
802    INTEGER, INTENT(IN)               ::  clientid  !<
803    INTEGER, INTENT(IN)               ::  nrdims    !<
804    INTEGER, INTENT(IN), DIMENSION(:) ::  dims      !<
805
806    TYPE(C_PTR), INTENT(IN)           :: array_adr   !<
807    TYPE(C_PTR), INTENT(IN), OPTIONAL :: second_adr  !<
808
809    INTEGER ::  i  !< local counter
810
811    TYPE(pedef), POINTER    ::  ape  !<
812    TYPE(arraydef), POINTER ::  ar   !<
813
814
815    DO  i = 1, clients(clientid)%inter_npes
816
817       ape => clients(clientid)%pes(i)
818       ar  => ape%array_list(next_array_in_list)
819       ar%nrdims = nrdims
820       ar%a_dim  = dims
821       ar%data   = array_adr
822
823       IF ( PRESENT( second_adr ) )  THEN
824          ar%po_data(1) = array_adr
825          ar%po_data(2) = second_adr
826       ELSE
827          ar%po_data(1) = C_NULL_PTR
828          ar%po_data(2) = C_NULL_PTR
829       ENDIF
830
831    ENDDO
832
833 END SUBROUTINE pmc_s_setarray
834
835
836
837 SUBROUTINE pmc_s_set_active_data_array( clientid, iactive )
838
839    IMPLICIT NONE
840
841    INTEGER, INTENT(IN) ::  clientid  !<
842    INTEGER, INTENT(IN) ::  iactive   !<
843
844    INTEGER :: i   !<
845    INTEGER :: ip  !<
846    INTEGER :: j   !<
847
848    TYPE(pedef), POINTER    ::  ape  !<
849    TYPE(arraydef), POINTER ::  ar   !<
850
851    DO  ip = 1, clients(clientid)%inter_npes
852
853       ape => clients(clientid)%pes(ip)
854
855       DO  j = 1, ape%nr_arrays
856
857          ar => ape%array_list(j)
858          IF ( iactive == 1  .OR.  iactive == 2 )  THEN
859             ar%data = ar%po_data(iactive)
860          ENDIF
861
862       ENDDO
863
864    ENDDO
865
866 END SUBROUTINE pmc_s_set_active_data_array
867
868
869
870 SUBROUTINE set_pe_index_list( clientid, myclient, index_list, nrp )
871
872    IMPLICIT NONE
873
874    INTEGER, INTENT(IN)                 ::  clientid    !<
875    INTEGER, INTENT(IN), DIMENSION(:,:) ::  index_list  !<
876    INTEGER, INTENT(IN)                 ::  nrp         !<
877
878    TYPE(clientdef), INTENT(INOUT) ::  myclient  !<
879
880    INTEGER                                 :: i        !<
881    INTEGER                                 :: ierr     !<
882    INTEGER                                 :: ind      !<
883    INTEGER                                 :: indwin   !<
884    INTEGER                                 :: indwin2  !<
885    INTEGER                                 :: i2       !<
886    INTEGER                                 :: j        !<
887    INTEGER                                 :: rempe    !<
888    INTEGER(KIND=MPI_ADDRESS_KIND)          :: winsize  !<
889
890    INTEGER, DIMENSION(myclient%inter_npes) :: remind   !<
891
892    INTEGER, DIMENSION(:), POINTER          :: remindw  !<
893    INTEGER, DIMENSION(:), POINTER          :: rldef    !<
894
895    TYPE(pedef), POINTER                    :: ape      !<
896
897!
898!-- First, count entries for every remote client PE
899    DO  i = 1, myclient%inter_npes
900       ape => myclient%pes(i)
901       ape%nrele = 0
902    ENDDO
903!
904!-- Loop over number of coarse grid cells
905    DO  j = 1, nrp
906       rempe = index_list(5,j) + 1   ! PE number on remote PE
907       ape => myclient%pes(rempe)
908       ape%nrele = ape%nrele + 1 ! Increment number of elements for this client PE
909    ENDDO
910
911    DO  i = 1, myclient%inter_npes
912       ape => myclient%pes(i)
913       ALLOCATE( ape%locind(ape%nrele) )
914    ENDDO
915
916    remind = 0
917
918!
919!-- Second, create lists
920!-- Loop over number of coarse grid cells
921    DO  j = 1, nrp
922       rempe = index_list(5,j) + 1
923       ape => myclient%pes(rempe)
924       remind(rempe)     = remind(rempe)+1
925       ind               = remind(rempe)
926       ape%locind(ind)%i = index_list(1,j)
927       ape%locind(ind)%j = index_list(2,j)
928    ENDDO
929!
930!-- Prepare number of elements for client PEs
931    CALL pmc_alloc_mem( rldef, myclient%inter_npes*2 )
932!
933!-- Number of client PEs * size of INTEGER (i just arbitrary INTEGER)
934    winsize = myclient%inter_npes*c_sizeof(i)*2
935
936    CALL MPI_WIN_CREATE( rldef, winsize, iwp, MPI_INFO_NULL,                   &
937                         myclient%intra_comm, indwin, ierr )
938!
939!-- Open window to set data
940    CALL MPI_WIN_FENCE( 0, indwin, ierr )
941
942    rldef(1) = 0            ! index on remote PE 0
943    rldef(2) = remind(1)    ! number of elements on remote PE 0
944!
945!-- Reserve buffer for index array
946    DO  i = 2, myclient%inter_npes
947       i2          = (i-1) * 2 + 1
948       rldef(i2)   = rldef(i2-2) + rldef(i2-1) * 2  ! index on remote PE
949       rldef(i2+1) = remind(i)                ! number of elements on remote PE
950    ENDDO
951!
952!-- Close window to allow client to access data
953    CALL MPI_WIN_FENCE( 0, indwin, ierr )
954!
955!-- Client has retrieved data
956    CALL MPI_WIN_FENCE( 0, indwin, ierr )
957
958    i2 = 2 * myclient%inter_npes - 1
959    winsize = ( rldef(i2) + rldef(i2+1) ) * 2
960!
961!-- Make sure, MPI_ALLOC_MEM works
962    winsize = MAX( winsize, 1 )
963
964    CALL pmc_alloc_mem( remindw, INT( winsize ) )
965
966    CALL MPI_BARRIER( m_model_comm, ierr )
967    CALL MPI_WIN_CREATE( remindw, winsize*c_sizeof(i), iwp, MPI_INFO_NULL,     &
968                         myclient%intra_comm, indwin2, ierr )
969!
970!-- Open window to set data
971    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
972!
973!-- Create the 2D index list
974    DO  j = 1, nrp
975       rempe = index_list(5,j) + 1    ! PE number on remote PE
976       ape => myclient%pes(rempe)
977       i2    = rempe * 2 - 1
978       ind   = rldef(i2) + 1
979       remindw(ind)   = index_list(3,j)
980       remindw(ind+1) = index_list(4,j)
981       rldef(i2)      = rldef(i2)+2
982    ENDDO
983!
984!-- All data areset
985    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
986!
987!-- Don't know why, but this barrier is necessary before windows can be freed
988!-- TODO: find out why this is required
989    CALL MPI_BARRIER( myclient%intra_comm, ierr )
990
991    CALL MPI_WIN_FREE( indwin, ierr )
992    CALL MPI_WIN_FREE( indwin2, ierr )
993
994!-- TODO: check if the following idea needs to be done
995!-- Sollte funktionieren, Problem mit MPI implementation
996!-- https://www.lrz.de/services/software/parallel/mpi/onesided
997!-- CALL MPI_Free_mem (remindw, ierr)
998
999 END SUBROUTINE set_pe_index_list
1000
1001#endif
1002 END MODULE pmc_server
Note: See TracBrowser for help on using the repository browser.