Home

Context Navigation

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

Last change on this file since 4222 was 4213, checked in by suehring, 5 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 35.4 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |