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

Last change on this file since 4635 was 4629, checked in by raasch, 4 years ago

support for MPI Fortran77 interface (mpif.h) removed

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