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

Last change on this file since 1986 was 1933, checked in by hellstea, 8 years ago

last commit documented

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