Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |