source: palm/trunk/SOURCE/pmc_child_mod.f90 @ 2769

Last change on this file since 2769 was 2718, checked in by maronga, 7 years ago

deleting of deprecated files; headers updated where needed

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