Home

Context Navigation

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

Last change on this file since 3943 was 3943, checked in by maronga, 5 years ago
bugfixes in urban surface model; output of greenz roof transpiration added/corrected; minor formatting improvements
Property svn:keywords set to `Id`
File size: 29.5 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |