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

Last change on this file since 4180 was 4180, checked in by scharf, 22 months ago

removed comments in 'Former revisions' section that are older than 01.01.2019

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