Home

Context Navigation

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

Last change on this file since 1935 was 1933, checked in by hellstea, 8 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 30.4 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |