Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |