source: palm/trunk/SOURCE/pmc_parent_mod.f90 @ 4869

Last change on this file since 4869 was 4830, checked in by Giersch, 4 years ago

Reformatted to follow PALM coding standard

  • Property svn:keywords set to Id
File size: 38.8 KB
Line 
1!> @file pmc_parent_mod.f90
2!--------------------------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
6! Public License as published by the Free Software Foundation, either version 3 of the License, or
7! (at your option) any later version.
8!
9! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
10! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
11! Public License for more details.
12!
13! You should have received a copy of the GNU General Public License along with PALM. If not, see
14! <http://www.gnu.org/licenses/>.
15!
16! Copyright 1997-2021 Leibniz Universitaet Hannover
17!--------------------------------------------------------------------------------------------------!
18!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: pmc_parent_mod.f90 4830 2021-01-06 11:25:45Z schwenkel $
27! Reformatted to follow PALM coding standard
28!
29! 4828 2021-01-05 11:21:41Z Giersch
30! pmc_s_set_2d_index_list revised for accelerating the code. Subroutine
31! description added.
32!
33! 4649 2020-08-25 12:11:17Z raasch
34! File re-formatted to follow the PALM coding standard
35!
36!
37! 4629 2020-07-29 09:37:56Z raasch
38! Support for MPI Fortran77 interface (mpif.h) removed
39!
40! 4360 2020-01-07 11:25:50Z suehring
41!
42!
43! 4213 2019-09-02 14:25:56Z suehring
44! Allocate array for index_list_2d also for zero-size arrays, in order to avoid errors when array
45! bound checks are enabled
46!
47! 4212 2019-09-02 14:23:05Z suehring
48! Corrected "Former revisions" section
49!
50! 3962 2019-05-08 19:40:33Z suehring
51! Bugfixes in initial settings of child and parent communication patterns.
52!
53! 3655 2019-01-07 16:51:22Z knoop
54! Explicit kind settings
55!
56! 1762 2016-02-25 12:31:13Z hellstea
57! Initial revision by K. Ketelsen
58!
59! Authors:
60! --------
61!> @author Klaus Ketelsen (no affiliation)
62!
63! Description:
64! ------------
65!> Parent part of Palm Model Coupler
66!--------------------------------------------------------------------------------------------------!
67 MODULE pmc_parent
68
69#if defined( __parallel )
70    USE, INTRINSIC ::  ISO_C_BINDING
71
72    USE MPI
73
74    USE kinds
75
76    USE pmc_general,                                                                               &
77        ONLY: arraydef,                                                                            &
78              childdef,                                                                            &
79              da_namedef,                                                                          &
80              da_namelen,                                                                          &
81              pedef,                                                                               &
82              pmc_g_setname,                                                                       &
83              pmc_max_array,                                                                       &
84              pmc_max_models
85
86    USE pmc_handle_communicator,                                                                   &
87        ONLY: m_model_comm,                                                                        &
88              m_model_rank,                                                                        &
89              m_model_npes,                                                                        &
90              m_to_child_comm,                                                                     &
91              m_world_rank,                                                                        &
92              pmc_parent_for_child
93
94    USE pmc_mpi_wrapper,                                                                           &
95        ONLY: pmc_alloc_mem,                                                                       &
96              pmc_bcast,                                                                           &
97              pmc_time
98
99
100    IMPLICIT NONE
101
102    INTEGER ::  next_array_in_list = 0  !<
103
104    TYPE childindexdef
105       INTEGER ::  nrpoints  !<
106
107       INTEGER, DIMENSION(:,:), ALLOCATABLE ::  index_list_2d  !<
108    END TYPE childindexdef
109
110    TYPE(childdef), DIMENSION(pmc_max_models) ::  children  !<
111
112    TYPE(childindexdef), DIMENSION(pmc_max_models) ::  indchildren  !<
113
114    SAVE
115
116    PRIVATE
117
118!
119!-- Public functions
120    PUBLIC pmc_parent_for_child
121
122!
123!-- Public variables, constants and types
124    PUBLIC children,                                                                               &
125           pmc_parentinit,                                                                         &
126           pmc_s_clear_next_array_list,                                                            &
127           pmc_s_fillbuffer,                                                                       &
128           pmc_s_getdata_from_buffer,                                                              &
129           pmc_s_getnextarray,                                                                     &
130           pmc_s_setind_and_allocmem,                                                              &
131           pmc_s_set_active_data_array,                                                            &
132           pmc_s_set_dataarray,                                                                    &
133           pmc_s_set_2d_index_list,                                                                &
134           pmc_s_get_child_npes
135
136    INTERFACE pmc_parentinit
137       MODULE PROCEDURE  pmc_parentinit
138    END INTERFACE pmc_parentinit
139
140    INTERFACE pmc_s_set_2d_index_list
141       MODULE PROCEDURE pmc_s_set_2d_index_list
142    END INTERFACE pmc_s_set_2d_index_list
143
144    INTERFACE pmc_s_clear_next_array_list
145       MODULE PROCEDURE pmc_s_clear_next_array_list
146    END INTERFACE pmc_s_clear_next_array_list
147
148    INTERFACE pmc_s_getnextarray
149       MODULE PROCEDURE pmc_s_getnextarray
150    END INTERFACE pmc_s_getnextarray
151
152    INTERFACE pmc_s_set_dataarray
153       MODULE PROCEDURE pmc_s_set_dataarray_2d
154       MODULE PROCEDURE pmc_s_set_dataarray_3d
155       MODULE PROCEDURE pmc_s_set_dataarray_ip2d
156    END INTERFACE pmc_s_set_dataarray
157
158    INTERFACE pmc_s_setind_and_allocmem
159       MODULE PROCEDURE pmc_s_setind_and_allocmem
160    END INTERFACE pmc_s_setind_and_allocmem
161
162    INTERFACE pmc_s_fillbuffer
163       MODULE PROCEDURE pmc_s_fillbuffer
164    END INTERFACE pmc_s_fillbuffer
165
166    INTERFACE pmc_s_getdata_from_buffer
167       MODULE PROCEDURE pmc_s_getdata_from_buffer
168    END INTERFACE pmc_s_getdata_from_buffer
169
170    INTERFACE pmc_s_set_active_data_array
171       MODULE PROCEDURE pmc_s_set_active_data_array
172    END INTERFACE pmc_s_set_active_data_array
173
174    INTERFACE pmc_s_get_child_npes
175       MODULE PROCEDURE pmc_s_get_child_npes
176    END INTERFACE pmc_s_get_child_npes
177
178
179 CONTAINS
180
181
182!--------------------------------------------------------------------------------------------------!
183! Description:
184! ------------
185!> If this thread is intended as parent, initialize parent part of parent-client data transfer
186!--------------------------------------------------------------------------------------------------!
187 SUBROUTINE pmc_parentinit
188
189    INTEGER(iwp) ::  childid  !<
190    INTEGER(iwp) ::  i        !<
191    INTEGER(iwp) ::  istat    !<
192    INTEGER(iwp) ::  j        !<
193
194
195    DO  i = 1, SIZE( pmc_parent_for_child ) - 1
196       childid = pmc_parent_for_child( i )
197
198       children(childid)%model_comm = m_model_comm
199       children(childid)%inter_comm = m_to_child_comm(childid)
200
201!
202!--    Get rank and size
203       CALL MPI_COMM_RANK( children(childid)%model_comm, children(childid)%model_rank, istat )
204       CALL MPI_COMM_SIZE( children(childid)%model_comm, children(childid)%model_npes, istat )
205       CALL MPI_COMM_REMOTE_SIZE( children(childid)%inter_comm, children(childid)%inter_npes,      &
206                                  istat )
207
208!
209!--    Intra communicator is used for MPI_GET
210       CALL MPI_INTERCOMM_MERGE( children(childid)%inter_comm, .FALSE.,                            &
211                                 children(childid)%intra_comm, istat )
212       CALL MPI_COMM_RANK( children(childid)%intra_comm, children(childid)%intra_rank, istat )
213
214       ALLOCATE( children(childid)%pes(children(childid)%inter_npes) )
215
216!
217!--    Allocate array of TYPE arraydef for all child PEs to store information of the transfer array
218       DO  j = 1, children(childid)%inter_npes
219         ALLOCATE( children(childid)%pes(j)%array_list(pmc_max_array) )
220       ENDDO
221
222       CALL get_da_names_from_child( childid )
223    ENDDO
224
225 END SUBROUTINE pmc_parentinit
226
227
228!--------------------------------------------------------------------------------------------------!
229! Description:
230! ------------
231!> thread 0 transfers the index list, which contains all parent grid cells involved in
232!> parent client data transfer to the thread, on which this grid cell is located
233!--------------------------------------------------------------------------------------------------!
234 SUBROUTINE pmc_s_set_2d_index_list( childid, index_list )
235
236     INTEGER(iwp) ::  ian        !<
237     INTEGER(iwp) ::  i          !<
238     INTEGER(iwp) ::  ip         !<
239     INTEGER(iwp) ::  istat      !<
240     INTEGER(iwp) ::  max_cells  !<
241
242     INTEGER(iwp), INTENT(IN) ::  childid  !<
243
244     INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) ::  index_list  !<
245
246     INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  cells_on_pe  !<
247
248     INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE ::  lo_ind_list  !<
249
250
251     IF ( m_model_rank == 0 )  THEN
252!
253!--     Compute maximum number of grid cells located on one parent thread
254        ALLOCATE( cells_on_pe(0:m_model_npes-1) )
255        cells_on_pe = 0
256
257        DO  i = 1, SIZE( index_list, 2 )
258           cells_on_pe(index_list(6,i )) = cells_on_pe(index_list(6,i ))+1
259        ENDDO
260
261        max_cells = MAXVAL( cells_on_pe )
262
263!
264!--     Allocate temp array for thread dependent transfer of index_list
265        ALLOCATE( lo_ind_list(SIZE( index_list,1 ),max_cells) )
266
267        DO  ip = 0, m_model_npes-1
268!
269!--        Split into parent processes
270           ian = 0
271
272           DO  i = 1, SIZE( index_list, 2 )
273              IF ( index_list(6,i) == ip )  THEN
274                 ian = ian+1
275                 lo_ind_list(:,ian) = index_list(:,i)
276              ENDIF
277           ENDDO
278
279!
280!--        Send data to other parent processes
281           IF ( ip == 0 )  THEN
282              indchildren(childid)%nrpoints = ian
283!
284!--           Allocate array for index_list_2d. Note, the array will also be allocated in case
285!--           ian = 0, in order to avoid errors when array bounds are checked.
286              ALLOCATE( indchildren(childid)%index_list_2d(6,1:ian) )
287              IF ( ian > 0 )  THEN
288                  indchildren(childid)%index_list_2d(:,1:ian) = lo_ind_list(:,1:ian)
289              ENDIF
290           ELSE
291              CALL MPI_SEND( ian, 1, MPI_INTEGER, ip, 1000, m_model_comm, istat )
292              IF ( ian > 0 )  THEN
293                  CALL MPI_SEND( lo_ind_list, 6*ian, MPI_INTEGER, ip, 1001, m_model_comm, istat )
294              ENDIF
295           ENDIF
296        ENDDO
297
298        DEALLOCATE( lo_ind_list )
299        DEALLOCATE( cells_on_pe )
300     ELSE
301        CALL MPI_RECV( indchildren(childid)%nrpoints, 1, MPI_INTEGER, 0, 1000, m_model_comm,       &
302                       MPI_STATUS_IGNORE, istat )
303        ian = indchildren(childid)%nrpoints
304!
305!--     Allocate array for index_list_2d. Note, the array will also be allocated in case ian=0, in
306!--     order to avoid errors when array bounds are checked.
307        ALLOCATE( indchildren(childid)%index_list_2d(6,1:ian) )
308        IF ( ian > 0 )  THEN
309           CALL MPI_RECV( indchildren(childid)%index_list_2d, 6*ian, MPI_INTEGER, 0, 1001,         &
310                          m_model_comm, MPI_STATUS_IGNORE, istat)
311        ENDIF
312     ENDIF
313
314     CALL set_pe_index_list( children(childid), indchildren(childid)%index_list_2d,                &
315                             indchildren(childid)%nrpoints )
316
317 END SUBROUTINE pmc_s_set_2d_index_list
318
319
320!--------------------------------------------------------------------------------------------------!
321! Description:
322! ------------
323!> Before creating an array list with arrays schedule for parent client transfer
324!> make sure that the list is empty
325!--------------------------------------------------------------------------------------------------!
326 SUBROUTINE pmc_s_clear_next_array_list
327
328    next_array_in_list = 0
329
330 END SUBROUTINE pmc_s_clear_next_array_list
331
332
333 LOGICAL FUNCTION pmc_s_getnextarray( childid, myname )
334
335!
336!-- Althoug there are no linked lists any more in PMC, this call still looks like working with a list
337    CHARACTER(LEN=*), INTENT(OUT) ::  myname  !<
338
339    INTEGER(iwp), INTENT(IN) ::  childid  !<
340
341    TYPE(pedef),    POINTER ::  ape  !<
342
343    TYPE(arraydef), POINTER ::  ar  !<
344
345
346    next_array_in_list = next_array_in_list + 1
347
348!
349!-- Array names are the same on all children processes, so take first process to get the name
350    ape => children(childid)%pes(1)
351
352    IF ( next_array_in_list > ape%nr_arrays )  THEN
353!
354!--    All arrays are done
355       pmc_s_getnextarray = .FALSE.
356       RETURN
357    ENDIF
358
359    ar => ape%array_list(next_array_in_list)
360    myname = ar%name
361
362!
363!-- Return true if there is still an array in the list
364    pmc_s_getnextarray = .TRUE.
365
366 END FUNCTION pmc_s_getnextarray
367
368
369!--------------------------------------------------------------------------------------------------!
370! Description:
371! ------------
372!> add 2D real array to list of arrays scheduled for parent-client transfer
373!--------------------------------------------------------------------------------------------------!
374 SUBROUTINE pmc_s_set_dataarray_2d( childid, array, array_2 )
375
376    INTEGER(iwp) ::  nrdims  !<
377
378    INTEGER(iwp), INTENT(IN) ::  childid  !<
379
380    INTEGER(iwp), DIMENSION(4) ::  dims  !<
381
382    REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER ::  array  !<
383
384    REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER, OPTIONAL ::  array_2  !<
385
386    TYPE(C_PTR) ::  array_adr   !<
387    TYPE(C_PTR) ::  second_adr  !<
388
389
390    dims      = 1
391    nrdims    = 2
392    dims(1)   = SIZE( array, 1 )
393    dims(2)   = SIZE( array, 2 )
394    array_adr = C_LOC( array )
395
396    IF ( PRESENT( array_2 ) )  THEN
397       second_adr = C_LOC( array_2 )
398       CALL pmc_s_setarray( childid, nrdims, dims, array_adr, second_adr = second_adr )
399    ELSE
400       CALL pmc_s_setarray( childid, nrdims, dims, array_adr )
401    ENDIF
402
403 END SUBROUTINE pmc_s_set_dataarray_2d
404
405
406!--------------------------------------------------------------------------------------------------!
407! Description:
408! ------------
409!> add 2D integer array to list of arrays scheduled for parent-client transfer
410!--------------------------------------------------------------------------------------------------!
411 SUBROUTINE pmc_s_set_dataarray_ip2d( childid, array )
412
413    INTEGER(iwp) ::  nrdims  !<
414
415    INTEGER(iwp), DIMENSION(4) ::  dims  !<
416
417    INTEGER(iwp), INTENT(IN) ::  childid  !<
418
419    INTEGER(idp), INTENT(IN), DIMENSION(:,:), POINTER ::  array  !<
420
421    TYPE(C_PTR) ::  array_adr  !<
422
423
424    dims      = 1
425    nrdims    = 2
426    dims(1)   = SIZE( array, 1 )
427    dims(2)   = SIZE( array, 2 )
428    array_adr = C_LOC( array )
429
430    CALL pmc_s_setarray( childid, nrdims, dims, array_adr , dimkey = 22 )
431
432 END SUBROUTINE pmc_s_set_dataarray_ip2d
433
434
435!--------------------------------------------------------------------------------------------------!
436! Description:
437! ------------
438!> add 3D real array to list of arrays scheduled for parent-client transfer
439!--------------------------------------------------------------------------------------------------!
440 SUBROUTINE pmc_s_set_dataarray_3d( childid, array, nz_cl, nz, array_2 )
441
442    INTEGER(iwp) ::  nrdims  !<
443
444    INTEGER(iwp), INTENT(IN) ::  childid  !<
445    INTEGER(iwp), INTENT(IN) ::  nz       !<
446    INTEGER(iwp), INTENT(IN) ::  nz_cl    !<
447
448    INTEGER(iwp), DIMENSION(4) ::  dims  !<
449
450    REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER ::  array  !<
451
452    REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER, OPTIONAL ::  array_2  !<
453
454    TYPE(C_PTR) ::  array_adr   !<
455    TYPE(C_PTR) ::  second_adr  !<
456
457
458    nrdims  = 3
459    dims(1) = SIZE( array, 1 )
460    dims(2) = SIZE( array, 2 )
461    dims(3) = SIZE( array, 3 )
462    dims(4) = nz_cl+dims(1)-nz  ! Works for first dimension 1:nz and 0:nz+1
463
464    array_adr = C_LOC( array )
465!
466!-- In PALM's pointer version, two indices have to be stored internally.
467!-- The active address of the data array is set in swap_timelevel.
468    IF ( PRESENT( array_2 ) )  THEN
469      second_adr = C_LOC( array_2 )
470      CALL pmc_s_setarray( childid, nrdims, dims, array_adr, second_adr = second_adr )
471    ELSE
472       CALL pmc_s_setarray( childid, nrdims, dims, array_adr )
473    ENDIF
474
475 END SUBROUTINE pmc_s_set_dataarray_3d
476
477
478!--------------------------------------------------------------------------------------------------!
479! Description:
480! ------------
481!> Naming convention for appendices:   _pc  -> parent to child transfer
482!>                                     _cp  -> child to parent transfer
483!>                                     send -> parent to child transfer
484!>                                     recv -> child to parent transfer
485!>
486!> @todo: Missing subroutine description.
487!--------------------------------------------------------------------------------------------------!
488 SUBROUTINE pmc_s_setind_and_allocmem( childid )
489
490    USE control_parameters,                                                                        &
491        ONLY:  message_string
492
493    INTEGER(iwp) ::  arlen         !<
494    INTEGER(iwp) ::  i             !<
495    INTEGER(iwp) ::  ierr          !<
496    INTEGER(iwp) ::  j             !<
497    INTEGER(iwp) ::  lo_nr_arrays  !< store number of arrays in  local variiab le
498    INTEGER(iwp) ::  myindex       !<
499    INTEGER(iwp) ::  total_npes    !< Total Number of PEs Parent and Child
500    INTEGER(idp) ::  bufsize       !< size of MPI data window
501
502    INTEGER(iwp), INTENT(IN) ::  childid  !<
503
504    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
505
506    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE ::  myindex_s  !<
507    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE ::  myindex_r  !<
508
509    REAL(wp),DIMENSION(:), POINTER, SAVE ::  base_array_cp  !< base array for child to parent transfer
510    REAL(wp),DIMENSION(:), POINTER, SAVE ::  base_array_pc  !< base array for parent to child transfer
511
512    TYPE(C_PTR) ::  base_ptr  !<
513
514    TYPE(pedef), POINTER ::  ape  !<
515
516    TYPE(arraydef), POINTER ::  ar   !<
517
518
519    call MPI_COMM_SIZE( children(childid)%intra_comm, total_npes, ierr )
520!
521!-- Parent to child direction
522    myindex = 1
523    bufsize = 8
524
525!
526!-- All Child processes get the same number of arrays.
527!-- Therfore the number of arrays form the first Child process can be used for Dimension.
528    lo_nr_arrays = children(childid)%pes(1)%nr_arrays
529
530    ALLOCATE( myindex_s(lo_nr_arrays,0:total_npes-1) )
531    ALLOCATE( myindex_r(lo_nr_arrays,0:total_npes-1) )
532
533    myindex_s = 0
534
535!
536!-- First stride: compute size and set index
537    DO  i = 1, children(childid)%inter_npes
538       ape => children(childid)%pes(i)
539       DO  j = 1, ape%nr_arrays
540          ar  => ape%array_list(j)
541          IF ( ar%nrdims == 2 )  THEN
542             arlen = ape%nrele
543          ELSEIF ( ar%nrdims == 3 )  THEN
544             arlen = ape%nrele * ar%a_dim(4)
545          ELSE
546             arlen = -1
547          ENDIF
548          ar%sendindex = myindex
549
550!
551!--       Using intra communicator for MPU_Alltoall, the numbers of the child processes are after
552!--       the parent ones.
553          myindex_s(j,i-1+children(childid)%model_npes) = myindex
554
555          myindex = myindex + arlen
556          bufsize = bufsize + arlen
557          ar%sendsize = arlen
558       ENDDO
559    ENDDO
560
561!
562!-- Using MPI_Alltoall to send indices from  Parent to Child
563!-- The data comming back from the child processes are ignored.
564    CALL MPI_ALLTOALL( myindex_s, lo_nr_arrays, MPI_INTEGER, myindex_r, lo_nr_arrays, MPI_INTEGER, &
565                       children(childid)%intra_comm, ierr )
566
567!
568!-- Using MPI_Alltoall to receive indices from Child
569    myindex_s = 0
570    myindex_r = 0
571
572    CALL MPI_ALLTOALL( myindex_s, lo_nr_arrays, MPI_INTEGER, myindex_r, lo_nr_arrays, MPI_INTEGER, &
573                       children(childid)%intra_comm, ierr )
574
575!
576!-- Create RMA (One Sided Communication) window for data buffer parent to child transfer.
577!-- The buffer of MPI_GET (counterpart of transfer) can be PE-local, i.e. it can but must not be
578!-- part of the MPI RMA window. Only one RMA window is required to prepare the data for:
579!--          parent -> child transfer on the parent side
580!-- and for:
581!--          child -> parent transfer on the child side
582    CALL pmc_alloc_mem( base_array_pc, bufsize )
583    children(childid)%totalbuffersize = bufsize * wp
584
585    winsize = bufsize * wp
586    CALL MPI_WIN_CREATE( base_array_pc, winsize, wp, MPI_INFO_NULL, children(childid)%intra_comm,  &
587                         children(childid)%win_parent_child, ierr )
588
589!
590!-- Open window to set data
591    CALL MPI_WIN_FENCE( 0, children(childid)%win_parent_child, ierr )
592
593!
594!-- Second stride: set buffer pointer
595    DO  i = 1, children(childid)%inter_npes
596       ape => children(childid)%pes(i)
597       DO  j = 1, ape%nr_arrays
598          ar => ape%array_list(j)
599          ar%sendbuf = C_LOC( base_array_pc(ar%sendindex) )
600          IF ( ar%sendindex + ar%sendsize > bufsize )  THEN
601             WRITE( message_string, '(a,i4,4i7,1x,a)' ) 'parent buffer too small ',i ,             &
602                    ar%sendindex, ar%sendsize, ar%sendindex + ar%sendsize, bufsize, TRIM( ar%name )
603             CALL message( 'pmc_s_setind_and_allocmem', 'PA0429', 3, 2, 0, 6, 0 )
604          ENDIF
605       ENDDO
606    ENDDO
607
608!
609!-- Child to parent direction
610    bufsize = 8
611
612!
613!-- First stride: compute size and set index
614    DO  i = 1, children(childid)%inter_npes
615       ape => children(childid)%pes(i)
616       DO  j = 1, ape%nr_arrays
617          ar => ape%array_list(j)
618!
619!--       Receive index from child
620          IF ( ar%nrdims == 3 )  THEN
621             bufsize = MAX( bufsize, INT( ape%nrele * ar%a_dim(4), MPI_ADDRESS_KIND ) )
622          ELSE
623             bufsize = MAX( bufsize, INT( ape%nrele, MPI_ADDRESS_KIND ) )
624          ENDIF
625          ar%recvindex = myindex_r(j,i-1+children(childid)%model_npes)
626        ENDDO
627    ENDDO
628
629    DEALLOCATE( myindex_s )
630    DEALLOCATE( myindex_r )
631
632!
633!-- Create RMA (one sided communication, RMA = Remote Memory Access) data buffer.
634!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of the MPI RMA window.
635    CALL pmc_alloc_mem( base_array_cp, bufsize, base_ptr )
636    children(childid)%totalbuffersize = bufsize * wp
637
638    CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
639
640!
641!-- Second stride: set buffer pointer
642    DO  i = 1, children(childid)%inter_npes
643       ape => children(childid)%pes(i)
644       DO  j = 1, ape%nr_arrays
645          ar => ape%array_list(j)
646          ar%recvbuf = base_ptr
647       ENDDO
648    ENDDO
649
650 END SUBROUTINE pmc_s_setind_and_allocmem
651
652
653!--------------------------------------------------------------------------------------------------!
654! Description:
655! ------------
656!> Fill buffer in RMA window to enable the client to fetch the dat with MPI_Get
657!--------------------------------------------------------------------------------------------------!
658 SUBROUTINE pmc_s_fillbuffer( childid, waittime, particle_transfer )
659
660    INTEGER(iwp) ::  ierr     !<
661    INTEGER(iwp) ::  ij       !<
662    INTEGER(iwp) ::  ip       !<
663    INTEGER(iwp) ::  j        !<
664    INTEGER(iwp) ::  myindex  !<
665
666    INTEGER(iwp), INTENT(IN) ::  childid   !<
667
668    INTEGER(iwp), DIMENSION(1) ::  buf_shape  !<
669
670    INTEGER(idp), POINTER, DIMENSION(:) ::  ibuf  !<
671
672    INTEGER(idp), POINTER, DIMENSION(:,:) ::  idata_2d  !<
673
674    LOGICAL ::  lo_ptrans  !<
675
676    LOGICAL, INTENT(IN), OPTIONAL   ::  particle_transfer  !<
677
678    REAL(wp) ::  t1  !<
679    REAL(wp) ::  t2  !<
680
681    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
682
683    REAL(wp), POINTER, DIMENSION(:) ::  buf  !<
684
685    REAL(wp), POINTER, DIMENSION(:,:) ::  data_2d  !<
686
687    REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d  !<
688
689    TYPE(pedef), POINTER ::  ape  !<
690
691    TYPE(arraydef), POINTER ::  ar   !<
692
693!
694!-- Synchronization of the model is done in pmci_synchronize. Therefor the RMA window can be filled
695!-- without sychronization at this point and a barrier is not necessary.
696!-- Please note that waittime has to be set in pmc_s_fillbuffer AND pmc_c_getbuffer.
697    IF ( PRESENT( waittime ) )  THEN
698      t1 = pmc_time()
699      CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
700      t2 = pmc_time()
701      waittime = t2 - t1
702    ENDIF
703
704    lo_ptrans = .FALSE.
705    IF ( PRESENT( particle_transfer ) )    lo_ptrans = particle_transfer
706
707    DO  ip = 1, children(childid)%inter_npes
708       ape => children(childid)%pes(ip)
709       DO  j = 1, ape%nr_arrays
710          ar => ape%array_list(j)
711          myindex = 1
712          IF ( ar%dimkey == 2 .AND. .NOT.lo_ptrans  )  THEN         ! PALM 2D REAL*8 Array
713             buf_shape(1) = ape%nrele
714             CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
715             CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
716             DO  ij = 1, ape%nrele
717                buf(myindex) = data_2d(ape%locind(ij)%j,ape%locind(ij)%i)
718                myindex = myindex + 1
719             ENDDO
720          ELSEIF ( ar%dimkey == 3  .AND. .NOT.lo_ptrans  )  THEN      ! PALM 3D REAL*8 Array
721             buf_shape(1) = ape%nrele*ar%a_dim(4)
722             CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
723             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
724             DO  ij = 1, ape%nrele
725                buf(myindex:myindex+ar%a_dim(4)-1) =                                               &
726                data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i)
727                myindex = myindex + ar%a_dim(4)
728             ENDDO
729          ELSEIF ( ar%dimkey == 22 .AND. lo_ptrans  )  THEN  ! 2D INTEGER*8 Array for particle Transfer
730             buf_shape(1) = ape%nrele
731             CALL C_F_POINTER( ar%sendbuf, ibuf, buf_shape )
732             CALL C_F_POINTER( ar%data, idata_2d, ar%a_dim(1:2) )
733             DO  ij = 1, ape%nrele
734                ibuf(myindex) = idata_2d(ape%locind(ij)%j,ape%locind(ij)%i)
735                myindex = myindex + 1
736             ENDDO
737          ENDIF
738        ENDDO
739    ENDDO
740
741!
742!-- Buffer is filled
743    CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
744
745 END SUBROUTINE pmc_s_fillbuffer
746
747
748!--------------------------------------------------------------------------------------------------!
749! Description:
750! ------------
751!> Get client data from RMM window
752!--------------------------------------------------------------------------------------------------!
753 SUBROUTINE pmc_s_getdata_from_buffer( childid, waittime , particle_transfer, child_process_nr )
754
755    INTEGER(iwp) ::  ierr       !<
756    INTEGER(iwp) ::  ij         !<
757    INTEGER(iwp) ::  ip         !<
758    INTEGER(iwp) ::  ip_start   !<
759    INTEGER(iwp) ::  ip_end     !<
760    INTEGER(iwp) ::  j          !<
761    INTEGER(iwp) ::  myindex    !<
762    INTEGER(iwp) ::  nr         !<
763    INTEGER(iwp) ::  target_pe  !<
764
765    INTEGER(iwp), INTENT(IN) ::  childid  !<
766
767    INTEGER(iwp), INTENT(IN), OPTIONAL ::  child_process_nr  !<
768
769    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp  !<
770
771    INTEGER(iwp), DIMENSION(1) ::  buf_shape  !<
772
773    INTEGER(idp), POINTER, DIMENSION(:) ::  ibuf  !<
774
775    INTEGER(idp), POINTER, DIMENSION(:,:) ::  idata_2d  !<
776
777    LOGICAL ::  lo_ptrans  !<
778
779    LOGICAL, INTENT(IN), OPTIONAL ::  particle_transfer  !<
780
781    REAL(wp) ::  t1  !<
782    REAL(wp) ::  t2  !<
783
784    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
785
786    REAL(wp), POINTER, DIMENSION(:) ::  buf  !<
787
788    REAL(wp), POINTER, DIMENSION(:,:) ::  data_2d  !<
789
790    REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d  !<
791
792    TYPE(pedef), POINTER  ::  ape  !<
793
794    TYPE(arraydef), POINTER ::  ar   !<
795
796
797    t1 = pmc_time()
798
799    IF( PRESENT( child_process_nr ) )  THEN
800       ip_start = child_process_nr
801       ip_end   = child_process_nr
802    ELSE
803       ip_start = 1
804       ip_end   = children(childid)%inter_npes
805    END IF
806
807    lo_ptrans = .FALSE.
808    IF ( PRESENT( particle_transfer ) )  lo_ptrans = particle_transfer
809
810    IF(ip_start == 1)  THEN
811!
812!--    Wait for child to fill buffer
813       CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
814       t2 = pmc_time() - t1
815       IF ( PRESENT( waittime ) )  waittime = t2
816
817       CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
818    ENDIF
819
820    DO  ip = ip_start, ip_end
821       ape => children(childid)%pes(ip)
822       DO  j = 1, ape%nr_arrays
823          ar => ape%array_list(j)
824
825          IF ( ar%recvindex < 0 )  CYCLE
826
827          IF ( ar%dimkey == 2  .AND.  .NOT. lo_ptrans  )  THEN
828             nr = ape%nrele
829          ELSEIF ( ar%dimkey == 3  .AND.  .NOT. lo_ptrans  )  THEN
830             nr = ape%nrele * ar%a_dim(4)
831          ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
832             nr = ape%nrele
833          ELSE
834             CYCLE            ! Particle arrays are not transfered here
835          ENDIF
836
837          buf_shape(1) = nr
838
839          IF(lo_ptrans)   THEN
840             CALL C_F_POINTER( ar%recvbuf, ibuf, buf_shape )
841          ELSE
842             CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
843          ENDIF
844
845!
846!--       MPI passive target RMA
847          IF ( nr > 0 )  THEN
848             target_disp = ar%recvindex - 1
849!
850!--          Child processes are located behind parent process
851             target_pe = ip - 1 + m_model_npes
852             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED, target_pe, 0, children(childid)%win_parent_child, &
853                                ierr )
854             IF ( lo_ptrans )  THEN
855                CALL MPI_GET( ibuf, nr * 8, MPI_BYTE, target_pe, target_disp, nr * 8,              &
856                              !There is no MPI_INTEGER8 datatype
857                              MPI_BYTE, children(childid)%win_parent_child, ierr )
858             ELSE
859                CALL MPI_GET( buf, nr, MPI_REAL, target_pe, target_disp, nr, MPI_REAL,             &
860                              children(childid)%win_parent_child, ierr )
861             ENDIF
862             CALL MPI_WIN_UNLOCK( target_pe, children(childid)%win_parent_child, ierr )
863          ENDIF
864
865          myindex = 1
866
867          IF ( ar%dimkey == 2  .AND.  .NOT. lo_ptrans )  THEN
868             CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
869             DO  ij = 1, ape%nrele
870                data_2d(ape%locind(ij)%j,ape%locind(ij)%i) = buf(myindex)
871                myindex = myindex + 1
872             ENDDO
873          ELSE IF ( ar%dimkey == 3  .AND.  .NOT. lo_ptrans )  THEN
874             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
875             DO  ij = 1, ape%nrele
876                data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i) =                         &
877                buf(myindex:myindex+ar%a_dim(4)-1)
878                myindex = myindex + ar%a_dim(4)
879             ENDDO
880          ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
881             CALL C_F_POINTER( ar%data, idata_2d, ar%a_dim(1:2) )
882             DO  ij = 1, ape%nrele
883                idata_2d(ape%locind(ij)%j,ape%locind(ij)%i) = ibuf(myindex)
884                myindex = myindex + 1
885             ENDDO
886          ENDIF
887       ENDDO
888    ENDDO
889
890 END SUBROUTINE pmc_s_getdata_from_buffer
891
892
893!--------------------------------------------------------------------------------------------------!
894! Description:
895! ------------
896!> broadcast name of transfer arrays from child thread 0 to parent threads
897!--------------------------------------------------------------------------------------------------!
898 SUBROUTINE get_da_names_from_child( childid )
899
900!
901!-- Get data array description and name from child
902    INTEGER(iwp), INTENT(IN) ::  childid  !<
903
904    TYPE(da_namedef) ::  myname  !<
905
906
907    DO
908       CALL pmc_bcast( myname%couple_index, 0, comm=m_to_child_comm(childid) )
909
910       IF ( myname%couple_index == -1 )  EXIT
911
912       CALL pmc_bcast( myname%parentdesc,   0, comm=m_to_child_comm(childid) )
913       CALL pmc_bcast( myname%nameonparent, 0, comm=m_to_child_comm(childid) )
914       CALL pmc_bcast( myname%childdesc,    0, comm=m_to_child_comm(childid) )
915       CALL pmc_bcast( myname%nameonchild,  0, comm=m_to_child_comm(childid) )
916
917       CALL pmc_g_setname( children(childid), myname%couple_index, myname%nameonparent )
918   ENDDO
919
920 END SUBROUTINE get_da_names_from_child
921
922
923!--------------------------------------------------------------------------------------------------!
924! Description:
925! ------------
926!> @todo: Missing subroutine description.
927!--------------------------------------------------------------------------------------------------!
928 SUBROUTINE pmc_s_setarray( childid, nrdims, dims, array_adr, second_adr, dimkey )
929
930!
931!-- Set array for child inter process 0
932    INTEGER(iwp) ::  i  !< local counter
933
934    INTEGER(iwp), INTENT(IN) :: childid  !<
935    INTEGER(iwp), INTENT(IN) :: nrdims   !<
936
937    INTEGER(iwp), INTENT(IN), OPTIONAL :: dimkey  !<
938
939    INTEGER(iwp), INTENT(IN), DIMENSION(:) :: dims  !<
940
941    TYPE(C_PTR), INTENT(IN) :: array_adr  !<
942
943    TYPE(C_PTR), INTENT(IN), OPTIONAL ::  second_adr  !<
944
945    TYPE(pedef), POINTER ::  ape  !<
946
947    TYPE(arraydef), POINTER ::  ar   !<
948
949
950    DO  i = 1, children(childid)%inter_npes
951       ape => children(childid)%pes(i)
952       ar  => ape%array_list(next_array_in_list)
953       ar%nrdims = nrdims
954       ar%dimkey = nrdims
955
956       IF( PRESENT( dimkey ) )  ar%dimkey = dimkey
957       ar%a_dim  = dims
958       ar%data   = array_adr
959       IF ( PRESENT( second_adr ) )  THEN
960          ar%po_data(1) = array_adr
961          ar%po_data(2) = second_adr
962       ELSE
963          ar%po_data(1) = C_NULL_PTR
964          ar%po_data(2) = C_NULL_PTR
965       ENDIF
966    ENDDO
967
968 END SUBROUTINE pmc_s_setarray
969
970
971!--------------------------------------------------------------------------------------------------!
972! Description:
973! ------------
974!> @todo: Missing subroutine description.
975!--------------------------------------------------------------------------------------------------!
976 SUBROUTINE pmc_s_set_active_data_array( childid, iactive )
977
978    INTEGER(iwp) :: ip  !<
979    INTEGER(iwp) :: j   !<
980
981    INTEGER(iwp), INTENT(IN) ::  childid  !<
982    INTEGER(iwp), INTENT(IN) ::  iactive  !<
983
984    TYPE(pedef), POINTER ::  ape  !<
985
986    TYPE(arraydef), POINTER ::  ar   !<
987
988    DO  ip = 1, children(childid)%inter_npes
989       ape => children(childid)%pes(ip)
990       DO  j = 1, ape%nr_arrays
991          ar => ape%array_list(j)
992          IF ( MOD( ar%dimkey, 10 ) == 2 )  CYCLE  !Not for 2D array
993          IF ( iactive == 1  .OR.  iactive == 2 )  THEN
994             ar%data = ar%po_data(iactive)
995          ENDIF
996       ENDDO
997    ENDDO
998
999 END SUBROUTINE pmc_s_set_active_data_array
1000
1001
1002 !--------------------------------------------------------------------------------------------------!
1003 ! Description:
1004 ! ------------
1005 !> @todo: Missing function description.
1006 !--------------------------------------------------------------------------------------------------!
1007 INTEGER FUNCTION pmc_s_get_child_npes( child_id )
1008
1009   INTEGER(iwp),INTENT(IN) ::  child_id  !<
1010
1011   pmc_s_get_child_npes = children(child_id)%inter_npes
1012
1013   RETURN
1014
1015 END FUNCTION pmc_s_get_child_npes
1016
1017
1018!--------------------------------------------------------------------------------------------------!
1019! Description:
1020! ------------
1021!> @todo: Missing subroutine description.
1022!--------------------------------------------------------------------------------------------------!
1023 SUBROUTINE set_pe_index_list( mychild, index_list, nrp )
1024
1025    INTEGER(iwp) :: i        !<
1026    INTEGER(iwp) :: ierr     !<
1027    INTEGER(iwp) :: ind      !<
1028    INTEGER(iwp) :: indwin   !<
1029    INTEGER(iwp) :: indwin2  !<
1030    INTEGER(iwp) :: i2       !<
1031    INTEGER(iwp) :: j        !<
1032    INTEGER(iwp) :: rempe    !<
1033
1034    TYPE(childdef), INTENT(INOUT) ::  mychild  !<
1035
1036    INTEGER(iwp), DIMENSION(mychild%inter_npes) ::  remind  !<
1037
1038    INTEGER(iwp), INTENT(IN) ::  nrp  !<
1039
1040    INTEGER(iwp), INTENT(IN), DIMENSION(:,:) ::  index_list  !<
1041
1042    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
1043
1044    INTEGER(iwp), DIMENSION(:), POINTER ::  remindw  !<
1045    INTEGER(iwp), DIMENSION(:), POINTER ::  rldef    !<
1046
1047    TYPE(pedef), POINTER ::  ape  !<
1048
1049
1050!
1051!-- First, count entries for every remote child process
1052    DO  i = 1, mychild%inter_npes
1053       ape => mychild%pes(i)
1054       ape%nrele = 0
1055    ENDDO
1056
1057!
1058!-- Loop over number of coarse grid cells
1059    DO  j = 1, nrp
1060       rempe = index_list(5,j) + 1   ! Process number on remote process
1061       ape => mychild%pes(rempe)
1062       ape%nrele = ape%nrele + 1     ! Increment number of elements for this child process
1063    ENDDO
1064
1065    DO  i = 1, mychild%inter_npes
1066       ape => mychild%pes(i)
1067       ALLOCATE( ape%locind(ape%nrele) )
1068    ENDDO
1069
1070    remind = 0
1071
1072!
1073!-- Second, create lists
1074!-- Loop over number of coarse grid cells
1075    DO  j = 1, nrp
1076       rempe = index_list(5,j) + 1
1077       ape => mychild%pes(rempe)
1078       remind(rempe)     = remind(rempe) + 1
1079       ind               = remind(rempe)
1080       ape%locind(ind)%i = index_list(1,j)
1081       ape%locind(ind)%j = index_list(2,j)
1082    ENDDO
1083
1084!
1085!-- Prepare number of elements for children processes
1086    CALL pmc_alloc_mem( rldef, mychild%inter_npes * 2 )
1087
1088!
1089!-- Number of child processes * size of INTEGER (i just arbitrary INTEGER)
1090    winsize = mychild%inter_npes * STORAGE_SIZE( i ) / 8 * 2
1091
1092    CALL MPI_WIN_CREATE( rldef, winsize, iwp, MPI_INFO_NULL, mychild%intra_comm, indwin, ierr )
1093
1094!
1095!-- Open window to set data
1096    CALL MPI_WIN_FENCE( 0, indwin, ierr )
1097
1098    rldef(1) = 0            ! Index on remote process 0
1099    rldef(2) = remind(1)    ! Number of elements on remote process 0
1100
1101!
1102!-- Reserve buffer for index array
1103    DO  i = 2, mychild%inter_npes
1104       i2          = ( i - 1 ) * 2 + 1
1105       rldef(i2)   = rldef(i2-2) + rldef(i2-1) * 2  ! Index on remote process
1106       rldef(i2+1) = remind(i)                      ! Number of elements on remote process
1107    ENDDO
1108
1109!
1110!-- Close window to allow child to access data
1111    CALL MPI_WIN_FENCE( 0, indwin, ierr )
1112
1113!
1114!-- Child has retrieved data
1115    CALL MPI_WIN_FENCE( 0, indwin, ierr )
1116
1117    i2 = 2 * mychild%inter_npes - 1
1118    winsize = ( rldef(i2) + rldef(i2+1) ) * 2
1119
1120!
1121!-- Make sure, MPI_ALLOC_MEM works
1122    winsize = MAX( winsize, INT( 1, MPI_ADDRESS_KIND ) )
1123
1124    CALL pmc_alloc_mem( remindw, INT( winsize ) )
1125
1126    CALL MPI_BARRIER( m_model_comm, ierr )
1127    CALL MPI_WIN_CREATE( remindw, winsize * STORAGE_SIZE( i ) / 8, iwp, MPI_INFO_NULL,             &
1128                         mychild%intra_comm, indwin2, ierr )
1129
1130!
1131!-- Open window to set data
1132    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
1133
1134!
1135!-- Create the 2D index list
1136    DO  j = 1, nrp
1137       rempe = index_list(5,j) + 1    ! Process number on remote process
1138       ape => mychild%pes(rempe)
1139       i2    = rempe * 2 - 1
1140       ind   = rldef(i2) + 1
1141       remindw(ind)   = index_list(3,j)
1142       remindw(ind+1) = index_list(4,j)
1143       rldef(i2)      = rldef(i2)+2
1144    ENDDO
1145
1146!
1147!-- All data are set
1148    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
1149
1150!
1151!-- Don't know why, but this barrier is necessary before windows can be freed
1152!-- TODO: find out why this is required
1153    CALL MPI_BARRIER( mychild%intra_comm, ierr )
1154
1155    CALL MPI_WIN_FREE( indwin, ierr )
1156    CALL MPI_WIN_FREE( indwin2, ierr )
1157
1158!
1159!-- TODO: check if the following idea needs to be done
1160!-- Should work, Problem with MPI implementation
1161!-- https://www.lrz.de/services/software/parallel/mpi/onesided
1162!-- CALL MPI_Free_mem (remindw, ierr)
1163
1164 END SUBROUTINE set_pe_index_list
1165#endif
1166
1167
1168 END MODULE pmc_parent
Note: See TracBrowser for help on using the repository browser.