Home

Context Navigation

source: palm/trunk/SOURCE/pmc_child_mod.f90 @ 2604

Last change on this file since 2604 was 2599, checked in by hellstea, 7 years ago
i/o grouping update for nested runs
Property svn:keywords set to `Id`
File size: 25.3 KB

Line
1	MODULE pmc_child
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-2017 Leibniz Universitaet Hannover
19	!------------------------------------------------------------------------------!
20	!
21	! Current revisions:
22	! ------------------
23	!
24	!
25	! Former revisions:
26	! -----------------
27	! $Id: pmc_child_mod.f90 2599 2017-11-01 13:18:45Z schwenkel $
28	! Some cleanup and commenting improvements only.
29	!
30	! 2101 2017-01-05 16:42:31Z suehring
31	!
32	! 2000 2016-08-20 18:09:15Z knoop
33	! Forced header and separation lines into 80 columns
34	!
35	! 1897 2016-05-03 08:10:23Z raasch
36	! Module renamed. Code clean up. The words server/client changed to parent/child.
37	!
38	! 1896 2016-05-03 08:06:41Z raasch
39	! re-formatted to match PALM style
40	!
41	! 1850 2016-04-08 13:29:27Z maronga
42	! Module renamed
43	!
44	!
45	! 1833 2016-04-07 14:23:03Z raasch
46	! gfortran requires pointer attributes for some array declarations,
47	! long line wrapped
48	!
49	! 1808 2016-04-05 19:44:00Z raasch
50	! MPI module used by default on all machines
51	!
52	! 1797 2016-03-21 16:50:28Z raasch
53	! introduction of different datatransfer modes
54	!
55	! 1791 2016-03-11 10:41:25Z raasch
56	! Debug write-statement commented out
57	!
58	! 1786 2016-03-08 05:49:27Z raasch
59	! change in child-parent data transfer: parent now gets data from child
60	! instead of that child puts it to the parent
61	!
62	! 1783 2016-03-06 18:36:17Z raasch
63	! Bugfix: wrong data-type in MPI_WIN_CREATE replaced
64	!
65	! 1779 2016-03-03 08:01:28Z raasch
66	! kind=dp replaced by wp, dim_order removed
67	! array management changed from linked list to sequential loop
68	!
69	! 1764 2016-02-28 12:45:19Z raasch
70	! cpp-statement added (nesting can only be used in parallel mode),
71	! all kinds given in PALM style
72	!
73	! 1762 2016-02-25 12:31:13Z hellstea
74	! Initial revision by K. Ketelsen
75	!
76	! Description:
77	! ------------
78	!
79	! Child part of Palm Model Coupler
80	!-------------------------------------------------------------------------------!
81
82	#if defined( __parallel )
83
84	USE, INTRINSIC :: iso_c_binding
85
86	#if defined( __mpifh )
87	INCLUDE "mpif.h"
88	#else
89	USE MPI
90	#endif
91
92	USE kinds
93	USE pmc_general, &
94	ONLY: arraydef, childdef, da_desclen, da_namedef, da_namelen, pedef, &
95	pmc_da_name_err, pmc_g_setname, pmc_max_array, pmc_status_ok
96
97	USE pmc_handle_communicator, &
98	ONLY: m_model_comm, m_model_npes, m_model_rank, m_to_parent_comm
99
100	USE pmc_mpi_wrapper, &
101	ONLY: pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, pmc_time
102
103	IMPLICIT NONE
104
105	PRIVATE
106	SAVE
107
108	TYPE(childdef) :: me !<
109
110	INTEGER :: myindex = 0 !< counter and unique number for data arrays
111	INTEGER :: next_array_in_list = 0 !<
112
113
114	INTERFACE pmc_childinit
115	MODULE PROCEDURE pmc_childinit
116	END INTERFACE pmc_childinit
117
118	INTERFACE pmc_c_clear_next_array_list
119	MODULE PROCEDURE pmc_c_clear_next_array_list
120	END INTERFACE pmc_c_clear_next_array_list
121
122	INTERFACE pmc_c_getbuffer
123	MODULE PROCEDURE pmc_c_getbuffer
124	END INTERFACE pmc_c_getbuffer
125
126	INTERFACE pmc_c_getnextarray
127	MODULE PROCEDURE pmc_c_getnextarray
128	END INTERFACE pmc_c_getnextarray
129
130	INTERFACE pmc_c_get_2d_index_list
131	MODULE PROCEDURE pmc_c_get_2d_index_list
132	END INTERFACE pmc_c_get_2d_index_list
133
134	INTERFACE pmc_c_putbuffer
135	MODULE PROCEDURE pmc_c_putbuffer
136	END INTERFACE pmc_c_putbuffer
137
138	INTERFACE pmc_c_setind_and_allocmem
139	MODULE PROCEDURE pmc_c_setind_and_allocmem
140	END INTERFACE pmc_c_setind_and_allocmem
141
142	INTERFACE pmc_c_set_dataarray
143	MODULE PROCEDURE pmc_c_set_dataarray_2d
144	MODULE PROCEDURE pmc_c_set_dataarray_3d
145	END INTERFACE pmc_c_set_dataarray
146
147	INTERFACE pmc_set_dataarray_name
148	MODULE PROCEDURE pmc_set_dataarray_name
149	MODULE PROCEDURE pmc_set_dataarray_name_lastentry
150	END INTERFACE pmc_set_dataarray_name
151
152
153	PUBLIC pmc_childinit, pmc_c_clear_next_array_list, pmc_c_getbuffer, &
154	pmc_c_getnextarray, pmc_c_putbuffer, pmc_c_setind_and_allocmem, &
155	pmc_c_set_dataarray, pmc_set_dataarray_name, pmc_c_get_2d_index_list
156
157	CONTAINS
158
159
160
161	SUBROUTINE pmc_childinit
162
163	IMPLICIT NONE
164
165	INTEGER :: i !<
166	INTEGER :: istat !<
167
168	!
169	!-- Get / define the MPI environment
170	me%model_comm = m_model_comm
171	me%inter_comm = m_to_parent_comm
172
173	CALL MPI_COMM_RANK( me%model_comm, me%model_rank, istat )
174	CALL MPI_COMM_SIZE( me%model_comm, me%model_npes, istat )
175	CALL MPI_COMM_REMOTE_SIZE( me%inter_comm, me%inter_npes, istat )
176	!
177	!-- Intra-communicator is used for MPI_GET
178	CALL MPI_INTERCOMM_MERGE( me%inter_comm, .TRUE., me%intra_comm, istat )
179	CALL MPI_COMM_RANK( me%intra_comm, me%intra_rank, istat )
180
181	ALLOCATE( me%pes(me%inter_npes) )
182	!
183	!-- Allocate an array of type arraydef for all parent processes to store
184	!-- information of then transfer array
185	DO i = 1, me%inter_npes
186	ALLOCATE( me%pes(i)%array_list(pmc_max_array) )
187	ENDDO
188
189	END SUBROUTINE pmc_childinit
190
191
192
193	SUBROUTINE pmc_set_dataarray_name( parentarraydesc, parentarrayname, &
194	childarraydesc, childarrayname, istat )
195
196	IMPLICIT NONE
197
198	CHARACTER(LEN=*), INTENT(IN) :: parentarrayname !<
199	CHARACTER(LEN=*), INTENT(IN) :: parentarraydesc !<
200	CHARACTER(LEN=*), INTENT(IN) :: childarrayname !<
201	CHARACTER(LEN=*), INTENT(IN) :: childarraydesc !<
202
203	INTEGER, INTENT(OUT) :: istat !<
204	!
205	!-- Local variables
206	TYPE(da_namedef) :: myname !<
207
208	INTEGER :: mype !<
209	INTEGER :: my_addiarray = 0 !<
210
211
212	istat = pmc_status_ok
213	!
214	!-- Check length of array names
215	IF ( LEN( TRIM( parentarrayname) ) > da_namelen .OR. &
216	LEN( TRIM( childarrayname) ) > da_namelen ) THEN
217	istat = pmc_da_name_err
218	ENDIF
219
220	IF ( m_model_rank == 0 ) THEN
221	myindex = myindex + 1
222	myname%couple_index = myIndex
223	myname%parentdesc = TRIM( parentarraydesc )
224	myname%nameonparent = TRIM( parentarrayname )
225	myname%childdesc = TRIM( childarraydesc )
226	myname%nameonchild = TRIM( childarrayname )
227	ENDIF
228
229	!
230	!-- Broadcast to all child processes
231	!-- TODO: describe what is broadcast here and why it is done
232	CALL pmc_bcast( myname%couple_index, 0, comm=m_model_comm )
233	CALL pmc_bcast( myname%parentdesc, 0, comm=m_model_comm )
234	CALL pmc_bcast( myname%nameonparent, 0, comm=m_model_comm )
235	CALL pmc_bcast( myname%childdesc, 0, comm=m_model_comm )
236	CALL pmc_bcast( myname%nameonchild, 0, comm=m_model_comm )
237	!
238	!-- Broadcast to all parent processes
239	!-- TODO: describe what is broadcast here and why it is done
240	IF ( m_model_rank == 0 ) THEN
241	mype = MPI_ROOT
242	ELSE
243	mype = MPI_PROC_NULL
244	ENDIF
245
246	CALL pmc_bcast( myname%couple_index, mype, comm=m_to_parent_comm )
247	CALL pmc_bcast( myname%parentdesc, mype, comm=m_to_parent_comm )
248	CALL pmc_bcast( myname%nameonparent, mype, comm=m_to_parent_comm )
249	CALL pmc_bcast( myname%childdesc, mype, comm=m_to_parent_comm )
250	CALL pmc_bcast( myname%nameonchild, mype, comm=m_to_parent_comm )
251
252	CALL pmc_g_setname( me, myname%couple_index, myname%nameonchild )
253
254	END SUBROUTINE pmc_set_dataarray_name
255
256
257
258	SUBROUTINE pmc_set_dataarray_name_lastentry( lastentry )
259
260	IMPLICIT NONE
261
262	LOGICAL, INTENT(IN), OPTIONAL :: lastentry !<
263	!
264	!-- Local variables
265	INTEGER :: mype !<
266	TYPE(dA_namedef) :: myname !<
267
268	myname%couple_index = -1
269
270	IF ( m_model_rank == 0 ) THEN
271	mype = MPI_ROOT
272	ELSE
273	mype = MPI_PROC_NULL
274	ENDIF
275
276	CALL pmc_bcast( myname%couple_index, mype, comm=m_to_parent_comm )
277
278	END SUBROUTINE pmc_set_dataarray_name_lastentry
279
280
281
282	SUBROUTINE pmc_c_get_2d_index_list
283
284	IMPLICIT NONE
285
286	INTEGER :: dummy !<
287	INTEGER :: i, ierr, i2, j, nr !<
288	INTEGER :: indwin !< MPI window object
289	INTEGER :: indwin2 !< MPI window object
290
291	INTEGER(KIND=MPI_ADDRESS_KIND) :: win_size !< Size of MPI window 1 (in bytes)
292	INTEGER(KIND=MPI_ADDRESS_KIND) :: disp !< Displacement unit (Integer = 4, floating poit = 8
293	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !< Size of MPI window 2 (in bytes)
294
295	INTEGER, DIMENSION(me%inter_npes*2) :: nrele !< Number of Elements of a
296	!< horizontal slice
297	INTEGER, DIMENSION(:), POINTER :: myind !<
298
299	TYPE(pedef), POINTER :: ape !> Pointer to pedef structure
300
301
302	win_size = C_SIZEOF( dummy )
303	CALL MPI_WIN_CREATE( dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm, &
304	indwin, ierr )
305	!
306	!-- Open window on parent side
307	!-- TODO: why is the next MPI routine called twice??
308	CALL MPI_WIN_FENCE( 0, indwin, ierr )
309	!
310	!-- Close window on parent side and open on child side
311	CALL MPI_WIN_FENCE( 0, indwin, ierr )
312
313	DO i = 1, me%inter_npes
314	disp = me%model_rank * 2
315	CALL MPI_GET( nrele((i-1)*2+1), 2, MPI_INTEGER, i-1, disp, 2, &
316	MPI_INTEGER, indwin, ierr )
317	ENDDO
318	!
319	!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
320	!-- called
321	CALL MPI_WIN_FENCE( 0, indwin, ierr )
322	!
323	!-- Allocate memory for index array
324	winsize = 0
325	DO i = 1, me%inter_npes
326	ape => me%pes(i)
327	i2 = ( i-1 ) * 2 + 1
328	nr = nrele(i2+1)
329	IF ( nr > 0 ) THEN
330	ALLOCATE( ape%locind(nr) )
331	ELSE
332	NULLIFY( ape%locind )
333	ENDIF
334	winsize = MAX( nr, winsize )
335	ENDDO
336
337	ALLOCATE( myind(2*winsize) )
338	winsize = 1
339	!
340	!-- Local buffer used in MPI_GET can but must not be inside the MPI Window.
341	!-- Here, we use a dummy for the MPI window because the parent processes do
342	!-- not access the RMA window via MPI_GET or MPI_PUT
343	CALL MPI_WIN_CREATE( dummy, winsize, iwp, MPI_INFO_NULL, me%intra_comm, &
344	indwin2, ierr )
345	!
346	!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
347	!-- called
348	!-- TODO: as before: why is this called twice??
349	CALL MPI_WIN_FENCE( 0, indwin2, ierr )
350	CALL MPI_WIN_FENCE( 0, indwin2, ierr )
351
352	DO i = 1, me%inter_npes
353	ape => me%pes(i)
354	nr = nrele(i*2)
355	IF ( nr > 0 ) THEN
356	disp = nrele(2*(i-1)+1)
357	CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , i-1, 0, indwin2, ierr )
358	CALL MPI_GET( myind, 2nr, MPI_INTEGER, i-1, disp, 2nr, &
359	MPI_INTEGER, indwin2, ierr )
360	CALL MPI_WIN_UNLOCK( i-1, indwin2, ierr )
361	DO j = 1, nr
362	ape%locind(j)%i = myind(2*j-1)
363	ape%locind(j)%j = myind(2*j)
364	ENDDO
365	ape%nrele = nr
366	ELSE
367	ape%nrele = -1
368	ENDIF
369	ENDDO
370	!
371	!-- Don't know why, but this barrier is necessary before we can free the windows
372	CALL MPI_BARRIER( me%intra_comm, ierr )
373
374	CALL MPI_WIN_FREE( indWin, ierr )
375	CALL MPI_WIN_FREE( indwin2, ierr )
376	DEALLOCATE( myind )
377
378	END SUBROUTINE pmc_c_get_2d_index_list
379
380
381
382	SUBROUTINE pmc_c_clear_next_array_list
383
384	IMPLICIT NONE
385
386	next_array_in_list = 0
387
388	END SUBROUTINE pmc_c_clear_next_array_list
389
390
391
392	LOGICAL FUNCTION pmc_c_getnextarray( myname )
393
394	!
395	!-- List handling is still required to get minimal interaction with
396	!-- pmc_interface
397	CHARACTER(LEN=*), INTENT(OUT) :: myname !<
398	!
399	!-- Local variables
400	TYPE(pedef), POINTER :: ape
401	TYPE(arraydef), POINTER :: ar
402
403
404	next_array_in_list = next_array_in_list + 1
405	!
406	!-- Array names are the same on all child PEs, so take first process to
407	!-- get the name
408	ape => me%pes(1)
409	!
410	!-- Check if all arrays have been processed
411	IF ( next_array_in_list > ape%nr_arrays ) THEN
412	pmc_c_getnextarray = .FALSE.
413	RETURN
414	ENDIF
415
416	ar => ape%array_list( next_array_in_list )
417
418	myname = ar%name
419	!
420	!-- Return true if legal array
421	!-- TODO: the case of a non-legal array does not seem to appear, so why is this
422	!-- setting required at all?
423	pmc_c_getnextarray = .TRUE.
424
425	END function pmc_c_getnextarray
426
427
428
429	SUBROUTINE pmc_c_set_dataarray_2d( array )
430
431	IMPLICIT NONE
432
433	REAL(wp), INTENT(IN) , DIMENSION(:,:), POINTER :: array !<
434
435	INTEGER :: i !<
436	INTEGER :: nrdims !<
437	INTEGER, DIMENSION(4) :: dims !<
438
439	TYPE(C_PTR) :: array_adr
440	TYPE(arraydef), POINTER :: ar
441	TYPE(pedef), POINTER :: ape
442
443
444	dims = 1
445	nrdims = 2
446	dims(1) = SIZE( array, 1 )
447	dims(2) = SIZE( array, 2 )
448
449	array_adr = C_LOC( array )
450
451	DO i = 1, me%inter_npes
452	ape => me%pes(i)
453	ar => ape%array_list(next_array_in_list)
454	ar%nrdims = nrdims
455	ar%a_dim = dims
456	ar%data = array_adr
457	ENDDO
458
459	END SUBROUTINE pmc_c_set_dataarray_2d
460
461
462
463	SUBROUTINE pmc_c_set_dataarray_3d (array)
464
465	IMPLICIT NONE
466
467	REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER :: array !<
468
469	INTEGER :: i
470	INTEGER :: nrdims
471	INTEGER, DIMENSION (4) :: dims
472	TYPE(C_PTR) :: array_adr
473	TYPE(pedef), POINTER :: ape
474	TYPE(arraydef), POINTER :: ar
475
476
477	dims = 1
478	nrdims = 3
479	dims(1) = SIZE( array, 1 )
480	dims(2) = SIZE( array, 2 )
481	dims(3) = SIZE( array, 3 )
482
483	array_adr = C_LOC( array )
484
485	DO i = 1, me%inter_npes
486	ape => me%pes(i)
487	ar => ape%array_list(next_array_in_list)
488	ar%nrdims = nrdims
489	ar%a_dim = dims
490	ar%data = array_adr
491	ENDDO
492
493	END SUBROUTINE pmc_c_set_dataarray_3d
494
495
496
497	SUBROUTINE pmc_c_setind_and_allocmem
498
499	IMPLICIT NONE
500
501	!
502	!-- Naming convention for appendices: _pc -> parent to child transfer
503	!-- _cp -> child to parent transfer
504	!-- recv -> parent to child transfer
505	!-- send -> child to parent transfer
506	CHARACTER(LEN=da_namelen) :: myname !<
507
508	INTEGER :: arlen !<
509	INTEGER :: myindex !<
510	INTEGER :: i !<
511	INTEGER :: ierr !<
512	INTEGER :: istat !<
513	INTEGER :: j !<
514	INTEGER :: rcount !<
515	INTEGER :: tag !<
516
517	INTEGER, PARAMETER :: noindex = -1 !<
518
519	INTEGER(idp) :: bufsize !< size of MPI data window
520	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
521
522	INTEGER,DIMENSION(1024) :: req !<
523
524	REAL(wp), DIMENSION(:), POINTER, SAVE :: base_array_pc !< base array
525	REAL(wp), DIMENSION(:), POINTER, SAVE :: base_array_cp !< base array
526
527	TYPE(pedef), POINTER :: ape !<
528	TYPE(arraydef), POINTER :: ar !<
529	Type(C_PTR) :: base_ptr !<
530
531
532	myindex = 0
533	bufsize = 8
534	!
535	!-- Parent to child direction.
536	!-- First stride: compute size and set index
537	DO i = 1, me%inter_npes
538	ape => me%pes(i)
539	tag = 200
540	DO j = 1, ape%nr_arrays
541	ar => ape%array_list(j)
542	!
543	!-- Receive index from child
544	tag = tag + 1
545	CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
546	MPI_STATUS_IGNORE, ierr )
547	ar%recvindex = myindex
548	!
549	!-- Determine max, because child buffer is allocated only once
550	!-- TODO: give a more meaningful comment
551	IF( ar%nrdims == 3 ) THEN
552	bufsize = MAX( bufsize, ar%a_dim(1)ar%a_dim(2)ar%a_dim(3) )
553	ELSE
554	bufsize = MAX( bufsize, ar%a_dim(1)*ar%a_dim(2) )
555	ENDIF
556	ENDDO
557	ENDDO
558	!
559	!-- Create RMA (one sided communication) data buffer.
560	!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of
561	!-- the MPI RMA window
562	CALL pmc_alloc_mem( base_array_pc, bufsize, base_ptr )
563	me%totalbuffersize = bufsize*wp ! total buffer size in byte
564	!
565	!-- Second stride: set buffer pointer
566	DO i = 1, me%inter_npes
567	ape => me%pes(i)
568	DO j = 1, ape%nr_arrays
569	ar => ape%array_list(j)
570	ar%recvbuf = base_ptr
571	ENDDO
572	ENDDO
573	!
574	!-- Child to parent direction
575	myindex = 1
576	rcount = 0
577	bufsize = 8
578
579	DO i = 1, me%inter_npes
580	ape => me%pes(i)
581	tag = 300
582	DO j = 1, ape%nr_arrays
583	ar => ape%array_list(j)
584	IF( ar%nrdims == 2 ) THEN
585	arlen = ape%nrele
586	ELSEIF( ar%nrdims == 3 ) THEN
587	arlen = ape%nrele*ar%a_dim(1)
588	ENDIF
589	tag = tag + 1
590	rcount = rcount + 1
591	IF ( ape%nrele > 0 ) THEN
592	CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
593	req(rcount), ierr )
594	ar%sendindex = myindex
595	ELSE
596	CALL MPI_ISEND( noindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
597	req(rcount), ierr )
598	ar%sendindex = noindex
599	ENDIF
600	!
601	!-- Maximum of 1024 outstanding requests
602	!-- TODO: explain where this maximum comes from (arbitrary?).
603	!-- Outstanding = pending?
604	IF ( rcount == 1024 ) THEN
605	CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
606	rcount = 0
607	ENDIF
608
609	IF ( ape%nrele > 0 ) THEN
610	ar%sendsize = arlen
611	myindex = myindex + arlen
612	bufsize = bufsize + arlen
613	ENDIF
614
615	ENDDO
616
617	IF ( rcount > 0 ) THEN
618	CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
619	ENDIF
620
621	ENDDO
622	!
623	!-- Create RMA (one sided communication) window for data buffer child to parent
624	!-- transfer.
625	!-- The buffer of MPI_GET (counter part of transfer) can be PE-local, i.e. it
626	!-- can but must not be part of the MPI RMA window. Only one RMA window is
627	!-- required to prepare the data
628	!-- for parent -> child transfer on the parent side
629	!-- and
630	!-- for child -> parent transfer on the child side
631	CALL pmc_alloc_mem( base_array_cp, bufsize )
632	me%totalbuffersize = bufsize * wp ! total buffer size in byte
633
634	winSize = me%totalbuffersize
635
636	CALL MPI_WIN_CREATE( base_array_cp, winsize, wp, MPI_INFO_NULL, &
637	me%intra_comm, me%win_parent_child, ierr )
638	CALL MPI_WIN_FENCE( 0, me%win_parent_child, ierr )
639	CALL MPI_BARRIER( me%intra_comm, ierr )
640	!
641	!-- Second stride: set buffer pointer
642	DO i = 1, me%inter_npes
643	ape => me%pes(i)
644	DO j = 1, ape%nr_arrays
645	ar => ape%array_list(j)
646	IF ( ape%nrele > 0 ) THEN
647	ar%sendbuf = C_LOC( base_array_cp(ar%sendindex) )
648	!
649	!-- TODO: if this is an error to be really expected, replace the
650	!-- following message by a meaningful standard PALM message using
651	!-- the message-routine
652	IF ( ar%sendindex+ar%sendsize > bufsize ) THEN
653	WRITE( 0,'(a,i4,4i7,1x,a)') 'Child buffer too small ', i, &
654	ar%sendindex, ar%sendsize, ar%sendindex+ar%sendsize, &
655	bufsize, TRIM( ar%name )
656	CALL MPI_ABORT( MPI_COMM_WORLD, istat, ierr )
657	ENDIF
658	ENDIF
659	ENDDO
660	ENDDO
661
662	END SUBROUTINE pmc_c_setind_and_allocmem
663
664
665
666	SUBROUTINE pmc_c_getbuffer( waittime )
667
668	IMPLICIT NONE
669
670	REAL(wp), INTENT(OUT), OPTIONAL :: waittime !<
671
672	CHARACTER(LEN=da_namelen) :: myname !<
673
674	INTEGER :: ierr !<
675	INTEGER :: ij !<
676	INTEGER :: ip !<
677	INTEGER :: j !<
678	INTEGER :: myindex !<
679	INTEGER :: nr !< number of elements to get
680	!< from parent
681	INTEGER(KIND=MPI_ADDRESS_KIND) :: target_disp
682	INTEGER,DIMENSION(1) :: buf_shape
683
684	REAL(wp) :: t1
685	REAL(wp) :: t2
686
687	REAL(wp), POINTER, DIMENSION(:) :: buf
688	REAL(wp), POINTER, DIMENSION(:,:) :: data_2d
689	REAL(wp), POINTER, DIMENSION(:,:,:) :: data_3d
690	TYPE(pedef), POINTER :: ape
691	TYPE(arraydef), POINTER :: ar
692
693	!
694	!-- Synchronization of the model is done in pmci_synchronize.
695	!-- Therefore the RMA window can be filled without
696	!-- sychronization at this point and a barrier is not necessary.
697	!-- Please note that waittime has to be set in pmc_s_fillbuffer AND
698	!-- pmc_c_getbuffer
699	IF ( PRESENT( waittime ) ) THEN
700	t1 = pmc_time()
701	CALL MPI_BARRIER( me%intra_comm, ierr )
702	t2 = pmc_time()
703	waittime = t2 - t1
704	ENDIF
705	!
706	!-- Wait for buffer is filled.
707	!-- TODO: explain in more detail what is happening here. The barrier seems to
708	!-- contradict what is said a few lines before (i.e. that no barrier is necessary)
709	!-- TODO: In case of PRESENT( waittime ) the barrrier would be calles twice. Why?
710	!-- Shouldn't it be done the same way as in pmc_putbuffer?
711	CALL MPI_BARRIER( me%intra_comm, ierr )
712
713	DO ip = 1, me%inter_npes
714	ape => me%pes(ip)
715	DO j = 1, ape%nr_arrays
716	ar => ape%array_list(j)
717	IF ( ar%nrdims == 2 ) THEN
718	nr = ape%nrele
719	ELSEIF ( ar%nrdims == 3 ) THEN
720	nr = ape%nrele * ar%a_dim(1)
721	ENDIF
722	buf_shape(1) = nr
723	CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
724	!
725	!-- MPI passive target RMA
726	!-- TODO: explain the above comment
727	IF ( nr > 0 ) THEN
728	target_disp = ar%recvindex - 1
729	CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0, &
730	me%win_parent_child, ierr )
731	CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, &
732	me%win_parent_child, ierr )
733	CALL MPI_WIN_UNLOCK( ip-1, me%win_parent_child, ierr )
734	ENDIF
735	myindex = 1
736	IF ( ar%nrdims == 2 ) THEN
737	CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
738	DO ij = 1, ape%nrele
739	data_2d(ape%locind(ij)%j,ape%locind(ij)%i) = buf(myindex)
740	myindex = myindex + 1
741	ENDDO
742	ELSEIF ( ar%nrdims == 3 ) THEN
743	CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
744	DO ij = 1, ape%nrele
745	data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) = &
746	buf(myindex:myindex+ar%a_dim(1)-1)
747	myindex = myindex+ar%a_dim(1)
748	ENDDO
749	ENDIF
750	ENDDO
751	ENDDO
752
753	END SUBROUTINE pmc_c_getbuffer
754
755
756
757	SUBROUTINE pmc_c_putbuffer( waittime )
758
759	IMPLICIT NONE
760
761	REAL(wp), INTENT(OUT), OPTIONAL :: waittime !<
762
763	CHARACTER(LEN=da_namelen) :: myname !<
764
765	INTEGER :: ierr !<
766	INTEGER :: ij !<
767	INTEGER :: ip !<
768	INTEGER :: j !<
769	INTEGER :: myindex !<
770	INTEGER :: nr !< number of elements to get
771	!< from parent
772	INTEGER(KIND=MPI_ADDRESS_KIND) :: target_disp !<
773
774	INTEGER, DIMENSION(1) :: buf_shape !<
775
776	REAL(wp) :: t1 !<
777	REAL(wp) :: t2 !<
778
779	REAL(wp), POINTER, DIMENSION(:) :: buf !<
780	REAL(wp), POINTER, DIMENSION(:,:) :: data_2d !<
781	REAL(wp), POINTER, DIMENSION(:,:,:) :: data_3d !<
782
783	TYPE(pedef), POINTER :: ape !<
784	TYPE(arraydef), POINTER :: ar !<
785
786	!
787	!-- Wait for empty buffer
788	!-- TODO: explain what is done here
789	t1 = pmc_time()
790	CALL MPI_BARRIER( me%intra_comm, ierr )
791	t2 = pmc_time()
792	IF ( PRESENT( waittime ) ) waittime = t2 - t1
793
794	DO ip = 1, me%inter_npes
795	ape => me%pes(ip)
796	DO j = 1, ape%nr_arrays
797	ar => aPE%array_list(j)
798	myindex = 1
799	IF ( ar%nrdims == 2 ) THEN
800	buf_shape(1) = ape%nrele
801	CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
802	CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
803	DO ij = 1, ape%nrele
804	buf(myindex) = data_2d(ape%locind(ij)%j,ape%locind(ij)%i)
805	myindex = myindex + 1
806	ENDDO
807	ELSEIF ( ar%nrdims == 3 ) THEN
808	buf_shape(1) = ape%nrele*ar%a_dim(1)
809	CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
810	CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
811	DO ij = 1, ape%nrele
812	buf(myindex:myindex+ar%a_dim(1)-1) = &
813	data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i)
814	myindex = myindex + ar%a_dim(1)
815	ENDDO
816	ENDIF
817	ENDDO
818	ENDDO
819	!
820	!-- TODO: Fence might do it, test later
821	!-- Call MPI_WIN_FENCE( 0, me%win_parent_child, ierr) !
822	!
823	!-- Buffer is filled
824	!-- TODO: explain in more detail what is happening here
825	CALL MPI_Barrier(me%intra_comm, ierr)
826
827	END SUBROUTINE pmc_c_putbuffer
828
829	#endif
830	END MODULE pmc_child

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |