Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |