Home

Context Navigation

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

Last change on this file since 4623 was 4620, checked in by raasch, 4 years ago
bugfix: variable definition changed
Property svn:keywords set to `Id`
File size: 41.3 KB

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