Home

Context Navigation

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

Last change on this file since 4808 was 4649, checked in by raasch, 4 years ago
files re-formatted to follow the PALM coding standard
Property svn:keywords set to `Id`
File size: 37.9 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |