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

Last change on this file since 4212 was 4212, checked in by suehring, 2 years ago

Allocate array for index lists in nesting also for zero-size arrays, in order to avoid error when array bound checks are enabled

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