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

Last change on this file since 3962 was 3962, checked in by suehring, 2 years ago

Bugfixes in initial settings of child and parent communication patterns

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