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

Last change on this file since 2801 was 2801, checked in by thiele, 3 years ago

Introduce particle transfer in nested models

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