Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |