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

Last change on this file since 4598 was 4360, checked in by suehring, 16 months ago

Bugfix in output of time-averaged plant-canopy quanities; Output of plant-canopy data only where tall canopy is defined; land-surface model: fix wrong location strings; tests: update urban test case; all source code files: copyright update

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