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

Last change on this file since 3049 was 2841, checked in by knoop, 3 years ago

Bugfix: wrong placement of include 'mpif.h' corrected

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