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

Last change on this file since 2000 was 2000, checked in by knoop, 5 years ago

Forced header and separation lines into 80 columns

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