Home

Context Navigation

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

Last change on this file since 2764 was 2718, checked in by maronga, 7 years ago
deleting of deprecated files; headers updated where needed
Property svn:keywords set to `Id`
File size: 25.4 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |