Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |