Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |