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

Last change on this file since 2805 was 2801, checked in by thiele, 7 years ago

Introduce particle transfer in nested models

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