Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |