Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |