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

Last change on this file since 4631 was 4629, checked in by raasch, 4 years ago

support for MPI Fortran77 interface (mpif.h) removed

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