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

Last change on this file since 3245 was 3241, checked in by raasch, 6 years ago

various changes to avoid compiler warnings (mainly removal of unused variables)

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