Home

Context Navigation

source: palm/trunk/SOURCE/shared_memory_io_mod.f90 @ 4893

Last change on this file since 4893 was 4893, checked in by raasch, 3 years ago
revised output of surface data via MPI-IO for better performance
Property svn:keywords set to `Id`
File size: 57.3 KB

Line
1	!> @file shared_memory_io_mod.f90
2	!--------------------------------------------------------------------------------------------------!
3	! This file is part of the PALM model system.
4	!
5	! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
6	! Public License as published by the Free Software Foundation, either version 3 of the License, or
7	! (at your option) any later version.
8	!
9	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
10	! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
11	! Public License for more details.
12	!
13	! You should have received a copy of the GNU General Public License along with PALM. If not, see
14	! <http://www.gnu.org/licenses/>.
15	!
16	! Copyright 1997-2021 Leibniz Universitaet Hannover
17	!--------------------------------------------------------------------------------------------------!
18	!
19	!
20	! Current revisions:
21	! -----------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: shared_memory_io_mod.f90 4893 2021-03-02 16:39:14Z raasch $
27	! revised output of surface data via MPI-IO for better performance
28	!
29	! 4828 2021-01-05 11:21:41Z Giersch
30	! additions for output of particle time series
31	!
32	! 4629 2020-07-29 09:37:56Z raasch
33	! support for MPI Fortran77 interface (mpif.h) removed
34	!
35	! 4628 2020-07-29 07:23:03Z raasch
36	! extensions required for MPI-I/O of particle data to restart files
37	!
38	! 4620 2020-07-22 14:11:16Z raasch
39	! bugfix: variable definition changed
40	!
41	! 4618 2020-07-22 11:21:08Z raasch
42	! unused variable removed
43	!
44	! Additions for cyclic fill mode
45	!
46	! File re-formatted to follow the PALM coding standard
47	!
48	!
49	! Initial version (Klaus Ketelsen)
50	!
51	! Description:
52	! ------------
53	!> Handle MPI-IO or NetCDF-IO shared memory arrays.
54	!> This module performs the organization of new communicators, adapted PE-grids and allocation of
55	!> shared memory arrays. The IO itself is not done here.
56	!--------------------------------------------------------------------------------------------------!
57	MODULE shared_memory_io_mod
58
59	#if defined( __parallel )
60	USE MPI
61	#endif
62
63	USE, INTRINSIC :: ISO_C_BINDING
64
65	USE control_parameters, &
66	ONLY: maximum_grid_level, &
67	message_string, &
68	mg_switch_to_pe0_level
69
70
71	USE indices, &
72	ONLY: nbgp, &
73	nnx, &
74	nny, &
75	nnz, &
76	nx, &
77	nxl, &
78	nxlg, &
79	nxr, &
80	nxrg, &
81	ny, &
82	nyn, &
83	nyng, &
84	nys, &
85	nysg, &
86	nzb, &
87	nzt
88
89	USE kinds, &
90	ONLY: dp, &
91	idp, &
92	isp, &
93	iwp, &
94	sp, &
95	wp
96
97	USE pegrid, &
98	ONLY: comm1dx, &
99	comm1dy, &
100	comm2d, &
101	comm_palm, &
102	ierr, &
103	myid, &
104	myidx, &
105	myidy, &
106	npex, &
107	npey, &
108	numprocs, &
109	pdims, &
110	pleft, &
111	pnorth, &
112	pright, &
113	psouth, &
114	sendrecvcount_xy
115
116	#if defined( __parallel )
117	USE pegrid, &
118	ONLY: pcoord, &
119	reorder
120	#endif
121
122	USE transpose_indices, &
123	ONLY: nxl_y, nxl_z, nxr_y, nxr_z, nys_x, nys_z, nyn_x, nyn_z, nzb_x, nzb_y, nzt_x, nzt_y
124
125	IMPLICIT NONE
126
127	PRIVATE
128
129	SAVE
130
131	!
132	!-- Type to store information about the domain decomposition grid
133	TYPE, PUBLIC :: domain_decomposition_grid_features !<
134
135	INTEGER(iwp) :: comm2d !<
136	INTEGER(iwp) :: myid !<
137	INTEGER(iwp) :: nnx !<
138	INTEGER(iwp) :: nny !<
139	INTEGER(iwp) :: nx !<
140	INTEGER(iwp) :: nxl !<
141	INTEGER(iwp) :: nxr !<
142	INTEGER(iwp) :: ny !<
143	INTEGER(iwp) :: nyn !<
144	INTEGER(iwp) :: nys !<
145	INTEGER(iwp) :: numprocs !<
146
147	CONTAINS
148
149	PROCEDURE, PASS(this), PUBLIC :: activate_grid_from_this_class
150	PROCEDURE, PASS(this), PUBLIC :: save_grid_into_this_class
151
152	END TYPE domain_decomposition_grid_features
153
154	TYPE, PUBLIC :: sm_remote_array
155
156	TYPE(C_PTR) :: rem_ptr !<
157	INTEGER(iwp) :: d1e !<
158	INTEGER(iwp) :: d1s !<
159	INTEGER(iwp) :: d2e !<
160	INTEGER(iwp) :: d2s !<
161	INTEGER(iwp) :: d3e !<
162	INTEGER(iwp) :: d3s !<
163	INTEGER(iwp) :: d4e !<
164	INTEGER(iwp) :: d4s !<
165
166	END TYPE sm_remote_array
167
168	!
169	!-- Class definition for shared memory instances.
170	!-- For every use of shared memory IO, one instance of this class is created.
171	TYPE, PUBLIC :: sm_class !<
172
173	INTEGER(iwp) :: nr_io_pe_per_node !< typical configuration, 2 sockets per node
174	LOGICAL :: no_shared_Memory_in_this_run !<
175
176	INTEGER(iwp) :: comm_model !< communicator of this model run
177	!
178	!-- Variables for the shared memory communicator
179	INTEGER(iwp), PUBLIC :: comm_shared !< communicator for processes with shared array
180	INTEGER(iwp), PUBLIC :: sh_npes !<
181	INTEGER(iwp), PUBLIC :: sh_rank !<
182
183	!
184	!-- Variables for the I/O virtual grid
185	INTEGER(iwp), PUBLIC :: comm_io !< communicator for all IO processes
186	INTEGER(iwp), PUBLIC :: io_npes !<
187	INTEGER(iwp), PUBLIC :: io_rank !<
188	!
189	!-- Variables for the node local communicator
190	INTEGER(iwp) :: comm_node !< communicator for all processes of current node
191	INTEGER(iwp) :: io_pe_global_rank !<
192	INTEGER(iwp) :: n_npes !<
193	INTEGER(iwp) :: n_rank !<
194
195	LOGICAL, PUBLIC :: is_root_pe !<
196	LOGICAL, PUBLIC :: iam_io_pe = .TRUE. !< this PE is an IO-PE
197
198	TYPE(domain_decomposition_grid_features), PUBLIC :: io_grid !< io grid features, depending on reading from prerun or main run
199
200	CONTAINS
201
202	PRIVATE
203
204	PROCEDURE, PASS(this), PUBLIC :: is_sm_active
205	PROCEDURE, PASS(this), PUBLIC :: sm_adjust_outer_boundary
206	PROCEDURE, PASS(this), PUBLIC :: sm_free_shared
207	PROCEDURE, PASS(this), PUBLIC :: sm_init_comm
208	PROCEDURE, PASS(this), PUBLIC :: sm_init_data_output_particles
209	PROCEDURE, PASS(this), PUBLIC :: sm_node_barrier
210	#if defined( __parallel )
211	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_1d_32
212	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_1d_64
213	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_1di
214	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_2d_32
215	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_2d_64
216	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_2di
217	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_3d_32
218	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_3d_64
219	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_4d_32
220	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_4d_64
221	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_3di_32
222	PROCEDURE, PASS(this), PUBLIC :: sm_allocate_shared_3di_64
223	PROCEDURE, PASS(this), PUBLIC :: sm_all_allocate_shared_3d_64
224
225	GENERIC, PUBLIC :: sm_allocate_shared => &
226	sm_allocate_shared_1d_64, sm_allocate_shared_1d_32, &
227	sm_allocate_shared_2d_64, sm_allocate_shared_2d_32, &
228	sm_allocate_shared_2di, sm_allocate_shared_3d_64, &
229	sm_allocate_shared_4d_64, sm_allocate_shared_4d_32, &
230	sm_allocate_shared_3d_32, sm_allocate_shared_1di, &
231	sm_allocate_shared_3di_32, sm_allocate_shared_3di_64
232
233	GENERIC, PUBLIC :: sm_all_allocate_shared => sm_all_allocate_shared_3d_64
234	#endif
235	END TYPE sm_class
236
237
238	CONTAINS
239
240
241	!--------------------------------------------------------------------------------------------------!
242	! Description:
243	! ------------
244	!> Create the communicator for shared memory groups and IO-PEs.
245	!> Setup the grid for shared memory IO.
246	!--------------------------------------------------------------------------------------------------!
247	SUBROUTINE sm_init_comm( this, sm_active, comm_input )
248
249	IMPLICIT NONE
250
251	CLASS(sm_class), INTENT(INOUT) :: this !< pointer to access internal variables of this call
252	INTEGER(iwp), INTENT(IN), OPTIONAL :: comm_input !< main model communicator (comm2d) can optional be set
253
254	#if defined( __parallel )
255	INTEGER :: color !<
256	INTEGER :: max_npes_per_node !< maximum number of PEs/node
257	#endif
258
259	LOGICAL, INTENT(IN) :: sm_active !< flag to activate shared-memory IO
260
261	this%nr_io_pe_per_node = 2
262
263	#if defined( __parallel )
264	IF ( PRESENT( comm_input ) ) THEN
265	this%comm_model = comm_input
266	ELSE
267	this%comm_model = comm2d
268	ENDIF
269
270	this%no_shared_memory_in_this_run = .NOT. sm_active
271	this%comm_io = this%comm_model ! preset in case of non shared-memory-IO
272
273	IF ( this%no_shared_memory_in_this_run ) THEN
274	this%iam_io_pe = .TRUE.
275	this%sh_rank = 0
276	this%sh_npes = 1
277	RETURN
278	ENDIF
279
280	!
281	!-- Determine, how many PEs are running on a node.
282	this%iam_io_pe = .FALSE.
283	CALL MPI_COMM_SPLIT_TYPE( this%comm_model, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, &
284	this%comm_node, ierr )
285	CALL MPI_COMM_SIZE( this%comm_node, this%n_npes, ierr )
286	CALL MPI_COMM_RANK( this%comm_node, this%n_rank, ierr )
287
288	CALL MPI_ALLREDUCE( this%n_npes, max_npes_per_node, 1, MPI_INTEGER, MPI_MAX, this%comm_model, &
289	ierr )
290	!
291	!-- Decide, if the configuration can run with shared-memory IO
292	IF ( max_npes_per_node > 64 ) THEN
293	!
294	!-- Special configuration on the HLRN-IV system with 4 shared memory blocks/node
295	this%nr_io_pe_per_node = 4
296
297	ELSEIF ( max_npes_per_node <= 3 ) THEN
298	!
299	!-- No shared memory IO with less than 3 MPI tasks/node
300	this%no_shared_memory_in_this_run = .TRUE.
301	this%iam_io_pe = .TRUE.
302	RETURN
303	ENDIF
304
305	!
306	!-- No shared memory IO with small setups.
307	IF ( nx < 16 .OR. ny < 16 ) THEN
308	this%no_shared_memory_in_this_run = .TRUE.
309	this%iam_io_pe = .TRUE.
310	RETURN
311	ENDIF
312
313	!
314	!-- Divide a node into shared memory groups, depending on the virtual x-y grid
315	CALL compute_color( color )
316	!
317	!-- If no shared memory IO possible, nothing is left to be done here.
318	IF ( this%no_shared_memory_in_this_run ) RETURN
319
320	!
321	!-- Setup the shared memory area
322	CALL MPI_COMM_SPLIT( this%comm_node, color, 0, this%comm_shared, ierr )
323	CALL MPI_COMM_SIZE( this%comm_shared, this%sh_npes, ierr )
324	CALL MPI_COMM_RANK( this%comm_shared, this%sh_rank, ierr )
325
326	!
327	!-- Setup the communicator across the nodes depending on the shared memory rank.
328	!-- All PEs with shared memory rank 0 will be I/O PEs.
329	color = this%sh_rank
330	CALL MPI_COMM_SPLIT( this%comm_model, color, 0, this%comm_io, ierr )
331
332	IF ( this%comm_io /= MPI_COMM_NULL ) THEN
333	CALL MPI_COMM_SIZE( this%comm_io, this%io_npes, ierr )
334	CALL MPI_COMM_RANK( this%comm_io, this%io_rank, ierr )
335	ELSE
336	this%io_npes = -1
337	this%io_rank = -1
338	ENDIF
339
340	IF ( this%sh_rank == 0 ) THEN
341	this%iam_io_pe = .TRUE.
342	this%io_pe_global_rank = myid
343	ENDIF
344	CALL MPI_BCAST( this%io_pe_global_rank, 1, MPI_INTEGER, 0, this%comm_shared, ierr )
345	#else
346	this%iam_io_pe = .TRUE.
347	this%comm_model = comm2d
348	this%sh_rank = 0
349	this%sh_npes = 1
350	this%no_shared_memory_in_this_run = .TRUE.
351	#endif
352
353	#if defined( __parallel )
354	CONTAINS
355
356	SUBROUTINE compute_color( color )
357
358	IMPLICIT NONE
359
360	INTEGER(iwp), INTENT(OUT) :: color !<
361
362	INTEGER(iwp) :: group_start !<
363	INTEGER(iwp) :: my_color !<
364	INTEGER(iwp) :: n !<
365	INTEGER(iwp) :: pe !<
366	INTEGER(iwp) :: sh_group_size !<
367
368	INTEGER(iwp), DIMENSION(4,0:this%n_npes-1) :: local_dim_s !<
369	INTEGER(iwp), DIMENSION(4,0:this%n_npes-1) :: local_dim_r !<
370
371	TYPE(domain_decomposition_grid_features), DIMENSION(32) :: node_grid !<
372
373	!
374	!-- No shared memory I/O on one node jobs
375	IF ( numprocs < this%n_npes ) THEN
376	this%no_shared_memory_in_this_run = .TRUE.
377	RETURN
378	ENDIF
379
380	local_dim_s = 0
381	local_dim_s(1,this%n_rank) = nxl
382	local_dim_s(2,this%n_rank) = nxr
383	local_dim_s(3,this%n_rank) = nys
384	local_dim_s(4,this%n_rank) = nyn
385
386	node_grid%nyn = -1
387	!
388	!-- Distribute the x-y layout of all cores of a node to all node processes
389	CALL MPI_ALLREDUCE( local_dim_s, local_dim_r, SIZE( local_dim_s ), MPI_INTEGER, MPI_SUM, &
390	this%comm_node, ierr )
391	sh_group_size = ( max_npes_per_node + this%nr_io_pe_per_node - 1 ) / this%nr_io_pe_per_node
392
393	pe = 0
394	my_color = 1 ! color is used to split the shared memory communicator into a communicator for
395	! io groups
396	group_start = pe
397	node_grid(my_color)%nxl = local_dim_r(1,group_start)
398	node_grid(my_color)%nxr = local_dim_r(2,group_start)
399	node_grid(my_color)%nys = local_dim_r(3,group_start)
400
401	DO n = 1, this%n_npes-1
402
403	pe = n
404	IF ( n > 0 .AND. MOD( n,sh_group_size ) == 0 ) THEN
405	!
406	!-- If group boundary, start new IO group
407	node_grid(my_color)%nyn = local_dim_r(4,pe-1)
408	my_color = my_color + 1
409	group_start = pe
410	node_grid(my_color)%nxl = local_dim_r(1,group_start)
411	node_grid(my_color)%nxr = local_dim_r(2,group_start)
412	node_grid(my_color)%nys = local_dim_r(3,group_start)
413
414	ELSEIF ( local_dim_r(1,pe) /= node_grid(my_color)%nxl ) THEN
415	!
416	!-- If nxl changes, start new IO group
417	node_grid(my_color)%nyn = local_dim_r(4,pe-1)
418	my_color = my_color+1
419	group_start = pe
420	node_grid(my_color)%nxl = local_dim_r(1,group_start)
421	node_grid(my_color)%nxr = local_dim_r(2,group_start)
422	node_grid(my_color)%nys = local_dim_r(3,group_start)
423	ENDIF
424	!
425	!-- Save values for local PE
426	IF ( this%n_rank == pe ) THEN !
427	color = my_color
428	ENDIF
429	IF ( n == this%n_npes-1 ) node_grid(my_color)%nyn = local_dim_r(4,pe)
430
431	ENDDO
432
433	IF ( this%n_rank == 0 ) THEN
434	color = 1
435	ENDIF
436
437	this%io_grid = node_grid(color)
438	this%io_grid%nnx = this%io_grid%nxr - this%io_grid%nxl + 1
439	this%io_grid%nny = this%io_grid%nyn - this%io_grid%nys + 1
440
441	END SUBROUTINE compute_color
442	#endif
443
444	END SUBROUTINE sm_init_comm
445
446	!
447	!-- Initializing setup for output of particle time series.
448	!-- This output always uses a shared memory to reduce the number of particle transfers.
449	SUBROUTINE sm_init_data_output_particles( this )
450
451	IMPLICIT NONE
452
453	CLASS(sm_class), INTENT(INOUT) :: this !< pointer to access internal variables of this call
454
455	#if defined( __parallel )
456	INTEGER(iwp) :: color !<
457	INTEGER(iwp) :: ierr !<
458	INTEGER(iwp) :: max_npes_per_node !< maximum number of PEs/node
459	#endif
460
461	LOGICAL :: sm_active !<
462
463
464	this%nr_io_pe_per_node = 2
465
466	sm_active = .TRUE. ! particle IO always uses shared memory
467	this%comm_model = comm2d
468
469	this%no_shared_memory_in_this_run = .NOT. sm_active
470	this%comm_io = this%comm_model ! preset in case of non shared-memory-IO
471
472	IF ( this%no_shared_memory_in_this_run ) THEN
473	this%iam_io_pe = .TRUE.
474	RETURN
475	ENDIF
476
477	#if defined( __parallel )
478	!
479	!-- Determine, how many PEs are running on a node.
480	this%iam_io_pe = .FALSE.
481	CALL MPI_COMM_SPLIT_TYPE( this%comm_model, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, &
482	this%comm_node, ierr )
483	CALL MPI_COMM_SIZE( this%comm_node, this%n_npes, ierr )
484	CALL MPI_COMM_RANK( this%comm_node, this%n_rank, ierr )
485
486	CALL MPI_ALLREDUCE( this%n_npes, max_npes_per_node, 1, MPI_INTEGER, MPI_MAX, this%comm_model, &
487	ierr )
488	!
489	!-- TODO: better explanation
490	!-- It has to be testet, if using memory blocks for an IO process (MPI shared Memory), or if it is
491	!-- even better to use the complete node for MPI shared memory (this%nr_io_pe_per_node = 1).
492	!- In the latter case, the access to the MPI shared memory buffer is slower, the number of
493	!-- particles to move between PEs will be much smaller.
494	IF ( max_npes_per_node > 64 ) THEN
495	!
496	!-- Special configuration on the HLRN-IV system with 4 shared memory blocks/node
497	this%nr_io_pe_per_node = 4
498	ENDIF
499
500	IF ( this%nr_io_pe_per_node == 1 ) THEN
501	!
502	!-- This branch is not realized so far
503	this%iam_io_pe = ( this%n_rank == 0 )
504	this%comm_shared = this%comm_node
505	CALL MPI_COMM_SIZE( this%comm_shared, this%sh_npes, ierr )
506	CALL MPI_COMM_RANK( this%comm_shared, this%sh_rank, ierr )
507
508	ELSEIF( this%nr_io_pe_per_node == 2 ) THEN
509
510	this%iam_io_pe = ( this%n_rank == 0 .OR. this%n_rank == this%n_npes/2 )
511	IF ( this%n_rank < this%n_npes/2 ) THEN
512	color = 1
513	ELSE
514	color = 2
515	ENDIF
516	CALL MPI_COMM_SPLIT( this%comm_node, color, 0, this%comm_shared, ierr )
517	CALL MPI_COMM_SIZE( this%comm_shared, this%sh_npes, ierr )
518	CALL MPI_COMM_RANK( this%comm_shared, this%sh_rank, ierr )
519
520	ELSEIF( this%nr_io_pe_per_node == 4 ) THEN
521
522	this%iam_io_pe = ( this%n_rank == 0 .OR. this%n_rank == this%n_npes/4 .OR. &
523	this%n_rank == this%n_npes/2 .OR. this%n_rank == (3*this%n_npes)/4 )
524	IF ( this%n_rank < this%n_npes/4 ) THEN
525	color = 1
526	ELSEIF( this%n_rank < this%n_npes/2 ) THEN
527	color = 2
528	ELSEIF( this%n_rank < (3*this%n_npes)/4 ) THEN
529	color = 3
530	ELSE
531	color = 4
532	ENDIF
533	CALL MPI_COMM_SPLIT( this%comm_node, color, 0, this%comm_shared, ierr )
534	CALL MPI_COMM_SIZE( this%comm_shared, this%sh_npes, ierr )
535	CALL MPI_COMM_RANK( this%comm_shared, this%sh_rank, ierr )
536
537	ELSE
538
539	WRITE( , ) 'shared_memory_io_mod: internal error'
540	WRITE( , ) 'only 1, 2 or 4 shared memory groups per node are allowed '
541	WRITE( , ) 'here, ', this%nr_io_pe_per_node, ' groups have been set'
542	STOP
543
544	ENDIF
545
546	!
547	!-- Setup the shared memory area
548	CALL MPI_COMM_SPLIT( this%comm_node, color, 0, this%comm_shared, ierr )
549	CALL MPI_COMM_SIZE( this%comm_shared, this%sh_npes, ierr )
550	CALL MPI_COMM_RANK( this%comm_shared, this%sh_rank, ierr )
551
552	!
553	!-- Setup the communicator across the nodes depending on the shared memory rank.
554	!-- All PEs with shared memory rank 0 will be I/O PEs.
555	color = this%sh_rank
556	CALL MPI_COMM_SPLIT( this%comm_model, color, 0, this%comm_io, ierr )
557
558	IF ( this%comm_io /= MPI_COMM_NULL ) THEN
559	CALL MPI_COMM_SIZE( this%comm_io, this%io_npes, ierr )
560	CALL MPI_COMM_RANK( this%comm_io, this%io_rank, ierr )
561	ELSE
562	this%io_npes = -1
563	this%io_rank = -1
564	ENDIF
565
566	IF ( this%sh_rank == 0 ) THEN
567	this%iam_io_pe = .TRUE.
568	this%io_pe_global_rank = myid
569	ENDIF
570	CALL MPI_BCAST( this%io_pe_global_rank, 1, MPI_INTEGER, 0, this%comm_shared, ierr )
571
572	#else
573	this%iam_io_pe = .FALSE.
574	#endif
575
576	END SUBROUTINE sm_init_data_output_particles
577
578	!--------------------------------------------------------------------------------------------------!
579	! Description:
580	! ------------
581	!> Function to return if shared Memory IO is active.
582	!--------------------------------------------------------------------------------------------------!
583	FUNCTION is_sm_active( this ) RESULT( ac )
584
585	IMPLICIT NONE
586
587	CLASS(sm_class), INTENT(inout) :: this !<
588
589	LOGICAL :: ac !<
590
591	ac = .NOT. this%no_shared_memory_in_this_run
592
593	END FUNCTION is_sm_active
594
595
596	#if defined( __parallel )
597
598	!--------------------------------------------------------------------------------------------------!
599	! Description:
600	! ------------
601	!> Allocate shared 1d-REAL (64 bit) array on PE 0 and pass address to all PEs.
602	!--------------------------------------------------------------------------------------------------!
603	SUBROUTINE sm_allocate_shared_1d_64( this, p1, d1, d2, win )
604
605	IMPLICIT NONE
606
607	CLASS(sm_class), INTENT(inout) :: this
608
609	INTEGER(iwp) :: disp_unit
610	INTEGER(iwp), INTENT(IN) :: d1
611	INTEGER(iwp), INTENT(IN) :: d2
612	INTEGER(iwp), SAVE :: pe_from = 0
613	INTEGER(iwp), INTENT(OUT) :: win
614
615	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size
616	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize
617
618	INTEGER(iwp), DIMENSION(1) :: buf_shape
619
620	REAL(dp), DIMENSION(:), POINTER :: buf
621	REAL(dp), DIMENSION(:), POINTER :: p1
622
623	TYPE(C_PTR), SAVE :: base_ptr
624	TYPE(C_PTR), SAVE :: rem_ptr
625
626
627	IF ( this%no_shared_memory_in_this_run ) RETURN
628	!
629	!-- Allocate shared memory on node rank 0 PEs.
630	IF ( this%sh_rank == pe_from ) THEN
631	wsize = d2 - d1 + 1
632	ELSE
633	wsize = 1
634	ENDIF
635	wsize = wsize * dp ! please note, size is always in bytes, independently of the displacement
636	! unit
637
638	CALL MPI_WIN_ALLOCATE_SHARED( wsize, dp, MPI_INFO_NULL, this%comm_shared,base_ptr, win, ierr )
639	!
640	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
641	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
642	!
643	!-- Convert C- to Fortran-pointer
644	buf_shape(1) = d2 - d1 + 1
645	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
646	p1(d1:) => buf
647	!
648	!-- Allocate shared memory in round robin on all PEs of a node.
649	pe_from = MOD( pe_from, this%sh_npes )
650
651	END SUBROUTINE sm_allocate_shared_1d_64
652
653
654	!--------------------------------------------------------------------------------------------------!
655	! Description:
656	! ------------
657	!> Allocate shared 1d-REAL (32 bit) array on PE 0 and pass address to all PEs
658	!--------------------------------------------------------------------------------------------------!
659	SUBROUTINE sm_allocate_shared_1d_32( this, p1, d1, d2, win )
660
661	IMPLICIT NONE
662
663	CLASS(sm_class), INTENT(inout) :: this
664
665	INTEGER(iwp) :: disp_unit
666	INTEGER(iwp), INTENT(IN) :: d1
667	INTEGER(iwp), INTENT(IN) :: d2
668	INTEGER(iwp), SAVE :: pe_from = 0
669	INTEGER(iwp), INTENT(OUT) :: win
670
671	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size
672	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize
673
674	INTEGER(iwp), DIMENSION(1) :: buf_shape
675
676	REAL(sp), DIMENSION(:), POINTER :: buf
677	REAL(sp), DIMENSION(:), POINTER :: p1
678
679	TYPE(C_PTR), SAVE :: base_ptr
680	TYPE(C_PTR), SAVE :: rem_ptr
681
682
683	IF ( this%no_shared_memory_in_this_run ) RETURN
684	!
685	!-- Allocate shared memory on node rank 0 PEs.
686	IF ( this%sh_rank == pe_from ) THEN
687	wsize = d2 - d1 + 1
688	ELSE
689	wsize = 1
690	ENDIF
691	wsize = wsize * sp ! Please note, size is always in bytes, independently of the displacement
692	! unit
693
694	CALL MPI_WIN_ALLOCATE_SHARED( wsize, sp, MPI_INFO_NULL, this%comm_shared,base_ptr, win, ierr )
695	!
696	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
697	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
698	!
699	!-- Convert C- to Fortran-pointer
700	buf_shape(1) = d2 - d1 + 1
701	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
702	p1(d1:) => buf
703	!
704	!-- Allocate shared memory in round robin on all PEs of a node.
705	pe_from = MOD( pe_from, this%sh_npes )
706
707	END SUBROUTINE sm_allocate_shared_1d_32
708
709
710	!--------------------------------------------------------------------------------------------------!
711	! Description:
712	! ------------
713	!> Allocate shared 1d-INTEGER array on PE 0 and pass address to all PEs.
714	!--------------------------------------------------------------------------------------------------!
715	SUBROUTINE sm_allocate_shared_1di( this, p1, d1, d2, win )
716
717	IMPLICIT NONE
718
719	CLASS(sm_class), INTENT(inout) :: this
720
721	INTEGER(iwp) :: disp_unit
722	INTEGER(iwp), INTENT(IN) :: d1
723	INTEGER(iwp), INTENT(IN) :: d2
724	INTEGER(iwp), SAVE :: pe_from = 0
725	INTEGER(iwp), INTENT(OUT) :: win
726
727	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size
728	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize
729
730	INTEGER(iwp), DIMENSION(1) :: buf_shape
731
732	INTEGER(iwp), DIMENSION(:), POINTER :: buf
733	INTEGER(iwp), DIMENSION(:), POINTER :: p1
734
735	TYPE(C_PTR), SAVE :: base_ptr
736	TYPE(C_PTR), SAVE :: rem_ptr
737
738
739	IF ( this%no_shared_memory_in_this_run ) RETURN
740	!
741	!-- Allocate shared memory on node rank 0 PEs.
742	IF ( this%sh_rank == pe_from ) THEN
743	wsize = d2 - d1 + 1
744	ELSE
745	wsize = 1
746	ENDIF
747	wsize = wsize * iwp ! Please note, size is always in bytes, independently of the displacement
748	! unit
749
750	CALL MPI_WIN_ALLOCATE_SHARED( wsize, iwp, MPI_INFO_NULL, this%comm_shared,base_ptr, win, ierr )
751	!
752	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
753	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
754	!
755	!-- Convert C- to Fortran-pointer
756	buf_shape(1) = d2 - d1 + 1
757	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
758	p1(d1:) => buf
759	!
760	!-- Allocate shared memory in round robin on all PEs of a node.
761	pe_from = MOD( pe_from, this%sh_npes )
762
763	END SUBROUTINE sm_allocate_shared_1di
764
765
766	!--------------------------------------------------------------------------------------------------!
767	! Description:
768	! ------------
769	!> Allocate shared 2d-REAL array (64 bit) on PE 0 and pass address to all PEs.
770	!--------------------------------------------------------------------------------------------------!
771	SUBROUTINE sm_allocate_shared_2d_64( this, p2, n_nxlg, n_nxrg, n_nysg, n_nyng, win )
772
773	IMPLICIT NONE
774
775	CLASS(sm_class), INTENT(INOUT) :: this
776
777	INTEGER(iwp) :: disp_unit
778	INTEGER(iwp), INTENT(IN) :: n_nxlg
779	INTEGER(iwp), INTENT(IN) :: n_nxrg
780	INTEGER(iwp), INTENT(IN) :: n_nyng
781	INTEGER(iwp), INTENT(IN) :: n_nysg
782	INTEGER(iwp), SAVE :: pe_from = 0
783	INTEGER(iwp), INTENT(OUT) :: win
784
785	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size
786	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize
787
788	INTEGER(iwp), DIMENSION(2) :: buf_shape
789
790	REAL(dp), DIMENSION(:,:), POINTER :: buf
791	REAL(dp), DIMENSION(:,:), POINTER :: p2
792
793	TYPE(C_PTR), SAVE :: base_ptr
794	TYPE(C_PTR), SAVE :: rem_ptr
795
796
797	IF ( this%no_shared_memory_in_this_run ) RETURN
798	!
799	!-- Allocate shared memory on node rank 0 PEs.
800	IF ( this%sh_rank == pe_from ) THEN
801	wsize = ( n_nyng - n_nysg + 1 ) * ( n_nxrg - n_nxlg + 1 )
802	ELSE
803	wsize = 1
804	ENDIF
805
806	wsize = wsize * dp ! Please note, size is always in bytes, independently of the displacement
807	! unit
808
809	CALL MPI_WIN_ALLOCATE_SHARED( wsize, 8, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr )
810	!
811	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
812	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
813	!
814	!-- Convert C- to Fortran-pointer
815	buf_shape(2) = n_nyng - n_nysg + 1
816	buf_shape(1) = n_nxrg - n_nxlg + 1
817	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
818	p2(n_nxlg:, n_nysg:) => buf
819	!
820	!-- Allocate shared memory in round robin on all PEs of a node.
821	pe_from = MOD( pe_from, this%sh_npes )
822
823	END SUBROUTINE sm_allocate_shared_2d_64
824
825
826	!--------------------------------------------------------------------------------------------------!
827	! Description:
828	! ------------
829	!> Allocate shared 2d-REAL (32 Bit) array on PE 0 and pass address to all PEs.
830	!--------------------------------------------------------------------------------------------------!
831	SUBROUTINE sm_allocate_shared_2d_32( this, p2, n_nxlg, n_nxrg, n_nysg, n_nyng, win )
832
833	IMPLICIT NONE
834
835	CLASS(sm_class), INTENT(INOUT) :: this
836
837	INTEGER(iwp) :: disp_unit
838	INTEGER(iwp), INTENT(IN) :: n_nxlg
839	INTEGER(iwp), INTENT(IN) :: n_nxrg
840	INTEGER(iwp), INTENT(IN) :: n_nyng
841	INTEGER(iwp), INTENT(IN) :: n_nysg
842	INTEGER(iwp), SAVE :: pe_from = 0
843	INTEGER(iwp), INTENT(OUT) :: win
844
845	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size
846	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize
847
848	INTEGER(iwp), DIMENSION(2) :: buf_shape
849
850	REAL(sp), DIMENSION(:,:), POINTER :: buf
851	REAL(sp), DIMENSION(:,:), POINTER :: p2
852
853	TYPE(C_PTR), SAVE :: base_ptr
854	TYPE(C_PTR), SAVE :: rem_ptr
855
856
857	IF ( this%no_shared_memory_in_this_run ) RETURN
858	!
859	!-- Allocate shared memory on node rank 0 PEs.
860	IF ( this%sh_rank == pe_from ) THEN
861	wsize = ( n_nyng - n_nysg + 1 ) * ( n_nxrg - n_nxlg + 1 )
862	ELSE
863	wsize = 1
864	ENDIF
865
866	wsize = wsize * sp ! Please note, size is always in bytes, independently of the displacement
867	! unit
868
869	CALL MPI_WIN_ALLOCATE_SHARED( wsize, dp, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr )
870	!
871	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
872	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
873	!
874	!-- Convert C- to Fortran-pointer
875	buf_shape(2) = n_nyng - n_nysg + 1
876	buf_shape(1) = n_nxrg - n_nxlg + 1
877	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
878	p2(n_nxlg:, n_nysg:) => buf
879	!
880	!-- Allocate shared memory in round robin on all PEs of a node.
881	pe_from = MOD( pe_from, this%sh_npes )
882
883	END SUBROUTINE sm_allocate_shared_2d_32
884
885
886	!--------------------------------------------------------------------------------------------------!
887	! Description:
888	! ------------
889	!> Allocate shared 2d-INTEGER array on PE 0 and pass address to all PEs.
890	!--------------------------------------------------------------------------------------------------!
891	SUBROUTINE sm_allocate_shared_2di( this, p2i, n_nxlg, n_nxrg, n_nysg, n_nyng, win )
892
893	IMPLICIT NONE
894
895	CLASS(sm_class), INTENT(inout) :: this !<
896
897	INTEGER(iwp) :: disp_unit !<
898	INTEGER(iwp), INTENT(IN) :: n_nxlg !<
899	INTEGER(iwp), INTENT(IN) :: n_nxrg !<
900	INTEGER(iwp), INTENT(IN) :: n_nyng !<
901	INTEGER(iwp), INTENT(IN) :: n_nysg !<
902	INTEGER(iwp), SAVE :: pe_from = 0 !<
903	INTEGER(iwp), INTENT(OUT) :: win !<
904
905	INTEGER(kind=MPI_ADDRESS_KIND) :: rem_size !<
906	INTEGER(kind=MPI_ADDRESS_KIND) :: wsize !<
907
908	INTEGER(iwp), DIMENSION(2) :: buf_shape !<
909
910	INTEGER(iwp), DIMENSION(:,:), POINTER :: buf !<
911	INTEGER(iwp), DIMENSION(:,:), POINTER :: p2i !<
912
913	TYPE(C_PTR), SAVE :: base_ptr !<
914	TYPE(C_PTR), SAVE :: rem_ptr !<
915
916
917	IF ( this%no_shared_memory_in_this_run ) RETURN
918	!
919	!-- Allocate shared memory on node rank 0 PEs.
920	IF ( this%sh_rank == pe_from ) THEN
921	wsize = ( n_nyng - n_nysg + 1 ) * ( n_nxrg - n_nxlg + 1 )
922	ELSE
923	wsize = 1
924	ENDIF
925
926	wsize = wsize * 4 ! Please note, size is always in bytes, independently of the displacement
927	! unit
928
929	CALL MPI_WIN_ALLOCATE_SHARED( wsize, 4, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr )
930	!
931	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
932	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
933	!
934	!-- Convert C- to Fortran-pointer
935	buf_shape(2) = n_nyng - n_nysg + 1
936	buf_shape(1) = n_nxrg - n_nxlg + 1
937	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
938	p2i(n_nxlg:, n_nysg:) => buf
939	!
940	!-- Allocate shared memory in round robin on all PEs of a node.
941	pe_from = MOD( pe_from, this%sh_npes )
942
943	END SUBROUTINE sm_allocate_shared_2di
944
945
946	!--------------------------------------------------------------------------------------------------!
947	! Description:
948	! ------------
949	!> Allocate shared 3d-REAL (64 bit) array on PE 0 and pass address to all PEs.
950	!--------------------------------------------------------------------------------------------------!
951	SUBROUTINE sm_allocate_shared_3d_64( this, p3, d1s, d1e, d2s, d2e, d3s, d3e, win )
952
953	IMPLICIT NONE
954
955	CLASS(sm_class), INTENT(inout) :: this !<
956
957	INTEGER(iwp) :: disp_unit !<
958	INTEGER(iwp), INTENT(IN) :: d1e !<
959	INTEGER(iwp), INTENT(IN) :: d1s !<
960	INTEGER(iwp), INTENT(IN) :: d2e !<
961	INTEGER(iwp), INTENT(IN) :: d2s !<
962	INTEGER(iwp), INTENT(IN) :: d3e !<
963	INTEGER(iwp), INTENT(IN) :: d3s !<
964	INTEGER(iwp), SAVE :: pe_from = 0 !<
965	INTEGER(iwp), INTENT(OUT) :: win !<
966
967	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size !<
968	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize !<
969
970	INTEGER(iwp), DIMENSION(3) :: buf_shape !<
971
972	REAL(dp), DIMENSION(:,:,:), POINTER :: buf !<
973	REAL(dp), DIMENSION(:,:,:), POINTER :: p3 !<
974
975	TYPE(C_PTR), SAVE :: base_ptr !<
976	TYPE(C_PTR), SAVE :: rem_ptr !<
977
978
979	IF ( this%no_shared_memory_in_this_run ) RETURN
980	!
981	!-- Allocate shared memory on node rank 0 PEs.
982	IF ( this%sh_rank == pe_from ) THEN
983	wsize = ( d3e - d3s + 1 ) * ( d2e - d2s + 1 ) * ( d1e - d1s + 1 )
984	ELSE
985	wsize = 1
986	ENDIF
987
988	wsize = wsize * dp ! Please note, size is always in bytes, independently of the displacement
989	! unit
990
991	CALL MPI_WIN_ALLOCATE_SHARED( wsize, dp, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr )
992	!
993	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
994	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
995	!
996	!-- Convert C- to Fortran-pointer
997	buf_shape(3) = d3e - d3s + 1
998	buf_shape(2) = d2e - d2s + 1
999	buf_shape(1) = d1e - d1s + 1
1000	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
1001	p3(d1s:,d2s:,d3s:) => buf
1002	!
1003	!-- Allocate shared memory in round robin on all PEs of a node.
1004	pe_from = MOD( pe_from, this%sh_npes )
1005
1006	END SUBROUTINE sm_allocate_shared_3d_64
1007
1008
1009	!--------------------------------------------------------------------------------------------------!
1010	! Description:
1011	! ------------
1012	!> Allocate shared 3d-REAL (32 bit) array on PE 0 and pass address to all PEs.
1013	!--------------------------------------------------------------------------------------------------!
1014	SUBROUTINE sm_allocate_shared_3d_32( this, p3, d1s, d1e, d2s, d2e, d3s, d3e, win )
1015
1016	IMPLICIT NONE
1017
1018	CLASS(sm_class), INTENT(inout) :: this
1019
1020	INTEGER(iwp) :: disp_unit
1021	INTEGER(iwp), INTENT(IN) :: d1e
1022	INTEGER(iwp), INTENT(IN) :: d1s
1023	INTEGER(iwp), INTENT(IN) :: d2e
1024	INTEGER(iwp), INTENT(IN) :: d2s
1025	INTEGER(iwp), INTENT(IN) :: d3e
1026	INTEGER(iwp), INTENT(IN) :: d3s
1027	INTEGER(iwp), SAVE :: pe_from = 0
1028	INTEGER(iwp), INTENT(OUT) :: win
1029
1030	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size
1031	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize
1032
1033	INTEGER(iwp), DIMENSION(3) :: buf_shape
1034
1035	REAL(sp), DIMENSION(:,:,:), POINTER :: buf
1036	REAL(sp), DIMENSION(:,:,:), POINTER :: p3
1037
1038	TYPE(C_PTR), SAVE :: base_ptr
1039	TYPE(C_PTR), SAVE :: rem_ptr
1040
1041
1042	IF ( this%no_shared_memory_in_this_run ) RETURN
1043	!
1044	!-- Allocate shared memory on node rank 0 PEs.
1045	IF ( this%sh_rank == pe_from ) THEN
1046	wsize = ( d3e - d3s + 1 ) * ( d2e - d2s + 1 ) * ( d1e - d1s + 1 )
1047	ELSE
1048	wsize = 1
1049	ENDIF
1050
1051	wsize = wsize * sp ! Please note, size is always in bytes, independently of the displacement
1052	! unit
1053
1054	CALL MPI_WIN_ALLOCATE_SHARED( wsize, sp, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr )
1055	!
1056	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
1057	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
1058	!
1059	!-- Convert C- to Fortran-pointer
1060	buf_shape(3) = d3e - d3s + 1
1061	buf_shape(2) = d2e - d2s + 1
1062	buf_shape(1) = d1e - d1s + 1
1063	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
1064	p3(d1s:,d2s:,d3s:) => buf
1065	!
1066	!-- Allocate shared memory in round robin on all PEs of a node.
1067	pe_from = MOD( pe_from, this%sh_npes )
1068
1069	END SUBROUTINE sm_allocate_shared_3d_32
1070
1071
1072	!--------------------------------------------------------------------------------------------------!
1073	! Description:
1074	! ------------
1075	!> Allocate shared 4d-REAL (64 bit) array on PE 0 and pass address to all PEs.
1076	!--------------------------------------------------------------------------------------------------!
1077	SUBROUTINE sm_allocate_shared_4d_64( this, p3, d1s, d1e, d2s, d2e, d3s, d3e, d4s, d4e, win )
1078
1079	IMPLICIT NONE
1080
1081	CLASS(sm_class), INTENT(inout) :: this !<
1082
1083	INTEGER :: disp_unit !<
1084	INTEGER(iwp), INTENT(IN) :: d1e !<
1085	INTEGER(iwp), INTENT(IN) :: d1s !<
1086	INTEGER(iwp), INTENT(IN) :: d2e !<
1087	INTEGER(iwp), INTENT(IN) :: d2s !<
1088	INTEGER(iwp), INTENT(IN) :: d3e !<
1089	INTEGER(iwp), INTENT(IN) :: d3s !<
1090	INTEGER(iwp), INTENT(IN) :: d4e !<
1091	INTEGER(iwp), INTENT(IN) :: d4s !<
1092	INTEGER(iwp), SAVE :: pe_from = 0 !<
1093	INTEGER(iwp), INTENT(OUT) :: win !<
1094
1095	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size !<
1096	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize !<
1097
1098	INTEGER(iwp), DIMENSION(4) :: buf_shape !<
1099
1100	REAL(dp), DIMENSION(:,:,:,:), POINTER :: buf !<
1101	REAL(dp), DIMENSION(:,:,:,:), POINTER :: p3 !<
1102
1103	TYPE(C_PTR), SAVE :: base_ptr !<
1104	TYPE(C_PTR), SAVE :: rem_ptr !<
1105
1106
1107	IF ( this%no_shared_memory_in_this_run ) RETURN
1108	!
1109	!-- Allocate shared memory on node rank 0 PEs.
1110	IF ( this%sh_rank == pe_from ) THEN
1111	wsize = (d4e - d4s +1) * ( d3e - d3s + 1 ) * ( d2e - d2s + 1 ) * ( d1e - d1s + 1 )
1112	ELSE
1113	wsize = 1
1114	ENDIF
1115
1116	wsize = wsize * dp ! Please note, size is always in bytes, independently of the displacement
1117	! unit
1118
1119	CALL MPI_WIN_ALLOCATE_SHARED( wsize, dp, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr )
1120	!
1121	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
1122	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
1123	!
1124	!-- Convert C- to Fortran-pointer
1125	buf_shape(4) = d4e - d4s + 1
1126	buf_shape(3) = d3e - d3s + 1
1127	buf_shape(2) = d2e - d2s + 1
1128	buf_shape(1) = d1e - d1s + 1
1129	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
1130	p3(d1s:,d2s:,d3s:,d4s:) => buf
1131	!
1132	!-- Allocate shared memory in round robin on all PEs of a node.
1133	pe_from = MOD( pe_from, this%sh_npes )
1134
1135	END SUBROUTINE sm_allocate_shared_4d_64
1136
1137
1138	!--------------------------------------------------------------------------------------------------!
1139	! Description:
1140	! ------------
1141	!> Allocate shared 4d-REAL (32 bit) array on PE 0 and pass address to all PEs.
1142	!--------------------------------------------------------------------------------------------------!
1143	SUBROUTINE sm_allocate_shared_4d_32( this, p3, d1s, d1e, d2s, d2e, d3s, d3e, d4s, d4e, win )
1144
1145	IMPLICIT NONE
1146
1147	CLASS(sm_class), INTENT(inout) :: this !<
1148
1149	INTEGER :: disp_unit !<
1150	INTEGER(iwp), INTENT(IN) :: d1e !<
1151	INTEGER(iwp), INTENT(IN) :: d1s !<
1152	INTEGER(iwp), INTENT(IN) :: d2e !<
1153	INTEGER(iwp), INTENT(IN) :: d2s !<
1154	INTEGER(iwp), INTENT(IN) :: d3e !<
1155	INTEGER(iwp), INTENT(IN) :: d3s !<
1156	INTEGER(iwp), INTENT(IN) :: d4e !<
1157	INTEGER(iwp), INTENT(IN) :: d4s !<
1158	INTEGER(iwp), SAVE :: pe_from = 0 !<
1159	INTEGER(iwp), INTENT(OUT) :: win !<
1160
1161	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size !<
1162	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize !<
1163
1164	INTEGER(iwp), DIMENSION(4) :: buf_shape !<
1165
1166	REAL(sp), DIMENSION(:,:,:,:), POINTER :: buf !<
1167	REAL(sp), DIMENSION(:,:,:,:), POINTER :: p3 !<
1168
1169	TYPE(C_PTR), SAVE :: base_ptr !<
1170	TYPE(C_PTR), SAVE :: rem_ptr !<
1171
1172
1173	IF ( this%no_shared_memory_in_this_run ) RETURN
1174	!
1175	!-- Allocate shared memory on node rank 0 PEs.
1176	IF ( this%sh_rank == pe_from ) THEN
1177	wsize = (d4e - d4s +1) * ( d3e - d3s + 1 ) * ( d2e - d2s + 1 ) * ( d1e - d1s + 1 )
1178	ELSE
1179	wsize = 1
1180	ENDIF
1181
1182	wsize = wsize * sp ! Please note, size is always in bytes, independently of the displacement
1183	! unit
1184
1185	CALL MPI_WIN_ALLOCATE_SHARED( wsize, dp, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr )
1186	!
1187	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
1188	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
1189	!
1190	!-- Convert C- to Fortran-pointer
1191	buf_shape(4) = d4e - d4s + 1
1192	buf_shape(3) = d3e - d3s + 1
1193	buf_shape(2) = d2e - d2s + 1
1194	buf_shape(1) = d1e - d1s + 1
1195	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
1196	p3(d1s:,d2s:,d3s:,d4s:) => buf
1197	!
1198	!-- Allocate shared memory in round robin on all PEs of a node.
1199	pe_from = MOD( pe_from, this%sh_npes )
1200
1201	END SUBROUTINE sm_allocate_shared_4d_32
1202
1203
1204	!--------------------------------------------------------------------------------------------------!
1205	! Description:
1206	! ------------
1207	!> Allocate shared 3d-INTEGER (32 bit) array on PE 0 and pass address to all PEs.
1208	!--------------------------------------------------------------------------------------------------!
1209	SUBROUTINE sm_allocate_shared_3di_32( this, p3, d1s, d1e, d2s, d2e, d3s, d3e, win )
1210
1211	IMPLICIT NONE
1212
1213	CLASS(sm_class), INTENT(inout) :: this
1214
1215	INTEGER :: disp_unit
1216	INTEGER(iwp), INTENT(IN) :: d1e
1217	INTEGER(iwp), INTENT(IN) :: d1s
1218	INTEGER(iwp), INTENT(IN) :: d2e
1219	INTEGER(iwp), INTENT(IN) :: d2s
1220	INTEGER(iwp), INTENT(IN) :: d3e
1221	INTEGER(iwp), INTENT(IN) :: d3s
1222	INTEGER(iwp), SAVE :: pe_from = 0
1223	INTEGER(iwp), INTENT(OUT) :: win
1224
1225	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size
1226	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize
1227
1228	INTEGER(iwp), DIMENSION(3) :: buf_shape
1229
1230	INTEGER(isp), DIMENSION(:,:,:), POINTER :: buf
1231	INTEGER(isp), DIMENSION(:,:,:), POINTER :: p3
1232
1233	TYPE(C_PTR), SAVE :: base_ptr
1234	TYPE(C_PTR), SAVE :: rem_ptr
1235
1236
1237	IF ( this%no_shared_memory_in_this_run ) RETURN
1238	!
1239	!-- Allocate shared memory on node rank 0 PEs.
1240	IF ( this%sh_rank == pe_from ) THEN
1241	wsize = ( d3e - d3s + 1 ) * ( d2e - d2s + 1 ) * ( d1e - d1s + 1 )
1242	ELSE
1243	wsize = 1
1244	ENDIF
1245
1246	wsize = wsize * isp ! Please note, size is always in bytes, independently of the displacement
1247	! unit
1248
1249	CALL MPI_WIN_ALLOCATE_SHARED( wsize, isp, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr )
1250	!
1251	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
1252	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
1253	!
1254	!-- Convert C- to Fortran-pointer
1255	buf_shape(3) = d3e - d3s + 1
1256	buf_shape(2) = d2e - d2s + 1
1257	buf_shape(1) = d1e - d1s + 1
1258	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
1259	p3(d1s:,d2s:,d3s:) => buf
1260	!
1261	!-- Allocate shared memory in round robin on all PEs of a node.
1262	pe_from = MOD( pe_from, this%sh_npes )
1263
1264	END SUBROUTINE sm_allocate_shared_3di_32
1265
1266
1267	!--------------------------------------------------------------------------------------------------!
1268	! Description:
1269	! ------------
1270	!> Allocate shared 3d-INTEGER (64 bit) array on PE 0 and pass address to all PEs.
1271	!--------------------------------------------------------------------------------------------------!
1272	SUBROUTINE sm_allocate_shared_3di_64( this, p3, d1s, d1e, d2s, d2e, d3s, d3e, win )
1273
1274	IMPLICIT NONE
1275
1276	CLASS(sm_class), INTENT(inout) :: this !<
1277
1278	INTEGER :: disp_unit !<
1279	INTEGER(iwp), INTENT(IN) :: d1e !<
1280	INTEGER(iwp), INTENT(IN) :: d1s !<
1281	INTEGER(iwp), INTENT(IN) :: d2e !<
1282	INTEGER(iwp), INTENT(IN) :: d2s !<
1283	INTEGER(iwp), INTENT(IN) :: d3e !<
1284	INTEGER(iwp), INTENT(IN) :: d3s !<
1285	INTEGER(iwp), SAVE :: pe_from = 0 !<
1286	INTEGER(iwp), INTENT(OUT) :: win !<
1287
1288	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size !<
1289	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize !<
1290
1291	INTEGER(iwp), DIMENSION(3) :: buf_shape !<
1292
1293	INTEGER(idp), DIMENSION(:,:,:), POINTER :: buf !<
1294	INTEGER(idp), DIMENSION(:,:,:), POINTER :: p3 !<
1295
1296	TYPE(C_PTR), SAVE :: base_ptr !<
1297	TYPE(C_PTR), SAVE :: rem_ptr !<
1298
1299
1300	IF ( this%no_shared_memory_in_this_run ) RETURN
1301	!
1302	!-- Allocate shared memory on node rank 0 PEs.
1303	IF ( this%sh_rank == pe_from ) THEN
1304	wsize = ( d3e - d3s + 1 ) * ( d2e - d2s + 1 ) * ( d1e - d1s + 1 )
1305	ELSE
1306	wsize = 1
1307	ENDIF
1308
1309	wsize = wsize * idp ! Please note, size is always in bytes, independently of the displacement
1310	! unit
1311
1312	CALL MPI_WIN_ALLOCATE_SHARED( wsize, idp, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr )
1313	!
1314	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
1315	CALL MPI_WIN_SHARED_QUERY( win, pe_from, rem_size, disp_unit, rem_ptr, ierr )
1316	!
1317	!-- Convert C- to Fortran-pointer
1318	buf_shape(3) = d3e - d3s + 1
1319	buf_shape(2) = d2e - d2s + 1
1320	buf_shape(1) = d1e - d1s + 1
1321	CALL C_F_POINTER( rem_ptr, buf, buf_shape )
1322	p3(d1s:,d2s:,d3s:) => buf
1323	!
1324	!-- Allocate shared memory in round robin on all PEs of a node.
1325	pe_from = MOD( pe_from, this%sh_npes )
1326
1327	END SUBROUTINE sm_allocate_shared_3di_64
1328
1329
1330	!--------------------------------------------------------------------------------------------------!
1331	! Description:
1332	! ------------
1333	!> Allocate shared 3d-REAL (64 Bit) array on ALL PEs.
1334	!>
1335	!> Every PE allocates the local part of a node-shared array.
1336	!> The C-Pointer of this array and the local limits are broadcasted to all PEs of the node
1337	!> The information is store in an array of type sm_remote_array and can be retrieved
1338	!> by sm_remote_array to access remote data.
1339	!--------------------------------------------------------------------------------------------------!
1340	SUBROUTINE sm_all_allocate_shared_3d_64( this, p3, d1s, d1e, d2s, d2e, d3s, d3e, remote_arrays, win )
1341
1342	IMPLICIT NONE
1343
1344	CLASS(sm_class), INTENT(inout) :: this !< class pointer
1345	REAL(dp), DIMENSION(:,:,:), POINTER :: p3 !< return local array pointer
1346
1347	INTEGER(iwp), INTENT(IN) :: d1e !< end index dimension 1
1348	INTEGER(iwp), INTENT(IN) :: d1s !< start index dimension 1
1349	INTEGER(iwp), INTENT(IN) :: d2e !< end index dimension 2
1350	INTEGER(iwp), INTENT(IN) :: d2s !< start index dimension 2
1351	INTEGER(iwp), INTENT(IN) :: d3e !< end index dimension 3
1352	INTEGER(iwp), INTENT(IN) :: d3s !< start index dimension 3
1353	INTEGER(iwp), INTENT(OUT) :: win !< MPI Window
1354
1355	INTEGER(iwp), DIMENSION(3) :: buf_shape !<
1356	INTEGER(iwp) :: disp_unit !<
1357	INTEGER(iwp) :: i !<
1358	INTEGER(iwp), SAVE :: pe_from = 0 !<
1359
1360	INTEGER(KIND=MPI_ADDRESS_KIND) :: rem_size !<
1361	INTEGER(KIND=MPI_ADDRESS_KIND) :: wsize !<
1362
1363	REAL(dp), DIMENSION(:,:,:), POINTER :: buf !<
1364
1365	TYPE(sm_remote_array),INTENT(INOUT), DIMENSION(0:this%sh_npes-1) :: remote_arrays !< info about all remote arrays
1366
1367	TYPE(C_PTR), SAVE :: base_ptr !<
1368
1369	INTEGER(iwp),DIMENSION(6,0:this%sh_npes-1) :: all_indices_s
1370	INTEGER(iwp),DIMENSION(6,0:this%sh_npes-1) :: all_indices
1371
1372
1373	IF ( this%no_shared_memory_in_this_run ) RETURN
1374
1375	all_indices_s = 0
1376
1377
1378	wsize = ( d3e - d3s + 1 ) * ( d2e - d2s + 1 ) * ( d1e - d1s + 1 )
1379
1380	wsize = wsize * dp ! Please note, size is always in bytes, independently of the displacement unit
1381
1382	CALL MPI_WIN_ALLOCATE_SHARED( wsize, dp, MPI_INFO_NULL, this%comm_shared, base_ptr, win, ierr )
1383	!
1384	!-- Get C-pointer of the memory located on node-rank pe_from (sh_rank == pe_from)
1385
1386	all_indices_s(1,this%sh_rank) = d1s
1387	all_indices_s(2,this%sh_rank) = d1e
1388	all_indices_s(3,this%sh_rank) = d2s
1389	all_indices_s(4,this%sh_rank) = d2e
1390	all_indices_s(5,this%sh_rank) = d3s
1391	all_indices_s(6,this%sh_rank) = d3e
1392
1393	CALL MPI_ALLREDUCE (all_indices_s ,all_indices, SIZE(all_indices_s), MPI_INTEGER, MPI_SUM, this%comm_shared, ierr)
1394
1395	DO i=0,this%sh_npes-1
1396	CALL MPI_WIN_SHARED_QUERY( win, i, rem_size, disp_unit, remote_arrays(i)%rem_ptr, ierr )
1397	remote_arrays(i)%d1s = all_indices(1,i)
1398	remote_arrays(i)%d1e = all_indices(2,i)
1399	remote_arrays(i)%d2s = all_indices(3,i)
1400	remote_arrays(i)%d2e = all_indices(4,i)
1401	remote_arrays(i)%d3s = all_indices(5,i)
1402	remote_arrays(i)%d3e = all_indices(6,i)
1403	END DO
1404
1405	!
1406	!-- Convert C- to Fortran-pointer
1407	buf_shape(3) = d3e - d3s + 1
1408	buf_shape(2) = d2e - d2s + 1
1409	buf_shape(1) = d1e - d1s + 1
1410	CALL C_F_POINTER( remote_arrays(this%sh_rank)%rem_ptr, buf, buf_shape )
1411	p3(d1s:,d2s:,d3s:) => buf
1412	!
1413	!-- Allocate shared memory in round robin on all PEs of a node.
1414	pe_from = MOD( pe_from, this%sh_npes )
1415
1416	END SUBROUTINE sm_all_allocate_shared_3d_64
1417	#endif
1418
1419
1420	!--------------------------------------------------------------------------------------------------!
1421	! Description:
1422	! ------------
1423	!> ???
1424	!--------------------------------------------------------------------------------------------------!
1425	SUBROUTINE sm_adjust_outer_boundary( this )
1426
1427	IMPLICIT NONE
1428
1429	CLASS(sm_class), INTENT(inout) :: this !<
1430
1431
1432	IF ( this%no_shared_memory_in_this_run ) RETURN
1433
1434	IF ( this%io_grid%nxl == 0 ) THEN
1435	this%io_grid%nxl = this%io_grid%nxl - nbgp
1436	this%io_grid%nnx = this%io_grid%nnx + nbgp
1437	ENDIF
1438
1439	IF ( this%io_grid%nxr == nx .OR. npex == -1 ) THEN ! npex == -1 if -D__parallel not set
1440	this%io_grid%nxr = this%io_grid%nxr + nbgp
1441	this%io_grid%nnx = this%io_grid%nnx + nbgp
1442	ENDIF
1443
1444	IF ( this%io_grid%nys == 0 ) THEN
1445	this%io_grid%nys = this%io_grid%nys - nbgp
1446	this%io_grid%nny = this%io_grid%nny + nbgp
1447	ENDIF
1448
1449	IF ( this%io_grid%nyn == ny .OR. npey == -1 ) THEN ! npey == -1 if -D__parallel not set
1450	this%io_grid%nyn = this%io_grid%nyn + nbgp
1451	this%io_grid%nny = this%io_grid%nny + nbgp
1452	ENDIF
1453
1454	this%io_grid%nxl = this%io_grid%nxl + nbgp
1455	this%io_grid%nxr = this%io_grid%nxr + nbgp
1456	this%io_grid%nys = this%io_grid%nys + nbgp
1457	this%io_grid%nyn = this%io_grid%nyn + nbgp
1458	this%io_grid%nnx = this%io_grid%nnx
1459	this%io_grid%nny = this%io_grid%nny
1460
1461	END SUBROUTINE sm_adjust_outer_boundary
1462
1463
1464	!--------------------------------------------------------------------------------------------------!
1465	! Description:
1466	! ------------
1467	!> Deallocate shared aray and free related window.
1468	!--------------------------------------------------------------------------------------------------!
1469	SUBROUTINE sm_free_shared( this, win )
1470
1471	IMPLICIT NONE
1472
1473	CLASS(sm_class), INTENT(inout) :: this !<
1474
1475	INTEGER(iwp), INTENT(INOUT) :: win !<
1476
1477	IF ( this%no_shared_memory_in_this_run ) RETURN
1478	#if defined( __parallel )
1479	CALL MPI_WIN_FREE( win, ierr )
1480	#endif
1481	win = -1
1482
1483	END SUBROUTINE sm_free_shared
1484
1485
1486	!--------------------------------------------------------------------------------------------------!
1487	! Description:
1488	! ------------
1489	!> ...
1490	!--------------------------------------------------------------------------------------------------!
1491	SUBROUTINE sm_node_barrier( this, win )
1492
1493	IMPLICIT NONE
1494
1495	INTEGER(iwp), OPTIONAL :: win !<
1496
1497	CLASS(sm_class), INTENT(inout) :: this !<
1498
1499
1500	IF ( this%no_shared_memory_in_this_run ) RETURN
1501
1502	#if defined( __parallel )
1503	CALL MPI_BARRIER( this%comm_shared, ierr )
1504	IF ( PRESENT(win) ) THEN
1505	CALL MPI_WIN_FENCE(0, win, ierr )
1506	ENDIF
1507	#endif
1508
1509	END SUBROUTINE sm_node_barrier
1510
1511
1512	SUBROUTINE save_grid_into_this_class( this )
1513
1514	IMPLICIT NONE
1515
1516	CLASS(domain_decomposition_grid_features), INTENT(inout) :: this !<
1517
1518	this%myid = myid !<
1519	this%nnx = nnx !<
1520	this%nny = nny !<
1521	this%nx = nx !<
1522	this%nxl = nxl !<
1523	this%nxr = nxr !<
1524	this%ny = ny !<
1525	this%nyn = nyn !<
1526	this%nys = nys !<
1527	this%numprocs = numprocs !<
1528	this%comm2d = comm2d !<
1529
1530	END SUBROUTINE save_grid_into_this_class
1531
1532
1533	SUBROUTINE activate_grid_from_this_class( this )
1534
1535	IMPLICIT NONE
1536
1537	CLASS(domain_decomposition_grid_features), INTENT(inout) :: this !<
1538
1539	myid = this%myid !<
1540	nnx = this%nnx !<
1541	nny = this%nny !<
1542	nx = this%nx !<
1543	nxl = this%nxl !<
1544	nxr = this%nxr !<
1545	ny = this%ny !<
1546	nyn = this%nyn !<
1547	nys = this%nys !<
1548	numprocs = this%numprocs !<
1549	comm2d = this%comm2d !<
1550
1551	END SUBROUTINE activate_grid_from_this_class
1552
1553	END MODULE shared_memory_io_mod

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |