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

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

re-formatting of remaining pmc routines

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