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

Last change on this file since 2481 was 2101, checked in by suehring, 8 years ago

last commit documented

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