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

Last change on this file since 4775 was 4649, checked in by raasch, 4 years ago

files re-formatted to follow the PALM coding standard

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