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

Last change on this file since 3945 was 3945, checked in by raasch, 2 years ago

messed document changes for r3932 cleaned up

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