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