Home

Context Navigation

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

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