Home

Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

shared_memory_io_mod.f90

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

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

Context Navigation

source: palm/trunk/SOURCE/shared_memory_io_mod.f90

Download in other formats: