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

Last change on this file since 3846 was 3761, checked in by raasch, 6 years ago

unused variables removed, OpenACC directives re-formatted, statements added to avoid compiler warnings

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