Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |