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

Last change on this file since 3741 was 3655, checked in by knoop, 6 years ago

Bugfix: made "unit" and "found" intend INOUT in module interface subroutines + automatic copyright update

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