Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |