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

Last change on this file since 4793 was 4649, checked in by raasch, 4 years ago

files re-formatted to follow the PALM coding standard

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