Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |