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

Last change on this file since 2718 was 2718, checked in by maronga, 4 years ago

deleting of deprecated files; headers updated where needed

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