Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |