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

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