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

Last change on this file since 4180 was 4180, checked in by scharf, 2 years ago

removed comments in 'Former revisions' section that are older than 01.01.2019

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