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

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