Home

Context Navigation

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

Last change on this file since 4210 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 suehring $
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, nr8, MPI_BYTE, target_pe, target_disp, nr8, & !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_npesSTORAGE_SIZE(i)/82
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.

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |