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

Last change on this file since 2834 was 2809, checked in by schwenkel, 7 years ago

Bugfix for gfortran: Replace the function C_SIZEOF with STORAGE_SIZE

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