source: palm/trunk/SOURCE/pmc_client_mod.f90 @ 1897

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

last commit documented

  • Property svn:keywords set to Id
File size: 25.1 KB
Line 
1MODULE pmc_client
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_client_mod.f90 1897 2016-05-03 08:10:23Z raasch $
27!
28! 1896 2016-05-03 08:06:41Z 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-statement 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! 1783 2016-03-06 18:36:17Z raasch
53! Bugfix: wrong data-type in MPI_WIN_CREATE replaced
54!
55! 1779 2016-03-03 08:01:28Z raasch
56! kind=dp replaced by wp, dim_order removed
57! array management changed from linked list to sequential loop
58!
59! 1764 2016-02-28 12:45:19Z raasch
60! cpp-statement added (nesting can only be used in parallel mode),
61! all kinds given in PALM style
62!
63! 1762 2016-02-25 12:31:13Z hellstea
64! Initial revision by K. Ketelsen
65!
66! Description:
67! ------------
68!
69! Client part of Palm Model Coupler
70!------------------------------------------------------------------------------!
71
72#if defined( __parallel )
73
74    USE, INTRINSIC ::  iso_c_binding
75
76#if defined( __mpifh )
77    INCLUDE "mpif.h"
78#else
79    USE MPI
80#endif
81
82    USE kinds
83    USE pmc_general,                                                           &
84        ONLY:  arraydef, clientdef, da_desclen, da_namedef, da_namelen, pedef, &
85               pmc_da_name_err,  pmc_g_setname, pmc_max_array, pmc_status_ok
86
87    USE pmc_handle_communicator,                                               &
88        ONLY:  m_model_comm, m_model_npes, m_model_rank, m_to_server_comm
89
90    USE pmc_mpi_wrapper,                                                       &
91        ONLY:  pmc_alloc_mem, pmc_bcast, pmc_inter_bcast,                      &
92               pmc_recv_from_server, pmc_send_to_server, pmc_time
93
94    IMPLICIT NONE
95
96    PRIVATE
97    SAVE
98
99    TYPE(clientdef) ::  me   !<
100
101    INTEGER ::  myindex = 0         !< counter and unique number for data arrays
102    INTEGER ::  next_array_in_list = 0   !<
103
104
105    INTERFACE pmc_clientinit
106        MODULE PROCEDURE pmc_clientinit
107    END INTERFACE PMC_ClientInit
108
109    INTERFACE pmc_c_clear_next_array_list
110        MODULE PROCEDURE pmc_c_clear_next_array_list
111    END INTERFACE pmc_c_clear_next_array_list
112
113    INTERFACE pmc_c_getbuffer
114        MODULE PROCEDURE pmc_c_getbuffer
115    END INTERFACE pmc_c_getbuffer
116
117    INTERFACE pmc_c_getnextarray
118        MODULE PROCEDURE pmc_c_getnextarray
119    END INTERFACE pmc_c_getnextarray
120
121    INTERFACE pmc_c_get_2d_index_list
122        MODULE PROCEDURE pmc_c_get_2d_index_list
123    END INTERFACE pmc_c_get_2d_index_list
124
125    INTERFACE pmc_c_putbuffer
126        MODULE PROCEDURE pmc_c_putbuffer
127    END INTERFACE pmc_c_putbuffer
128
129    INTERFACE pmc_c_setind_and_allocmem
130        MODULE PROCEDURE pmc_c_setind_and_allocmem
131    END INTERFACE pmc_c_setind_and_allocmem
132
133    INTERFACE pmc_c_set_dataarray
134        MODULE PROCEDURE pmc_c_set_dataarray_2d
135        MODULE PROCEDURE pmc_c_set_dataarray_3d
136    END INTERFACE pmc_c_set_dataarray
137
138    INTERFACE pmc_set_dataarray_name
139        MODULE PROCEDURE pmc_set_dataarray_name
140        MODULE PROCEDURE pmc_set_dataarray_name_lastentry
141    END INTERFACE pmc_set_dataarray_name
142
143
144    PUBLIC pmc_clientinit, pmc_c_clear_next_array_list, pmc_c_getbuffer,       &
145           pmc_c_getnextarray, pmc_c_putbuffer, pmc_c_setind_and_allocmem,     &
146           pmc_c_set_dataarray, pmc_set_dataarray_name, pmc_c_get_2d_index_list
147
148 CONTAINS
149
150
151
152 SUBROUTINE pmc_clientinit
153
154     IMPLICIT NONE
155
156     INTEGER ::  i        !<
157     INTEGER ::  istat    !<
158
159!
160!--  Get / define the MPI environment
161     me%model_comm = m_model_comm
162     me%inter_comm = m_to_server_comm
163
164     CALL MPI_COMM_RANK( me%model_comm, me%model_rank, istat )
165     CALL MPI_COMM_SIZE( me%model_comm, me%model_npes, istat )
166     CALL MPI_COMM_REMOTE_SIZE( me%inter_comm, me%inter_npes, istat )
167!
168!--  Intra-communicater is used for MPI_GET
169     CALL MPI_INTERCOMM_MERGE( me%inter_comm, .TRUE., me%intra_comm, istat )
170     CALL MPI_COMM_RANK( me%intra_comm, me%intra_rank, istat )
171
172     ALLOCATE( me%pes(me%inter_npes) )
173
174!
175!--  Allocate an array of type arraydef for all server PEs to store information
176!--  of then transfer array
177     DO  i = 1, me%inter_npes
178        ALLOCATE( me%pes(i)%array_list(pmc_max_array) )
179     ENDDO
180
181 END SUBROUTINE pmc_clientinit
182
183
184
185 SUBROUTINE pmc_set_dataarray_name( serverarraydesc, serverarrayname,          &
186                                    clientarraydesc, clientarrayname, istat )
187
188    IMPLICIT NONE
189
190    CHARACTER(LEN=*), INTENT(IN) ::  serverarrayname  !<
191    CHARACTER(LEN=*), INTENT(IN) ::  serverarraydesc  !<
192    CHARACTER(LEN=*), INTENT(IN) ::  clientarrayname  !<
193    CHARACTER(LEN=*), INTENT(IN) ::  clientarraydesc  !<
194
195    INTEGER, INTENT(OUT) ::  istat  !<
196
197!
198!-- Local variables
199    TYPE(da_namedef) ::  myname  !<
200
201    INTEGER ::  mype  !<
202    INTEGER ::  my_addiarray = 0  !<
203
204
205    istat = pmc_status_ok
206!
207!-- Check length of array names
208    IF ( LEN( TRIM( serverarrayname) ) > da_namelen  .OR.                     &
209         LEN( TRIM( clientarrayname) ) > da_namelen )  THEN
210       istat = pmc_da_name_err
211    ENDIF
212
213    IF ( m_model_rank == 0 )  THEN
214       myindex = myindex + 1
215       myname%couple_index = myIndex
216       myname%serverdesc   = TRIM( serverarraydesc )
217       myname%nameonserver = TRIM( serverarrayname )
218       myname%clientdesc   = TRIM( clientarraydesc )
219       myname%nameonclient = TRIM( clientarrayname )
220    ENDIF
221
222!
223!-- Broadcat to all client PEs
224!-- TODO: describe what is broadcast here and why it is done
225    CALL pmc_bcast( myname%couple_index, 0, comm=m_model_comm )
226    CALL pmc_bcast( myname%serverdesc,   0, comm=m_model_comm )
227    CALL pmc_bcast( myname%nameonserver, 0, comm=m_model_comm )
228    CALL pmc_bcast( myname%clientdesc,   0, comm=m_model_comm )
229    CALL pmc_bcast( myname%nameonclient, 0, comm=m_model_comm )
230
231!
232!-- Broadcat to all server PEs
233!-- TODO: describe what is broadcast here and why it is done
234    IF ( m_model_rank == 0 )  THEN
235        mype = MPI_ROOT
236    ELSE
237        mype = MPI_PROC_NULL
238    ENDIF
239
240    CALL pmc_bcast( myname%couple_index, mype, comm=m_to_server_comm )
241    CALL pmc_bcast( myname%serverdesc,   mype, comm=m_to_server_comm )
242    CALL pmc_bcast( myname%nameonserver, mype, comm=m_to_server_comm )
243    CALL pmc_bcast( myname%clientdesc,   mype, comm=m_to_server_comm )
244    CALL pmc_bcast( myname%nameonclient, mype, comm=m_to_server_comm )
245
246    CALL pmc_g_setname( me, myname%couple_index, myname%nameonclient )
247
248 END SUBROUTINE pmc_set_dataarray_name
249
250
251
252 SUBROUTINE pmc_set_dataarray_name_lastentry( lastentry )
253
254    IMPLICIT NONE
255
256    LOGICAL, INTENT(IN), OPTIONAL ::  lastentry  !<
257
258!
259!-- Local variables
260    INTEGER ::  mype  !<
261    TYPE(dA_namedef) ::  myname  !<
262
263    myname%couple_index = -1
264
265    IF ( m_model_rank == 0 )  THEN
266       mype = MPI_ROOT
267    ELSE
268       mype = MPI_PROC_NULL
269    ENDIF
270
271    CALL pmc_bcast( myname%couple_index, mype, comm=m_to_server_comm )
272
273 END SUBROUTINE pmc_set_dataarray_name_lastentry
274
275
276
277 SUBROUTINE pmc_c_get_2d_index_list
278
279    IMPLICIT NONE
280
281    INTEGER :: dummy               !<
282    INTEGER :: i, ierr, i2, j, nr  !<
283    INTEGER :: indwin              !< MPI window object
284    INTEGER :: indwin2  !          < MPI window object
285
286    INTEGER(KIND=MPI_ADDRESS_KIND) :: win_size !< Size of MPI window 1 (in bytes)
287    INTEGER(KIND=MPI_ADDRESS_KIND) :: disp     !< Displacement unit (Integer = 4, floating poit = 8
288    INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize  !< Size of MPI window 2 (in bytes)
289
290    INTEGER, DIMENSION(me%inter_npes*2) :: nrele  !< Number of Elements of a
291                                                  !< horizontal slice
292    INTEGER, DIMENSION(:), POINTER ::  myind  !<
293
294    TYPE(pedef), POINTER ::  ape  !> Pointer to pedef structure
295
296
297    win_size = C_SIZEOF( dummy )
298    CALL MPI_WIN_CREATE( dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm,   &
299                         indwin, ierr )
300!
301!-- Open window on server side
302!-- TODO: why is the next MPI routine called twice??
303    CALL MPI_WIN_FENCE( 0, indwin, ierr )
304!
305!-- Close window on server side and open on client side
306    CALL MPI_WIN_FENCE( 0, indwin, ierr )
307
308    DO  i = 1, me%inter_npes
309       disp = me%model_rank * 2
310       CALL MPI_GET( nrele((i-1)*2+1), 2, MPI_INTEGER, i-1, disp, 2,           &
311                     MPI_INTEGER, indwin, ierr )
312    ENDDO
313!
314!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
315!-- called
316    CALL MPI_WIN_FENCE( 0, indwin, ierr )
317
318!
319!-- Allocate memory for index array
320    winsize = 0
321    DO  i = 1, me%inter_npes
322       ape => me%pes(i)
323       i2 = ( i-1 ) * 2 + 1
324       nr = nrele(i2+1)
325       IF ( nr > 0 )  THEN
326          ALLOCATE( ape%locind(nr) )
327       ELSE
328          NULLIFY( ape%locind )
329       ENDIF
330       winsize = MAX( nr, winsize )
331    ENDDO
332
333    ALLOCATE( myind(2*winsize) )
334    winsize = 1
335
336!
337!-- Local buffer used in MPI_GET can but must not be inside the MPI Window.
338!-- Here, we use a dummy for the MPI window because the server PEs do not access
339!-- the RMA window via MPI_GET or MPI_PUT
340    CALL MPI_WIN_CREATE( dummy, winsize, iwp, MPI_INFO_NULL, me%intra_comm,    &
341                         indwin2, ierr )
342!
343!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
344!-- called
345!-- TODO: as before: why is this called twice??
346    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
347    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
348
349    DO  i = 1, me%inter_npes
350       ape => me%pes(i)
351       nr = nrele(i*2)
352       IF ( nr > 0 )  THEN
353          disp = nrele(2*(i-1)+1)
354          CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , i-1, 0, indwin2, ierr )
355          CALL MPI_GET( myind, 2*nr, MPI_INTEGER, i-1, disp, 2*nr,             &
356                        MPI_INTEGER, indwin2, ierr )
357          CALL MPI_WIN_UNLOCK( i-1, indwin2, ierr )
358          DO  j = 1, nr
359             ape%locind(j)%i = myind(2*j-1)
360             ape%locind(j)%j = myind(2*j)
361          ENDDO
362          ape%nrele = nr
363       ELSE
364          ape%nrele = -1
365       ENDIF
366    ENDDO
367
368!
369!-- Don't know why, but this barrier is necessary before we can free the windows
370    CALL MPI_BARRIER( me%intra_comm, ierr )
371
372    CALL MPI_WIN_FREE( indWin,  ierr )
373    CALL MPI_WIN_FREE( indwin2, ierr )
374    DEALLOCATE( myind )
375
376 END SUBROUTINE pmc_c_get_2d_index_list
377
378
379
380 SUBROUTINE pmc_c_clear_next_array_list
381
382    IMPLICIT NONE
383
384    next_array_in_list = 0
385
386 END SUBROUTINE pmc_c_clear_next_array_list
387
388
389
390 LOGICAL FUNCTION pmc_c_getnextarray( myname )
391!
392!--  List handling is still required to get minimal interaction with
393!--  pmc_interface
394     CHARACTER(LEN=*), INTENT(OUT) ::  myname  !<
395
396!
397!-- Local variables
398    TYPE(pedef), POINTER    :: ape
399    TYPE(arraydef), POINTER :: ar
400
401
402    next_array_in_list = next_array_in_list + 1
403
404!
405!-- Array names are the same on all client PEs, so take first PE to get the name
406    ape => me%pes(1)
407!
408!-- Check if all arrays have been processed
409    IF ( next_array_in_list > ape%nr_arrays )  THEN
410       pmc_c_getnextarray = .FALSE.
411       RETURN
412    ENDIF
413
414    ar => ape%array_list( next_array_in_list )
415
416    myname = ar%name
417
418!
419!-- Return true if legal array
420!-- TODO: the case of a non-legal array does not seem to appear, so why is this
421!-- setting required at all?
422    pmc_c_getnextarray = .TRUE.
423
424 END function pmc_c_getnextarray
425
426
427
428 SUBROUTINE pmc_c_set_dataarray_2d( array )
429
430    IMPLICIT NONE
431
432    REAL(wp), INTENT(IN) , DIMENSION(:,:), POINTER ::  array  !<
433
434    INTEGER                 ::  i       !<
435    INTEGER                 ::  nrdims  !<
436    INTEGER, DIMENSION(4)   ::  dims    !<
437
438    TYPE(C_PTR)             ::  array_adr
439    TYPE(arraydef), POINTER ::  ar
440    TYPE(pedef), POINTER    ::  ape
441
442
443    dims    = 1
444    nrdims  = 2
445    dims(1) = SIZE( array, 1 )
446    dims(2) = SIZE( array, 2 )
447
448    array_adr = C_LOC( array )
449
450    DO  i = 1, me%inter_npes
451       ape => me%pes(i)
452       ar  => ape%array_list(next_array_in_list)
453       ar%nrdims = nrdims
454       ar%a_dim  = dims
455       ar%data   = array_adr
456    ENDDO
457
458 END SUBROUTINE pmc_c_set_dataarray_2d
459
460
461
462 SUBROUTINE pmc_c_set_dataarray_3d (array)
463
464    IMPLICIT NONE
465
466    REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER ::  array  !<
467
468    INTEGER                 ::  i
469    INTEGER                 ::  nrdims
470    INTEGER, DIMENSION (4)  ::  dims
471    TYPE(C_PTR)             ::  array_adr
472    TYPE(pedef), POINTER    ::  ape
473    TYPE(arraydef), POINTER ::  ar
474
475
476    dims    = 1
477    nrdims  = 3
478    dims(1) = SIZE( array, 1 )
479    dims(2) = SIZE( array, 2 )
480    dims(3) = SIZE( array, 3 )
481
482    array_adr = C_LOC( array )
483
484    DO  i = 1, me%inter_npes
485       ape => me%pes(i)
486       ar  => ape%array_list(next_array_in_list)
487       ar%nrdims = nrdims
488       ar%a_dim  = dims
489       ar%data   = array_adr
490    ENDDO
491
492 END SUBROUTINE pmc_c_set_dataarray_3d
493
494
495
496 SUBROUTINE pmc_c_setind_and_allocmem
497
498    IMPLICIT NONE
499!
500!-- Naming convention for appendices:  _sc  -> server to client transfer
501!--                                    _cs  -> client to server transfer
502!--                                    recv -> server to client transfer
503!--                                    send -> client to server transfer
504    CHARACTER(LEN=da_namelen) ::  myname  !<
505
506    INTEGER ::  arlen    !<
507    INTEGER ::  myindex  !<
508    INTEGER ::  i        !<
509    INTEGER ::  ierr     !<
510    INTEGER ::  istat    !<
511    INTEGER ::  j        !<
512    INTEGER ::  rcount   !<
513    INTEGER ::  tag      !<
514
515    INTEGER, PARAMETER ::  noindex = -1  !<
516
517    INTEGER(idp)                   ::  bufsize  !< size of MPI data window
518    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
519
520    INTEGER,DIMENSION(1024) ::  req  !<
521
522    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_sc  !< base array
523    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_cs  !< base array
524
525    TYPE(pedef), POINTER    ::  ape       !<
526    TYPE(arraydef), POINTER ::  ar        !<
527    Type(C_PTR)             ::  base_ptr  !<
528
529
530    myindex = 0
531    bufsize = 8
532
533!
534!-- Server to client direction.
535!-- First stride: compute size and set index
536    DO  i = 1, me%inter_npes
537
538       ape => me%pes(i)
539       tag = 200
540
541       DO  j = 1, ape%nr_arrays
542
543          ar => ape%array_list(j)
544!
545!--       Receive index from client
546          tag = tag + 1
547          CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,     &
548                         MPI_STATUS_IGNORE, ierr )
549          ar%recvindex = myindex
550!
551!--       Determine max, because client buffer is allocated only once
552!--       TODO: give a more meaningful comment
553          IF( ar%nrdims == 3 )  THEN
554             bufsize = MAX( bufsize, ar%a_dim(1)*ar%a_dim(2)*ar%a_dim(3) )
555          ELSE
556             bufsize = MAX( bufsize, ar%a_dim(1)*ar%a_dim(2) )
557          ENDIF
558
559       ENDDO
560
561    ENDDO
562
563!
564!-- Create RMA (one sided communication) data buffer.
565!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of
566!-- the MPI RMA window
567    CALL pmc_alloc_mem( base_array_sc, bufsize, base_ptr )
568    me%totalbuffersize = bufsize*wp  ! total buffer size in byte
569
570!
571!-- Second stride: set buffer pointer
572    DO  i = 1, me%inter_npes
573
574       ape => me%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!
584!-- Client to server direction
585    myindex = 1
586    rcount  = 0
587    bufsize = 8
588
589    DO  i = 1, me%inter_npes
590
591       ape => me%pes(i)
592       tag = 300
593
594       DO  j = 1, ape%nr_arrays
595
596          ar => ape%array_list(j)
597          IF( ar%nrdims == 2 )  THEN
598             arlen = ape%nrele
599          ELSEIF( ar%nrdims == 3 )  THEN
600             arlen = ape%nrele*ar%a_dim(1)
601          ENDIF
602
603          tag    = tag + 1
604          rcount = rcount + 1
605          IF ( ape%nrele > 0 )  THEN
606             CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
607                             req(rcount), ierr )
608             ar%sendindex = myindex
609          ELSE
610             CALL MPI_ISEND( noindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
611                             req(rcount), ierr )
612             ar%sendindex = noindex
613          ENDIF
614!
615!--       Maximum of 1024 outstanding requests
616!--       TODO: explain where this maximum comes from (arbitrary?)
617          IF ( rcount == 1024 )  THEN
618             CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
619             rcount = 0
620          ENDIF
621
622          IF ( ape%nrele > 0 )  THEN
623             ar%sendsize = arlen
624             myindex     = myindex + arlen
625             bufsize     = bufsize + arlen
626          ENDIF
627
628       ENDDO
629
630       IF ( rcount > 0 )  THEN
631          CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
632       ENDIF
633
634    ENDDO
635
636!
637!-- Create RMA (one sided communication) window for data buffer client to server
638!-- transfer.
639!-- The buffer of MPI_GET (counter part of transfer) can be PE-local, i.e. it
640!-- can but must not be part of the MPI RMA window. Only one RMA window is
641!-- required to prepare the data
642!--        for server -> client transfer on the server side
643!-- and
644!--        for client -> server transfer on the client side
645
646    CALL pmc_alloc_mem( base_array_cs, bufsize )
647    me%totalbuffersize = bufsize * wp  ! total buffer size in byte
648
649    winSize = me%totalbuffersize
650
651    CALL MPI_WIN_CREATE( base_array_cs, winsize, wp, MPI_INFO_NULL,            &
652                         me%intra_comm, me%win_server_client, ierr )
653    CALL MPI_WIN_FENCE( 0, me%win_server_client, ierr )
654    CALL MPI_BARRIER( me%intra_comm, ierr )
655
656!
657!-- Second stride: set buffer pointer
658    DO  i = 1, me%inter_npes
659
660       ape => me%pes(i)
661
662       DO  j = 1, ape%nr_arrays
663
664          ar => ape%array_list(j)
665
666          IF ( ape%nrele > 0 )  THEN
667             ar%sendbuf = C_LOC( base_array_cs(ar%sendindex) )
668!--          TODO: if this is an error to be really expected, replace the
669!--                following message by a meaningful standard PALM message using
670!--                the message-routine
671             IF ( ar%sendindex+ar%sendsize > bufsize )  THEN
672                WRITE( 0,'(a,i4,4i7,1x,a)') 'Client Buffer too small ', i,     &
673                          ar%sendindex, ar%sendsize, ar%sendindex+ar%sendsize, &
674                          bufsize, TRIM( ar%name )
675                CALL MPI_ABORT( MPI_COMM_WORLD, istat, ierr )
676             ENDIF
677          ENDIF
678
679       ENDDO
680
681    ENDDO
682
683 END SUBROUTINE pmc_c_setind_and_allocmem
684
685
686
687 SUBROUTINE pmc_c_getbuffer( waittime )
688
689    IMPLICIT NONE
690
691    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
692
693    CHARACTER(LEN=da_namelen) ::  myname  !<
694
695    INTEGER                        ::  ierr     !<
696    INTEGER                        ::  ij       !<
697    INTEGER                        ::  ip       !<
698    INTEGER                        ::  j        !<
699    INTEGER                        ::  myindex  !<
700    INTEGER                        ::  nr       !< number of elements to get
701                                                !< from server
702    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp
703    INTEGER,DIMENSION(1)           ::  buf_shape
704
705    REAL(wp)                            ::  t1
706    REAL(wp)                            ::  t2
707
708    REAL(wp), POINTER, DIMENSION(:)     ::  buf
709    REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
710    REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
711    TYPE(pedef), POINTER                ::  ape
712    TYPE(arraydef), POINTER             ::  ar
713
714!
715!-- Synchronization of the model is done in pmci_client_synchronize and
716!-- pmci_server_synchronize. Therefor the RMA window can be filled without
717!-- sychronization at this point and a barrier is not necessary.
718!-- Please note that waittime has to be set in pmc_s_fillbuffer AND
719!-- pmc_c_getbuffer
720    IF ( PRESENT( waittime ) )  THEN
721       t1 = pmc_time()
722       CALL MPI_BARRIER( me%intra_comm, ierr )
723       t2 = pmc_time()
724       waittime = t2 - t1
725    ENDIF
726!
727!-- Wait for buffer is filled
728!-- TODO: explain in more detail what is happening here. The barrier seems to
729!-- contradict what is said a few lines beforer (i.e. that no barrier is necessary)
730!-- TODO: In case of PRESENT( waittime ) the barrrier would be calles twice. Why?
731!-- Shouldn't it be done the same way as in pmc_putbuffer?
732    CALL MPI_BARRIER( me%intra_comm, ierr )
733
734    DO  ip = 1, me%inter_npes
735
736       ape => me%pes(ip)
737
738       DO  j = 1, ape%nr_arrays
739
740          ar => ape%array_list(j)
741
742          IF ( ar%nrdims == 2 )  THEN
743             nr = ape%nrele
744          ELSEIF ( ar%nrdims == 3 )  THEN
745             nr = ape%nrele * ar%a_dim(1)
746          ENDIF
747
748          buf_shape(1) = nr
749          CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
750!
751!--       MPI passive target RMA
752!--       TODO: explain the above comment
753          IF ( nr > 0 )  THEN
754             target_disp = ar%recvindex - 1
755             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0,                     &
756                                me%win_server_client, ierr )
757             CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, &
758                                me%win_server_client, ierr )
759             CALL MPI_WIN_UNLOCK( ip-1, me%win_server_client, ierr )
760          ENDIF
761
762          myindex = 1
763          IF ( ar%nrdims == 2 )  THEN
764
765             CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
766
767             DO  ij = 1, ape%nrele
768                data_2d(ape%locind(ij)%j,ape%locind(ij)%i) = buf(myindex)
769                myindex = myindex + 1
770             ENDDO
771
772          ELSEIF ( ar%nrdims == 3 )  THEN
773
774             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
775
776             DO  ij = 1, ape%nrele
777                data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) =                 &
778                                              buf(myindex:myindex+ar%a_dim(1)-1)
779                myindex = myindex+ar%a_dim(1)
780             ENDDO
781
782          ENDIF
783
784       ENDDO
785
786    ENDDO
787
788 END SUBROUTINE pmc_c_getbuffer
789
790
791
792 SUBROUTINE pmc_c_putbuffer( waittime )
793
794    IMPLICIT NONE
795
796    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
797
798    CHARACTER(LEN=da_namelen) ::  myname  !<
799
800    INTEGER                        ::  ierr         !<
801    INTEGER                        ::  ij           !<
802    INTEGER                        ::  ip           !<
803    INTEGER                        ::  j            !<
804    INTEGER                        ::  myindex      !<
805    INTEGER                        ::  nr           !< number of elements to get
806                                                    !< from server
807    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp  !<
808
809    INTEGER, DIMENSION(1)          ::  buf_shape    !<
810
811    REAL(wp) ::  t1  !<
812    REAL(wp) ::  t2  !<
813
814    REAL(wp), POINTER, DIMENSION(:)     ::  buf      !<
815    REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d  !<
816    REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d  !<
817
818    TYPE(pedef), POINTER               ::  ape  !<
819    TYPE(arraydef), POINTER            ::  ar   !<
820
821!
822!-- Wait for empty buffer
823!-- TODO: explain what is done here
824    t1 = pmc_time()
825    CALL MPI_BARRIER( me%intra_comm, ierr )
826    t2 = pmc_time()
827    IF ( PRESENT( waittime ) )  waittime = t2 - t1
828
829    DO  ip = 1, me%inter_npes
830
831       ape => me%pes(ip)
832
833       DO  j = 1, ape%nr_arrays
834
835          ar => aPE%array_list(j)
836          myindex = 1
837
838          IF ( ar%nrdims == 2 )  THEN
839
840             buf_shape(1) = ape%nrele
841             CALL C_F_POINTER( ar%sendbuf, buf,     buf_shape     )
842             CALL C_F_POINTER( ar%data,    data_2d, ar%a_dim(1:2) )
843
844             DO  ij = 1, ape%nrele
845                buf(myindex) = data_2d(ape%locind(ij)%j,ape%locind(ij)%i)
846                myindex = myindex + 1
847             ENDDO
848
849          ELSEIF ( ar%nrdims == 3 )  THEN
850
851             buf_shape(1) = ape%nrele*ar%a_dim(1)
852             CALL C_F_POINTER( ar%sendbuf, buf,     buf_shape     )
853             CALL C_F_POINTER( ar%data,    data_3d, ar%a_dim(1:3) )
854
855             DO  ij = 1, ape%nrele
856                buf(myindex:myindex+ar%a_dim(1)-1) =                           &
857                                    data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i)
858                myindex = myindex + ar%a_dim(1)
859             ENDDO
860
861          ENDIF
862
863       ENDDO
864
865    ENDDO
866!
867!-- TODO: Fence might do it, test later
868!-- Call MPI_WIN_FENCE( 0, me%win_server_client, ierr)      !
869!
870!-- Buffer is filled
871!-- TODO: explain in more detail what is happening here
872    CALL MPI_Barrier(me%intra_comm, ierr)
873
874 END SUBROUTINE pmc_c_putbuffer
875
876#endif
877 END MODULE pmc_client
Note: See TracBrowser for help on using the repository browser.