Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |