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

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

Remove unused variable

  • 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! Remove unused variable
24!
25! Former revisions:
26! -----------------
27! $Id: pmc_child_mod.f90 3963 2019-05-08 20:09:11Z 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    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_pc  !< base array
608    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_cp  !< base array
609
610    TYPE(pedef), POINTER    ::  ape       !<
611    TYPE(arraydef), POINTER ::  ar        !<
612    Type(C_PTR)             ::  base_ptr  !<
613
614 
615    CALL MPI_COMM_SIZE (me%intra_comm, total_npes, ierr)
616
617    lo_nr_arrays = me%pes(1)%nr_arrays
618
619    ALLOCATE(myindex_s(lo_nr_arrays,0:total_npes-1))
620    ALLOCATE(myindex_r(lo_nr_arrays,0:total_npes-1))
621
622    myindex_s = 0
623
624!
625!-- Receive indices from child
626    CALL MPI_ALLTOALL( myindex_s, lo_nr_arrays, MPI_INTEGER,                   &
627                       myindex_r, lo_nr_arrays, MPI_INTEGER,                   &
628                       me%intra_comm, ierr )
629
630    myindex = 0
631    bufsize = 8
632!
633!-- Parent to child direction.
634!-- First stride: compute size and set index
635    DO  i = 1, me%inter_npes
636       ape => me%pes(i)
637       DO  j = 1, ape%nr_arrays
638          ar => ape%array_list(j)
639          ar%recvindex = myindex_r(j,i-1)
640!
641!--       Determine max, because child buffer is allocated only once
642!--       All 2D and 3d arrays use the same buffer
643
644          IF ( ar%nrdims == 3 )  THEN
645             bufsize = MAX( bufsize,                                           &
646                            INT( ar%a_dim(1)*ar%a_dim(2)*ar%a_dim(3),          &
647                                 MPI_ADDRESS_KIND ) )
648          ELSE
649             bufsize = MAX( bufsize,                                           &
650                            INT( ar%a_dim(1)*ar%a_dim(2), MPI_ADDRESS_KIND ) )
651          ENDIF
652       ENDDO
653    ENDDO
654
655!
656!-- Create RMA (one sided communication) data buffer.
657!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of
658!-- the MPI RMA window
659    CALL pmc_alloc_mem( base_array_pc, bufsize, base_ptr )
660    me%totalbuffersize = bufsize*wp  ! total buffer size in byte
661!
662!-- Second stride: set buffer pointer
663    DO  i = 1, me%inter_npes
664       ape => me%pes(i)
665       DO  j = 1, ape%nr_arrays
666          ar => ape%array_list(j)
667          ar%recvbuf = base_ptr
668       ENDDO
669    ENDDO
670!
671!-- Child to parent direction
672    myindex = 1
673    rcount  = 0
674    bufsize = 8
675
676    myindex_s = 0
677    myindex_r = 0
678
679    DO  i = 1, me%inter_npes
680       ape => me%pes(i)
681       tag = 300
682       DO  j = 1, ape%nr_arrays
683          ar => ape%array_list(j)
684          IF ( ar%nrdims == 2 )  THEN
685             arlen = ape%nrele
686          ELSEIF( ar%nrdims == 3 )  THEN
687             arlen = ape%nrele*ar%a_dim(1)
688          ENDIF
689
690          IF ( ape%nrele > 0 )  THEN
691             ar%sendindex = myindex
692          ELSE
693             ar%sendindex = noindex
694          ENDIF
695
696          myindex_s(j,i-1) = ar%sendindex
697
698          IF ( ape%nrele > 0 )  THEN
699             ar%sendsize = arlen
700             myindex     = myindex + arlen
701             bufsize     = bufsize + arlen
702          ENDIF
703
704       ENDDO
705
706    ENDDO
707!
708!-- Send indices to parent
709
710    CALL MPI_ALLTOALL( myindex_s, lo_nr_arrays, MPI_INTEGER,                   &
711                       myindex_r, lo_nr_arrays, MPI_INTEGER,                   &
712                       me%intra_comm, ierr)
713
714    DEALLOCATE( myindex_s )
715    DEALLOCATE( myindex_r )
716
717!
718!-- Create RMA (one sided communication) window for data buffer child to parent
719!-- transfer.
720!-- The buffer of MPI_GET (counter part of transfer) can be PE-local, i.e. it
721!-- can but must not be part of the MPI RMA window. Only one RMA window is
722!-- required to prepare the data
723!--        for parent -> child transfer on the parent side
724!-- and
725!--        for child -> parent transfer on the child side
726    CALL pmc_alloc_mem( base_array_cp, bufsize )
727    me%totalbuffersize = bufsize * wp  ! total buffer size in byte
728
729    winSize = me%totalbuffersize
730
731    CALL MPI_WIN_CREATE( base_array_cp, winsize, wp, MPI_INFO_NULL,            &
732                         me%intra_comm, me%win_parent_child, ierr )
733    CALL MPI_WIN_FENCE( 0, me%win_parent_child, ierr )
734    CALL MPI_BARRIER( me%intra_comm, ierr )
735!
736!-- Second stride: set buffer pointer
737    DO  i = 1, me%inter_npes
738       ape => me%pes(i)
739       DO  j = 1, ape%nr_arrays
740          ar => ape%array_list(j)         
741          IF ( ape%nrele > 0 )  THEN
742             ar%sendbuf = C_LOC( base_array_cp(ar%sendindex) )
743!
744!--          TODO: if this is an error to be really expected, replace the
745!--                following message by a meaningful standard PALM message using
746!--                the message-routine
747             IF ( ar%sendindex+ar%sendsize > bufsize )  THEN
748                WRITE( 0,'(a,i4,4i7,1x,a)') 'Child buffer too small ', i,      &
749                          ar%sendindex, ar%sendsize, ar%sendindex+ar%sendsize, &
750                          bufsize, TRIM( ar%name )
751                CALL MPI_ABORT( MPI_COMM_WORLD, istat, ierr )
752             ENDIF
753          ENDIF
754       ENDDO
755    ENDDO
756
757 END SUBROUTINE pmc_c_setind_and_allocmem
758
759
760
761 SUBROUTINE pmc_c_getbuffer( waittime, particle_transfer )
762
763    IMPLICIT NONE
764
765    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
766    LOGICAL, INTENT(IN), OPTIONAL   ::  particle_transfer  !<
767
768    LOGICAL                        ::  lo_ptrans!<
769   
770    INTEGER(iwp)                        ::  ierr    !<
771    INTEGER(iwp)                        ::  ij      !<
772    INTEGER(iwp)                        ::  ip      !<
773    INTEGER(iwp)                        ::  j       !<
774    INTEGER(iwp)                        ::  myindex !<
775    INTEGER(iwp)                        ::  nr      !< number of elements to get
776                                                    !< from parent
777    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp
778    INTEGER,DIMENSION(1)           ::  buf_shape
779
780    REAL(wp)                            ::  t1
781    REAL(wp)                            ::  t2
782
783    REAL(wp), POINTER, DIMENSION(:)     ::  buf
784    REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
785    REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
786    TYPE(pedef), POINTER                ::  ape
787    TYPE(arraydef), POINTER             ::  ar
788    INTEGER(idp), POINTER, DIMENSION(:)     ::  ibuf      !<
789    INTEGER(idp), POINTER, DIMENSION(:,:)   ::  idata_2d  !<
790
791!
792!-- Synchronization of the model is done in pmci_synchronize.
793!-- Therefore the RMA window can be filled without
794!-- sychronization at this point and a barrier is not necessary.
795
796!-- In case waittime is present, the following barrier is necessary to
797!-- insure the same number of barrier calls on parent and child
798!-- This means, that here on child side two barriers are call successively
799!-- The parent is filling its buffer between the two barrier calls
800
801!-- Please note that waittime has to be set in pmc_s_fillbuffer AND
802!-- pmc_c_getbuffer
803    IF ( PRESENT( waittime ) )  THEN
804       t1 = pmc_time()
805       CALL MPI_BARRIER( me%intra_comm, ierr )
806       t2 = pmc_time()
807       waittime = t2 - t1
808    ENDIF
809
810    lo_ptrans = .FALSE.
811    IF ( PRESENT( particle_transfer))    lo_ptrans = particle_transfer
812
813!
814!-- Wait for buffer is filled.
815!
816!-- The parent side (in pmc_s_fillbuffer) is filling the buffer in the MPI RMA window
817!-- When the filling is complet, a MPI_BARRIER is called.
818!-- The child is not allowd to access the parent-buffer before it is completely filled
819!-- therefore the following barrier is required.
820
821    CALL MPI_BARRIER( me%intra_comm, ierr )
822
823    DO  ip = 1, me%inter_npes
824       ape => me%pes(ip)
825       DO  j = 1, ape%nr_arrays
826          ar => ape%array_list(j)
827
828          IF ( ar%dimkey == 2 .AND. .NOT.lo_ptrans)  THEN
829             nr = ape%nrele
830          ELSEIF ( ar%dimkey == 3 .AND. .NOT.lo_ptrans)  THEN
831             nr = ape%nrele * ar%a_dim(1)
832          ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
833             nr = ape%nrele
834          ELSE
835             CYCLE                    ! Particle array ar not transferd here
836          ENDIF
837          buf_shape(1) = nr
838          IF ( lo_ptrans )   THEN
839             CALL C_F_POINTER( ar%recvbuf, ibuf, buf_shape )
840          ELSE
841             CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
842          ENDIF
843!
844!--       MPI passive target RMA
845!--       One data array is fetcht from MPI RMA window on parent
846
847          IF ( nr > 0 )  THEN
848             target_disp = ar%recvindex - 1
849             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0,                     &
850                                me%win_parent_child, ierr )
851             IF ( lo_ptrans )   THEN
852                CALL MPI_GET( ibuf, nr*8, MPI_BYTE, ip-1, target_disp, nr*8, MPI_BYTE,  &               !There is no MPI_INTEGER8 datatype
853                                   me%win_parent_child, ierr )
854             ELSE
855                CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr,        &
856                              MPI_REAL, me%win_parent_child, ierr )
857             ENDIF
858             CALL MPI_WIN_UNLOCK( ip-1, me%win_parent_child, ierr )
859          ENDIF
860          myindex = 1
861          IF ( ar%dimkey == 2 .AND. .NOT.lo_ptrans)  THEN
862
863             CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
864             DO  ij = 1, ape%nrele
865                data_2d(ape%locind(ij)%j,ape%locind(ij)%i) = buf(myindex)
866                myindex = myindex + 1
867             ENDDO
868
869          ELSEIF ( ar%dimkey == 3 .AND. .NOT.lo_ptrans)  THEN
870
871             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
872             DO  ij = 1, ape%nrele
873                data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) =                 &
874                                              buf(myindex:myindex+ar%a_dim(1)-1)
875                myindex = myindex+ar%a_dim(1)
876             ENDDO
877
878          ELSEIF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
879             CALL C_F_POINTER( ar%data, idata_2d, ar%a_dim(1:2) )
880
881             DO  ij = 1, ape%nrele
882                idata_2d(ape%locind(ij)%j,ape%locind(ij)%i) = ibuf(myindex)
883                myindex = myindex + 1
884             ENDDO
885
886          ENDIF
887       ENDDO
888    ENDDO
889
890 END SUBROUTINE pmc_c_getbuffer
891
892
893
894 SUBROUTINE pmc_c_putbuffer( waittime , particle_transfer )
895
896    IMPLICIT NONE
897
898    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
899    LOGICAL, INTENT(IN), OPTIONAL   ::  particle_transfer  !<
900
901    LOGICAL ::  lo_ptrans!<
902   
903    INTEGER(iwp) ::  ierr         !<
904    INTEGER(iwp) ::  ij           !<
905    INTEGER(iwp) ::  ip           !<
906    INTEGER(iwp) ::  j            !<
907    INTEGER(iwp) ::  myindex      !<
908
909    INTEGER(iwp), DIMENSION(1) ::  buf_shape    !<
910
911    REAL(wp) ::  t1  !<
912    REAL(wp) ::  t2  !<
913
914    REAL(wp), POINTER, DIMENSION(:)         ::  buf      !<
915    REAL(wp), POINTER, DIMENSION(:,:)       ::  data_2d  !<
916    REAL(wp), POINTER, DIMENSION(:,:,:)     ::  data_3d  !<
917   
918    INTEGER(idp), POINTER, DIMENSION(:)     ::  ibuf      !<
919    INTEGER(idp), POINTER, DIMENSION(:,:)   ::  idata_2d  !<
920
921    TYPE(pedef), POINTER                    ::  ape  !<
922    TYPE(arraydef), POINTER                 ::  ar   !<
923
924!
925!-- Wait for empty buffer
926!-- Switch RMA epoche
927
928    t1 = pmc_time()
929    CALL MPI_BARRIER( me%intra_comm, ierr )
930    t2 = pmc_time()
931    IF ( PRESENT( waittime ) )  waittime = t2 - t1
932
933    lo_ptrans = .FALSE.
934    IF ( PRESENT( particle_transfer))    lo_ptrans = particle_transfer
935
936    DO  ip = 1, me%inter_npes
937       ape => me%pes(ip)
938       DO  j = 1, ape%nr_arrays
939          ar => aPE%array_list(j)
940          myindex = 1
941
942          IF ( ar%dimkey == 2 .AND. .NOT.lo_ptrans )  THEN
943
944             buf_shape(1) = ape%nrele
945             CALL C_F_POINTER( ar%sendbuf, buf,     buf_shape     )
946             CALL C_F_POINTER( ar%data,    data_2d, ar%a_dim(1:2) )
947             DO  ij = 1, ape%nrele
948                buf(myindex) = data_2d(ape%locind(ij)%j,ape%locind(ij)%i)
949                myindex = myindex + 1
950             ENDDO
951
952          ELSEIF ( ar%dimkey == 3 .AND. .NOT.lo_ptrans )  THEN
953
954             buf_shape(1) = ape%nrele*ar%a_dim(1)
955             CALL C_F_POINTER( ar%sendbuf, buf,     buf_shape     )
956             CALL C_F_POINTER( ar%data,    data_3d, ar%a_dim(1:3) )
957             DO  ij = 1, ape%nrele
958                buf(myindex:myindex+ar%a_dim(1)-1) =                            &
959                                    data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i)
960                myindex = myindex + ar%a_dim(1)
961             ENDDO
962
963          ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
964
965             buf_shape(1) = ape%nrele
966             CALL C_F_POINTER( ar%sendbuf, ibuf,     buf_shape     )
967             CALL C_F_POINTER( ar%data,    idata_2d, ar%a_dim(1:2) )
968
969             DO  ij = 1, ape%nrele
970                ibuf(myindex) = idata_2d(ape%locind(ij)%j,ape%locind(ij)%i)
971                myindex = myindex + 1
972             ENDDO
973
974          ENDIF
975       ENDDO
976    ENDDO
977!
978!-- Buffer is filled
979!-- Switch RMA epoche
980
981    CALL MPI_Barrier(me%intra_comm, ierr)
982
983 END SUBROUTINE pmc_c_putbuffer
984
985#endif
986 END MODULE pmc_child
Note: See TracBrowser for help on using the repository browser.