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

Last change on this file since 2604 was 2599, checked in by hellstea, 7 years ago

i/o grouping update for nested runs

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