Home

Context Navigation

source: palm/trunk/SOURCE/restart_data_mpi_io_mod.f90 @ 4536

Last change on this file since 4536 was 4536, checked in by raasch, 4 years ago
messages and debug output converted to PALM routines (restart_data_mpi_io_mod), binary version number set to 5.0, heeader output for restart data format added, restart data filesize and I/O transfer speed added in cpu_measures, handling of single restart files (created with MPI-I/O) added to palmrun, bugfix: preprocessor directive adjusted (virtual_measurement_mod), location message format changed
Property svn:keywords set to `Id`
File size: 92.6 KB

Line
1	!> @file restart_data_mpi_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	! Current revisions:
20	! -----------------
21	!
22	!
23	! Former revisions:
24	! -----------------
25	! $Id: restart_data_mpi_io_mod.f90 4536 2020-05-17 17:24:13Z raasch $
26	! messages and debug output converted to PALM routines
27	!
28	! 4534 2020-05-14 18:35:22Z raasch
29	! I/O on reduced number of cores added (using shared memory MPI)
30	!
31	! 4500 2020-04-17 10:12:45Z suehring
32	! Fix too long lines
33	!
34	! 4498 2020-04-15 14:26:31Z raasch
35	! bugfix for creation of filetypes, argument removed from rd_mpi_io_open
36	!
37	! 4497 2020-04-15 10:20:51Z raasch
38	! last bugfix deactivated because of compile problems
39	!
40	! 4496 2020-04-15 08:37:26Z raasch
41	! problem with posix read arguments for surface data fixed
42	!
43	! 4495 2020-04-13 20:11:20Z raasch
44	! Initial version (K. Ketelsen), adjusted to PALM formatting standards (s. Raasch)
45	!
46	!
47	!
48	! Description:
49	! ------------
50	!> Routines for restart data handling using MPI-IO.
51	!--------------------------------------------------------------------------------------------------!
52	MODULE restart_data_mpi_io_mod
53
54	#if defined( __parallel )
55	#if defined( __mpifh )
56	INCLUDE "mpif.h"
57	#else
58	USE MPI
59	#endif
60	#else
61	USE posix_interface, &
62	ONLY: posix_close, posix_lseek, posix_open, posix_read, posix_write
63	#endif
64
65	USE, INTRINSIC :: ISO_C_BINDING
66
67	USE control_parameters, &
68	ONLY: debug_output, debug_string, include_total_domain_boundaries, message_string, &
69	restart_data_format_input, restart_data_format_output, restart_file_size
70
71	USE exchange_horiz_mod, &
72	ONLY: exchange_horiz, exchange_horiz_2d
73
74	USE indices, &
75	ONLY: nbgp, nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nz, nzb, nzt
76
77	USE kinds
78
79	USE pegrid, &
80	ONLY: comm1dx, comm1dy, comm2d, myid, myidx, myidy, npex, npey, numprocs, pdims
81
82	USE shared_memory_io_mod, &
83	ONLY: local_boundaries, sm_class
84
85
86	IMPLICIT NONE
87
88	CHARACTER(LEN=128) :: io_file_name !> internal variable to communicate filename between
89	!> different subroutines
90
91	#if defined( __parallel )
92	INTEGER(iwp) :: ierr !< error status of MPI-calls
93	INTEGER(iwp), PARAMETER :: rd_offset_kind = MPI_OFFSET_KIND !< Adress or Offset kind
94	INTEGER(iwp), PARAMETER :: rd_status_size = MPI_STATUS_SIZE !<
95	#else
96	INTEGER(iwp), PARAMETER :: rd_offset_kind = C_SIZE_T !<
97	INTEGER(iwp), PARAMETER :: rd_status_size = 1 !< Not required in sequential mode
98	#endif
99
100	INTEGER(iwp) :: debug_level = 1 !< TODO: replace with standard debug output steering
101
102	INTEGER(iwp) :: comm_io !< Communicator for MPI-IO
103	INTEGER(iwp) :: fh !< MPI-IO file handle
104	#if defined( __parallel )
105	INTEGER(iwp) :: fhs = -1 !< MPI-IO file handle to open file with comm2d always
106	#endif
107	INTEGER(iwp) :: ft_surf = -1 !< MPI filetype surface data
108	#if defined( __parallel )
109	INTEGER(iwp) :: ft_2di_nb !< MPI filetype 2D array INTEGER no outer boundary
110	INTEGER(iwp) :: ft_2d !< MPI filetype 2D array REAL with outer boundaries
111	INTEGER(iwp) :: ft_3d !< MPI filetype 3D array REAL with outer boundaries
112	INTEGER(iwp) :: ft_3dsoil !< MPI filetype for 3d-soil array
113	#endif
114	INTEGER(iwp) :: glo_start !< global start index on this PE
115	#if defined( __parallel )
116	INTEGER(iwp) :: local_start !<
117	#endif
118	INTEGER(iwp) :: nr_iope !<
119	INTEGER(iwp) :: nr_val !< local number of values in x and y direction
120	#if defined( __parallel )
121	INTEGER(iwp) :: win_2di
122	INTEGER(iwp) :: win_2dr
123	INTEGER(iwp) :: win_3dr
124	INTEGER(iwp) :: win_3ds
125	INTEGER(iwp) :: win_surf = -1
126	#endif
127	INTEGER(iwp) :: total_number_of_surface_values !< total number of values for one variable
128
129	INTEGER(KIND=rd_offset_kind) :: array_position !<
130	INTEGER(KIND=rd_offset_kind) :: header_position !<
131
132	INTEGER(iwp), DIMENSION(:,:), POINTER, CONTIGUOUS :: array_2di !<
133
134	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: m_end_index !<
135	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: m_start_index !<
136	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: m_global_start !<
137
138	LOGICAL :: all_pes_write !< all PEs have data to write
139	LOGICAL :: filetypes_created !<
140	LOGICAL :: io_on_limited_cores_per_node !< switch to shared memory MPI-IO
141	LOGICAL :: rd_flag !< file is opened for read
142	LOGICAL :: wr_flag !< file is opened for write
143
144	#if defined( __parallel )
145	REAL(wp), DIMENSION(:), POINTER, CONTIGUOUS :: array_1d !<
146	#endif
147	REAL(wp), DIMENSION(:,:), POINTER, CONTIGUOUS :: array_2d !<
148	REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: array_3d !<
149	REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: array_3d_soil !<
150
151	!
152	!-- Handling of outer boundaries
153	TYPE(local_boundaries) :: lb !<
154
155	!
156	!-- General Header (first 32 byte in restart file)
157	TYPE general_header
158	INTEGER(iwp) :: nr_int !< number of INTEGER entries in header
159	INTEGER(iwp) :: nr_char !< number of Text strings entries in header
160	INTEGER(iwp) :: nr_real !< number of REAL entries in header
161	INTEGER(iwp) :: nr_arrays !< number of arrays in restart files
162	INTEGER(iwp) :: total_nx !< total number of points in x-direction
163	INTEGER(iwp) :: total_ny !< total number of points in y-direction
164	INTEGER(iwp) :: i_outer_bound !< if 1, outer boundaries are stored in restart file
165	INTEGER(iwp) :: endian !< little endian (1) or big endian (2) internal format
166	END TYPE general_header
167
168	TYPE(general_header), TARGET :: tgh
169
170	TYPE(sm_class) :: sm_io
171
172	!
173	!-- Declaration of varibales for file header section
174	INTEGER(KIND=rd_offset_kind) :: header_int_index
175	INTEGER, PARAMETER :: max_nr_int=256
176	CHARACTER(LEN=32), DIMENSION(max_nr_int) :: int_names
177	INTEGER(KIND=iwp), DIMENSION(max_nr_int) :: int_values
178
179	INTEGER(KIND=rd_offset_kind) :: header_char_index
180	INTEGER, PARAMETER :: max_nr_text=128
181	CHARACTER(LEN=128), DIMENSION(max_nr_text) :: text_lines
182
183	INTEGER(KIND=rd_offset_kind) :: header_real_index
184	INTEGER, PARAMETER :: max_nr_real=256
185	CHARACTER(LEN=32), DIMENSION(max_nr_real) :: real_names
186	REAL(KIND=wp), DIMENSION(max_nr_real) :: real_values
187
188	INTEGER(KIND=rd_offset_kind) :: header_arr_index
189	INTEGER, PARAMETER :: max_nr_arrays=600
190	CHARACTER(LEN=32), DIMENSION(max_nr_arrays) :: array_names
191	INTEGER(KIND=rd_offset_kind), DIMENSION(max_nr_arrays) :: array_offset
192
193	SAVE
194
195	PRIVATE
196
197	PUBLIC restart_file_size, total_number_of_surface_values
198
199	!
200	!-- PALM interfaces
201	INTERFACE rd_mpi_io_check_array
202	MODULE PROCEDURE rd_mpi_io_check_array
203	END INTERFACE rd_mpi_io_check_array
204
205	INTERFACE rd_mpi_io_close
206	MODULE PROCEDURE rd_mpi_io_close
207	END INTERFACE rd_mpi_io_close
208
209	INTERFACE rd_mpi_io_open
210	MODULE PROCEDURE rd_mpi_io_open
211	END INTERFACE rd_mpi_io_open
212
213	INTERFACE rrd_mpi_io
214	MODULE PROCEDURE rrd_mpi_io_char
215	MODULE PROCEDURE rrd_mpi_io_int
216	MODULE PROCEDURE rrd_mpi_io_int_2d
217	MODULE PROCEDURE rrd_mpi_io_logical
218	MODULE PROCEDURE rrd_mpi_io_real
219	MODULE PROCEDURE rrd_mpi_io_real_2d
220	MODULE PROCEDURE rrd_mpi_io_real_3d
221	MODULE PROCEDURE rrd_mpi_io_real_3d_soil
222	END INTERFACE rrd_mpi_io
223
224	INTERFACE rrd_mpi_io_global_array
225	MODULE PROCEDURE rrd_mpi_io_global_array_int_1d
226	MODULE PROCEDURE rrd_mpi_io_global_array_real_1d
227	MODULE PROCEDURE rrd_mpi_io_global_array_real_2d
228	MODULE PROCEDURE rrd_mpi_io_global_array_real_3d
229	MODULE PROCEDURE rrd_mpi_io_global_array_real_4d
230	END INTERFACE rrd_mpi_io_global_array
231
232	INTERFACE rrd_mpi_io_surface
233	MODULE PROCEDURE rrd_mpi_io_surface
234	MODULE PROCEDURE rrd_mpi_io_surface_2d
235	END INTERFACE rrd_mpi_io_surface
236
237	INTERFACE rd_mpi_io_surface_filetypes
238	MODULE PROCEDURE rd_mpi_io_surface_filetypes
239	END INTERFACE rd_mpi_io_surface_filetypes
240
241	INTERFACE wrd_mpi_io
242	MODULE PROCEDURE wrd_mpi_io_char
243	MODULE PROCEDURE wrd_mpi_io_int
244	MODULE PROCEDURE wrd_mpi_io_int_2d
245	MODULE PROCEDURE wrd_mpi_io_logical
246	MODULE PROCEDURE wrd_mpi_io_real
247	MODULE PROCEDURE wrd_mpi_io_real_2d
248	MODULE PROCEDURE wrd_mpi_io_real_3d
249	MODULE PROCEDURE wrd_mpi_io_real_3d_soil
250	END INTERFACE wrd_mpi_io
251
252	INTERFACE wrd_mpi_io_global_array
253	MODULE PROCEDURE wrd_mpi_io_global_array_int_1d
254	MODULE PROCEDURE wrd_mpi_io_global_array_real_1d
255	MODULE PROCEDURE wrd_mpi_io_global_array_real_2d
256	MODULE PROCEDURE wrd_mpi_io_global_array_real_3d
257	MODULE PROCEDURE wrd_mpi_io_global_array_real_4d
258	END INTERFACE wrd_mpi_io_global_array
259
260	INTERFACE wrd_mpi_io_surface
261	MODULE PROCEDURE wrd_mpi_io_surface
262	MODULE PROCEDURE wrd_mpi_io_surface_2d
263	END INTERFACE wrd_mpi_io_surface
264
265	PUBLIC rd_mpi_io_check_array, rd_mpi_io_close, rd_mpi_io_open, rrd_mpi_io, &
266	rrd_mpi_io_global_array, rrd_mpi_io_surface, rd_mpi_io_surface_filetypes, wrd_mpi_io, &
267	wrd_mpi_io_global_array, wrd_mpi_io_surface
268
269
270	CONTAINS
271
272
273	!--------------------------------------------------------------------------------------------------!
274	! Description:
275	! ------------
276	!> Open restart file for read or write with MPI-IO
277	!--------------------------------------------------------------------------------------------------!
278	SUBROUTINE rd_mpi_io_open( action, file_name, open_for_global_io_only )
279
280	IMPLICIT NONE
281
282	CHARACTER(LEN=*), INTENT(IN) :: action !<
283	CHARACTER(LEN=*), INTENT(IN) :: file_name !<
284
285	INTEGER(iwp) :: i !<
286	INTEGER(iwp) :: gh_size !<
287
288	INTEGER(KIND=rd_offset_kind) :: offset !<
289
290	#if defined( __parallel )
291	INTEGER, DIMENSION(rd_status_size) :: status !<
292	#endif
293
294	LOGICAL, INTENT(IN), OPTIONAL :: open_for_global_io_only !<
295	LOGICAL :: set_filetype !<
296
297	#if ! defined( __parallel )
298	TYPE(C_PTR) :: buf_ptr !<
299	#endif
300
301
302	offset = 0
303	io_on_limited_cores_per_node = .FALSE.
304
305	rd_flag = ( TRIM( action ) == 'READ' .OR. TRIM( action ) == 'read' )
306	wr_flag = ( TRIM( action ) == 'WRITE' .OR. TRIM( action ) == 'write' )
307
308	IF ( .NOT. ( rd_flag .OR. wr_flag ) ) THEN
309	message_string = 'illegal action "' // TRIM( action ) // '" for opening restart files'
310	CALL message( 'restart_data_mpi_io_mod', 'PA0720', 1, 2, 0, 6, 0 )
311	ENDIF
312	!
313	!-- Store name of I/O file to communicate it internally within this module.
314	io_file_name = file_name
315	!
316	!-- Setup for IO on a limited number of threads per node (using shared memory MPI)
317	IF ( rd_flag ) THEN
318	set_filetype = .TRUE.
319	IF ( TRIM( restart_data_format_input ) == 'mpi_shared_memory' ) THEN
320	io_on_limited_cores_per_node = .TRUE.
321	ENDIF
322	ENDIF
323
324	IF ( TRIM( restart_data_format_output ) == 'mpi_shared_memory' .AND. wr_flag ) THEN
325	io_on_limited_cores_per_node = .TRUE.
326	ENDIF
327	!
328	!-- Shared memory MPI is not used for reading of global data
329	IF ( PRESENT( open_for_global_io_only ) .AND. rd_flag ) THEN
330	IF ( open_for_global_io_only ) THEN
331	io_on_limited_cores_per_node = .FALSE.
332	set_filetype = .FALSE.
333	ENDIF
334	ENDIF
335
336	CALL sm_io%sm_init_comm( io_on_limited_cores_per_node )
337
338	!
339	!-- Set communicator to be used. If all cores are doing I/O, comm2d is used as usual.
340	IF( sm_io%is_sm_active() ) THEN
341	comm_io = sm_io%comm_io
342	ELSE
343	comm_io = comm2d
344	ENDIF
345
346	!
347	!-- Create subarrays and file types
348	filetypes_created = .FALSE.
349
350	!
351	!-- In case of read it is not known yet if data include total domain. Filetypes will be created
352	!-- further below.
353	IF ( wr_flag ) THEN
354	CALL rd_mpi_io_create_filetypes
355	filetypes_created = .TRUE.
356	ENDIF
357
358	!
359	!-- Open file for MPI-IO
360	#if defined( __parallel )
361	IF ( sm_io%iam_io_pe ) THEN
362
363	IF ( rd_flag ) THEN
364
365	IF ( debug_output ) THEN
366	WRITE( debug_string, * ) 'open joint restart file "' // TRIM( io_file_name ) // &
367	'" for read with MPI-IO'
368	CALL debug_message( debug_string, 'start' )
369	ENDIF
370
371	CALL MPI_FILE_OPEN( comm_io, TRIM( io_file_name ), MPI_MODE_RDONLY, MPI_INFO_NULL, fh, &
372	ierr )
373
374	IF ( ierr /= 0 ) THEN
375	message_string = 'error opening restart file "' // TRIM( io_file_name ) // &
376	'" for reading with MPI-IO'
377	CALL message( 'rrd_mpi_io_open', 'PA0727', 3, 2, 0, 6, 0 )
378	ENDIF
379
380	IF ( debug_output ) THEN
381	WRITE( debug_string, * ) 'open joint restart file "' // TRIM( io_file_name ) // &
382	'" for read with MPI-IO'
383	CALL debug_message( debug_string, 'end' )
384	ENDIF
385
386	ELSEIF ( wr_flag ) THEN
387
388	IF ( debug_output ) THEN
389	WRITE( debug_string, * ) 'open joint restart file "' // TRIM( io_file_name ) // &
390	'" for write with MPI-IO'
391	CALL debug_message( debug_string, 'start' )
392	ENDIF
393
394	CALL MPI_FILE_OPEN( comm_io, TRIM( io_file_name ), MPI_MODE_CREATE+MPI_MODE_WRONLY, &
395	MPI_INFO_NULL, fh, ierr )
396
397	IF ( ierr /= 0 ) THEN
398	message_string = 'error opening restart file "' // TRIM( io_file_name ) // &
399	'" for writing with MPI-IO'
400	CALL message( 'rrd_mpi_io_open', 'PA0728', 3, 2, 0, 6, 0 )
401	ENDIF
402
403	IF ( debug_output ) THEN
404	WRITE( debug_string, * ) 'open joint restart file "' // TRIM( io_file_name ) // &
405	'" for write with MPI-IO'
406	CALL debug_message( debug_string, 'end' )
407	ENDIF
408
409	ENDIF
410
411	ENDIF
412	#else
413	IF ( rd_flag ) THEN
414
415	IF ( debug_output ) THEN
416	WRITE( debug_string, * ) 'open restart file "' // TRIM( io_file_name ) // &
417	'" for read in serial mode (posix)'
418	CALL debug_message( debug_string, 'start' )
419	ENDIF
420
421	fh = posix_open( TRIM( io_file_name ), .TRUE. )
422
423	IF ( debug_output ) THEN
424	WRITE( debug_string, * ) 'open restart file "' // TRIM( io_file_name ) // &
425	'" for read in serial mode (posix)'
426	CALL debug_message( debug_string, 'end' )
427	ENDIF
428
429	ELSEIF ( wr_flag ) THEN
430
431	IF ( debug_output ) THEN
432	WRITE( debug_string, * ) 'open restart file "' // TRIM( io_file_name ) // &
433	'" for write in serial mode (posix)'
434	CALL debug_message( debug_string, 'start' )
435	ENDIF
436
437	fh = posix_open( TRIM( io_file_name ), .FALSE. )
438
439	IF ( debug_output ) THEN
440	WRITE( debug_string, * ) 'open restart file "' // TRIM( io_file_name ) // &
441	'" for write in serial mode (posix)'
442	CALL debug_message( debug_string, 'end' )
443	ENDIF
444
445	ENDIF
446
447	IF ( fh < 0 ) THEN
448	message_string = 'error opening restart file for posix I/O'
449	CALL message( 'restart_data_mpi_io_mod', 'PA0721', 1, 2, 0, 6, 0 )
450	ENDIF
451	#endif
452
453	array_position = 65536 !> Start offset for writing 2-D and 3.D arrays at 64 k
454	header_position = 0
455
456	header_int_index = 1
457	header_char_index = 1
458	header_real_index = 1
459	header_arr_index = 1
460
461	int_names = ' '
462	int_values = 0
463	text_lines = ' '
464	real_names = ' '
465	real_values = 0.0
466	array_names = ' '
467	array_offset = 0
468
469	int_names(1) = 'nx'
470	int_values(1) = nx
471	int_names(2) = 'ny'
472	int_values(2) = ny
473	int_names(3) = 'nz'
474	int_values(3) = nz
475	header_int_index = header_int_index+3
476
477	DO i = 1, max_nr_arrays
478	array_offset(i) = 0
479	array_names(i) = ' '
480	ENDDO
481
482	gh_size = STORAGE_SIZE( tgh ) / 8
483
484	IF ( rd_flag ) THEN
485	IF ( sm_io%iam_io_pe ) THEN
486	!
487	!-- File is open for read.
488	#if defined( __parallel )
489	!-- Set the default view
490	CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
491	!
492	!-- Read the file header size
493	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
494	CALL MPI_FILE_READ( fh, tgh, gh_size, MPI_BYTE, status, ierr )
495	#else
496	CALL posix_lseek( fh, header_position )
497	buf_ptr = C_LOC( tgh )
498	CALL posix_read( fh, buf_ptr, gh_size )
499	#endif
500	ENDIF
501	#if defined( __parallel )
502	IF ( sm_io%is_sm_active() ) THEN
503	CALL MPI_BCAST( tgh, gh_size, MPI_BYTE, 0, sm_io%comm_shared, ierr )
504	ENDIF
505	#endif
506	header_position = header_position + gh_size
507
508	include_total_domain_boundaries = ( tgh%i_outer_bound == 1 )
509
510	!
511	!-- File types depend on if boundaries of the total domain is included in data. This has been
512	!-- checked with the previous statement.
513	IF ( set_filetype ) THEN
514	CALL rd_mpi_io_create_filetypes
515	filetypes_created = .TRUE.
516	ENDIF
517
518	IF ( sm_io%iam_io_pe ) THEN
519	#if defined( __parallel )
520	!
521	!-- Read INTEGER values
522	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
523	CALL MPI_FILE_READ( fh, int_names, SIZE( int_names ) * 32, MPI_CHAR, status, ierr )
524	header_position = header_position + SIZE( int_names ) * 32
525
526	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
527	CALL MPI_FILE_READ (fh, int_values, SIZE( int_values ), MPI_INT, status, ierr )
528	header_position = header_position + SIZE( int_values ) * iwp
529	!
530	!-- Character entries
531	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
532	CALL MPI_FILE_READ( fh, text_lines, SIZE( text_lines ) * 128, MPI_CHAR, status, ierr )
533	header_position = header_position+size(text_lines) * 128
534	!
535	!-- REAL values
536	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
537	CALL MPI_FILE_READ( fh, real_names, SIZE( real_names ) * 32, MPI_CHAR, status, ierr )
538	header_position = header_position + SIZE( real_names ) * 32
539
540	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
541	CALL MPI_FILE_READ( fh, real_values, SIZE( real_values ), MPI_REAL, status, ierr )
542	header_position = header_position + SIZE( real_values ) * wp
543	!
544	!-- 2d- and 3d-array headers
545	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
546	CALL MPI_FILE_READ( fh, array_names, SIZE( array_names ) * 32, MPI_CHAR, status, ierr )
547	header_position = header_position + SIZE( array_names ) * 32
548
549	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
550	CALL MPI_FILE_READ( fh, array_offset, SIZE( array_offset ) * MPI_OFFSET_KIND, MPI_BYTE, &
551	status,ierr ) ! there is no I*8 datatype in Fortran
552	header_position = header_position + SIZE( array_offset ) * rd_offset_kind
553	#else
554	CALL posix_lseek( fh, header_position )
555	CALL posix_read( fh, int_names )
556	header_position = header_position + SIZE( int_names ) * 32
557
558	CALL posix_lseek( fh, header_position )
559	CALL posix_read( fh, int_values, SIZE( int_values ) )
560	header_position = header_position + SIZE( int_values ) * iwp
561	!
562	!-- Character entries
563	CALL posix_lseek( fh, header_position )
564	CALL posix_read( fh, text_lines )
565	header_position = header_position + SIZE( text_lines ) * 128
566	!
567	!-- REAL values
568	CALL posix_lseek( fh, header_position )
569	CALL posix_read( fh, real_names )
570	header_position = header_position + SIZE( real_names ) * 32
571
572	CALL posix_lseek( fh, header_position )
573	CALL posix_read( fh, real_values, SIZE( real_values ) )
574	header_position = header_position + SIZE( real_values ) * wp
575	!
576	!-- 2d- and 3d-array headers
577	CALL posix_lseek( fh, header_position )
578	CALL posix_read( fh, array_names )
579	header_position = header_position + SIZE( array_names ) * 32
580
581	CALL posix_lseek( fh, header_position )
582	CALL posix_read( fh, array_offset, SIZE( array_offset ) ) ! there is no I*8 datatype in Fortran
583	header_position = header_position + SIZE( array_offset ) * rd_offset_kind
584	#endif
585	IF ( debug_output ) CALL rd_mpi_io_print_header
586
587	ENDIF
588
589	#if defined( __parallel )
590	!
591	!-- Broadcast header to all remaining cores that are not involved in I/O
592	IF ( sm_io%is_sm_active() ) THEN
593	!
594	!-- Not sure, that it is possible to broadcast CHARACTER array in one MPI_Bcast call
595	DO i = 1, SIZE( int_names )
596	CALL MPI_BCAST( int_names(i), 32, MPI_CHARACTER, 0, sm_io%comm_shared, ierr )
597	ENDDO
598	CALL MPI_BCAST( int_values, SIZE( int_values ), MPI_INTEGER, 0, sm_io%comm_shared, ierr )
599
600	DO i = 1, SIZE( text_lines )
601	CALL MPI_BCAST( text_lines(i), 128, MPI_CHARACTER, 0, sm_io%comm_shared, ierr )
602	ENDDO
603
604	DO i = 1, SIZE( real_names )
605	CALL MPI_BCAST( real_names(i), 32, MPI_CHARACTER, 0, sm_io%comm_shared, ierr )
606	ENDDO
607	CALL MPI_BCAST( real_values, SIZE( real_values ), MPI_REAL, 0, sm_io%comm_shared, ierr )
608
609	DO i = 1, SIZE( array_names )
610	CALL MPI_BCAST( array_names(i), 32, MPI_CHARACTER, 0, sm_io%comm_shared, ierr )
611	ENDDO
612	CALL MPI_BCAST( array_offset, SIZE( array_offset )*8, MPI_BYTE, 0, sm_io%comm_shared, &
613	ierr ) ! there is no I8 datatype in Fortran (array_offset is I8!)
614
615	CALL MPI_BCAST( header_position, rd_offset_kind, MPI_BYTE, 0, sm_io%comm_shared, ierr )
616
617	ENDIF
618	#endif
619
620	ENDIF
621
622	END SUBROUTINE rd_mpi_io_open
623
624
625	!--------------------------------------------------------------------------------------------------!
626	! Description:
627	! ------------
628	!> Check, if array exists in restart file
629	!--------------------------------------------------------------------------------------------------!
630	SUBROUTINE rd_mpi_io_check_array( name, found )
631
632	IMPLICIT NONE
633
634	CHARACTER(LEN=*), INTENT(IN) :: name !<
635
636	INTEGER(iwp) :: i !<
637
638	LOGICAl :: found !<
639
640
641	DO i = 1, tgh%nr_arrays
642	IF ( TRIM( array_names(i) ) == TRIM( name ) ) THEN
643	array_position = array_offset(i)
644	found = .TRUE.
645	RETURN
646	ENDIF
647	ENDDO
648
649	found = .FALSE.
650
651	END SUBROUTINE rd_mpi_io_check_array
652
653
654
655	!--------------------------------------------------------------------------------------------------!
656	! Description:
657	! ------------
658	!> Read INTEGER with MPI-IO
659	!--------------------------------------------------------------------------------------------------!
660	SUBROUTINE rrd_mpi_io_int( name, value )
661
662	IMPLICIT NONE
663
664	CHARACTER(LEN=*), INTENT(IN) :: name
665
666	INTEGER(iwp) :: i
667	INTEGER(KIND=iwp), INTENT(OUT) :: value
668
669	LOGICAL :: found
670
671
672	found = .FALSE.
673	value = 0
674
675	DO i = 1, tgh%nr_int
676	IF ( TRIM(int_names(i)) == TRIM( name ) ) THEN
677	value = int_values(i)
678	found = .TRUE.
679	EXIT
680	ENDIF
681	ENDDO
682
683	IF ( .NOT. found ) THEN
684	message_string = 'INTEGER variable "' // TRIM( name ) // '" not found in restart file'
685	CALL message( 'rrd_mpi_io_int', 'PA0722', 3, 2, 0, 6, 0 )
686	ENDIF
687
688	END SUBROUTINE rrd_mpi_io_int
689
690
691
692	!--------------------------------------------------------------------------------------------------!
693	! Description:
694	! ------------
695	!> Read REAL with MPI-IO
696	!--------------------------------------------------------------------------------------------------!
697	SUBROUTINE rrd_mpi_io_real( name, value )
698
699	IMPLICIT NONE
700
701	CHARACTER(LEN=*), INTENT(IN) :: name
702
703	INTEGER(iwp) :: i
704
705	LOGICAL :: found
706
707	REAL(KIND=wp), INTENT(OUT) :: value
708
709
710	found = .FALSE.
711	value = 0.0
712
713	DO i = 1, tgh%nr_real
714	IF ( TRIM(real_names(i)) == TRIM( name ) ) THEN
715	value = real_values(i)
716	found = .TRUE.
717	EXIT
718	ENDIF
719	ENDDO
720
721	IF ( .NOT. found ) THEN
722	message_string = 'REAL variable "' // TRIM( name ) // '" not found in restart file'
723	CALL message( 'rrd_mpi_io_int', 'PA0722', 3, 2, 0, 6, 0 )
724	ENDIF
725
726	END SUBROUTINE rrd_mpi_io_real
727
728
729
730	!--------------------------------------------------------------------------------------------------!
731	! Description:
732	! ------------
733	!> Read 2d-real array with MPI-IO
734	!--------------------------------------------------------------------------------------------------!
735	SUBROUTINE rrd_mpi_io_real_2d( name, data )
736
737	IMPLICIT NONE
738
739	CHARACTER(LEN=*), INTENT(IN) :: name
740
741	#if defined( __parallel )
742	INTEGER, DIMENSION(rd_status_size) :: status
743	#endif
744	INTEGER(iwp) :: i
745
746	LOGICAL :: found
747
748	REAL(wp), INTENT(INOUT), DIMENSION(nysg:nyng,nxlg:nxrg) :: data
749
750
751	found = .FALSE.
752
753	DO i = 1, tgh%nr_arrays
754	IF ( TRIM(array_names(i)) == TRIM( name ) ) THEN
755	array_position = array_offset(i)
756	found = .TRUE.
757	EXIT
758	ENDIF
759	ENDDO
760
761	IF ( found ) THEN
762	#if defined( __parallel )
763	CALL sm_io%sm_node_barrier() ! has no effect if I/O on limited number of cores is inactive
764	IF ( sm_io%iam_io_pe ) THEN
765	CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_2d, 'native', MPI_INFO_NULL, &
766	ierr )
767	CALL MPI_FILE_READ_ALL( fh, array_2d, SIZE( array_2d ), MPI_REAL, status, ierr )
768	ENDIF
769	CALL sm_io%sm_node_barrier()
770	#else
771	CALL posix_lseek( fh, array_position )
772	CALL posix_read( fh, array_2d, SIZE( array_2d ) )
773	#endif
774
775	IF ( include_total_domain_boundaries) THEN
776	DO i = lb%nxl, lb%nxr
777	data(lb%nys-nbgp:lb%nyn-nbgp,i-nbgp) = array_2d(i,lb%nys:lb%nyn)
778	ENDDO
779	IF ( debug_level >= 2) WRITE(9,*) 'r2f_ob ', TRIM(name),' ', SUM( data(nys:nyn,nxl:nxr) )
780	ELSE
781	DO i = nxl, nxr
782	data(nys:nyn,i) = array_2d(i,nys:nyn)
783	ENDDO
784	IF ( debug_level >= 2) WRITE(9,*) 'r2f ', TRIM( name ),' ', SUM( data(nys:nyn,nxl:nxr) )
785	ENDIF
786
787	CALL exchange_horiz_2d( data )
788
789	ELSE
790	message_string = '2d-REAL array "' // TRIM( name ) // '" not found in restart file'
791	CALL message( 'rrd_mpi_io_int', 'PA0722', 3, 2, 0, 6, 0 )
792	ENDIF
793
794	END SUBROUTINE rrd_mpi_io_real_2d
795
796
797
798	!--------------------------------------------------------------------------------------------------!
799	! Description:
800	! ------------
801	!> Read 2d-INTEGER array with MPI-IO
802	!--------------------------------------------------------------------------------------------------!
803	SUBROUTINE rrd_mpi_io_int_2d( name, data )
804
805	IMPLICIT NONE
806
807	CHARACTER(LEN=*), INTENT(IN) :: name
808
809	INTEGER(iwp) :: i
810	INTEGER(iwp) :: j
811
812	#if defined( __parallel )
813	INTEGER, DIMENSION(rd_status_size) :: status
814	#endif
815
816	INTEGER(KIND=iwp), INTENT(INOUT), DIMENSION(:,:) :: data
817
818	LOGICAL :: found
819
820
821	found = .FALSE.
822
823	DO i = 1, tgh%nr_arrays
824	IF ( TRIM(array_names(i)) == TRIM( name ) ) THEN
825	array_position = array_offset(i)
826	found = .TRUE.
827	EXIT
828	ENDIF
829	ENDDO
830
831	IF ( found ) THEN
832
833	IF ( ( nxr - nxl + 1 + 2*nbgp ) == SIZE( data, 2 ) ) THEN
834	!
835	!-- Output array with Halos.
836	!-- ATTENTION: INTEGER array with ghost boundaries are not implemented yet. This kind of array
837	!-- would be dimensioned in the caller subroutine like this:
838	!-- INTEGER, DIMENSION(nysg:nyng,nxlg:nxrg):: data
839	message_string = '2d-INTEGER array "' // TRIM( name ) // '" to be read from restart ' // &
840	'file is defined with illegal dimensions in the PALM code'
841	CALL message( 'rrd_mpi_io_int_2d', 'PA0723', 3, 2, 0, 6, 0 )
842
843	ELSEIF ( (nxr-nxl+1) == SIZE( data, 2 ) ) THEN
844	!
845	!-- INTEGER input array without Halos.
846	!-- This kind of array is dimensioned in the caller subroutine
847	!-- INTEGER, DIMENSION(nys:nyn,nxl:nxr) :: data
848
849	#if defined( __parallel )
850	CALL sm_io%sm_node_barrier() ! has no effect if I/O on limited number of cores is inactive
851	IF ( sm_io%iam_io_pe ) THEN
852	CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_INTEGER, ft_2di_nb, 'native', &
853	MPI_INFO_NULL, ierr )
854	CALL MPI_FILE_READ_ALL( fh, array_2d, SIZE( array_2d ), MPI_INTEGER, status, ierr )
855	ENDIF
856	CALL sm_io%sm_node_barrier()
857	#else
858	CALL posix_lseek( fh, array_position )
859	CALL posix_read( fh, array_2di, SIZE( array_2di ) )
860	#endif
861
862	DO j = nys, nyn
863	DO i = nxl, nxr
864	data(j-nys+1,i-nxl+1) = array_2di(i,j)
865	ENDDO
866	ENDDO
867
868	ELSE
869
870	message_string = '2d-INTEGER array "' // TRIM( name ) // '" to be read from restart ' // &
871	'file is defined with illegal dimensions in the PALM code'
872	CALL message( 'rrd_mpi_io_int_2d', 'PA0723', 3, 2, 0, 6, 0 )
873
874	ENDIF
875
876	ELSE
877
878	message_string = '2d-INTEGER array "' // TRIM( name ) // '" not found in restart file'
879	CALL message( 'rrd_mpi_io_int_2d', 'PA0722', 3, 2, 0, 6, 0 )
880
881	ENDIF
882
883	END SUBROUTINE rrd_mpi_io_int_2d
884
885
886
887	!--------------------------------------------------------------------------------------------------!
888	! Description:
889	! ------------
890	!> Read 2d-REAL array with MPI-IO
891	!--------------------------------------------------------------------------------------------------!
892	SUBROUTINE rrd_mpi_io_real_3d( name, data )
893
894	IMPLICIT NONE
895
896	CHARACTER(LEN=*), INTENT(IN) :: name
897
898	INTEGER(iwp) :: i
899
900	#if defined( __parallel )
901	INTEGER, DIMENSION(rd_status_size) :: status
902	#endif
903
904	LOGICAL :: found
905
906	REAL(wp), INTENT(INOUT), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: data
907
908
909	found = .FALSE.
910
911	DO i = 1, tgh%nr_arrays
912	IF ( TRIM(array_names(i)) == TRIM( name ) ) THEN
913	array_position = array_offset(i)
914	found = .TRUE.
915	EXIT
916	ENDIF
917	ENDDO
918
919	IF ( found ) THEN
920	#if defined( __parallel )
921	CALL sm_io%sm_node_barrier() ! has no effect if I/O on limited number of cores is inactive
922	IF( sm_io%iam_io_pe ) THEN
923	CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3d, 'native', MPI_INFO_NULL, &
924	ierr )
925	CALL MPI_FILE_READ_ALL( fh, array_3d, SIZE( array_3d ), MPI_REAL, status, ierr )
926	ENDIF
927	CALL sm_io%sm_node_barrier()
928	#else
929	CALL posix_lseek( fh, array_position )
930	CALL posix_read(fh, array_3d, SIZE( array_3d ) )
931	#endif
932	IF ( include_total_domain_boundaries) THEN
933	DO i = lb%nxl, lb%nxr
934	data(:,lb%nys-nbgp:lb%nyn-nbgp,i-nbgp) = array_3d(:,i,lb%nys:lb%nyn)
935	ENDDO
936	ELSE
937	DO i = nxl, nxr
938	data(:,nys:nyn,i) = array_3d(:,i,nys:nyn)
939	ENDDO
940	ENDIF
941
942	CALL exchange_horiz( data, nbgp )
943
944	ELSE
945
946	message_string = '3d-REAL array "' // TRIM( name ) // '" not found in restart file'
947	CALL message( 'rrd_mpi_io_real_3d', 'PA0722', 3, 2, 0, 6, 0 )
948
949	ENDIF
950
951	END SUBROUTINE rrd_mpi_io_real_3d
952
953
954
955	!--------------------------------------------------------------------------------------------------!
956	! Description:
957	! ------------
958	!> Read 3d-REAL soil array with MPI-IO
959	!> nzb_soil, nzt_soil are located in the module land_surface_model_mod. Since Fortran does not allow
960	!> cross referencing of module variables, it is required to pass these variables as arguments.
961	!--------------------------------------------------------------------------------------------------!
962	SUBROUTINE rrd_mpi_io_real_3d_soil( name, data, nzb_soil, nzt_soil )
963
964	IMPLICIT NONE
965
966	CHARACTER(LEN=*), INTENT(IN) :: name
967
968	INTEGER(iwp) :: i
969	INTEGER, INTENT(IN) :: nzb_soil
970	INTEGER, INTENT(IN) :: nzt_soil
971
972	#if defined( __parallel )
973	INTEGER, DIMENSION(rd_status_size) :: status
974	#endif
975
976	LOGICAL :: found
977
978	REAL(wp), INTENT(INOUT), DIMENSION(nzb_soil:nzt_soil,nysg:nyng,nxlg:nxrg) :: data
979
980
981	found = .FALSE.
982
983	DO i = 1, tgh%nr_arrays
984	IF ( TRIM(array_names(i)) == TRIM( name ) ) THEN
985	array_position = array_offset(i)
986	found = .TRUE.
987	EXIT
988	ENDIF
989	ENDDO
990
991	IF ( found ) THEN
992	#if defined( __parallel )
993	CALL rd_mpi_io_create_filetypes_3dsoil( nzb_soil, nzt_soil )
994	CALL sm_io%sm_node_barrier() ! has no effect if I/O on limited number of cores is inactive
995	IF ( sm_io%iam_io_pe ) THEN
996	CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3dsoil, 'native', MPI_INFO_NULL,&
997	ierr )
998	CALL MPI_FILE_READ_ALL( fh, array_3d_soil, SIZE( array_3d_soil ), MPI_REAL, status, ierr )
999	CALL MPI_TYPE_FREE( ft_3dsoil, ierr )
1000	ENDIF
1001	CALL sm_io%sm_node_barrier()
1002	#else
1003	CALL posix_lseek( fh, array_position )
1004	CALL posix_read( fh, array_3d_soil, SIZE( array_3d_soil ) )
1005	#endif
1006	IF ( include_total_domain_boundaries ) THEN
1007	DO i = lb%nxl, lb%nxr
1008	data(:,lb%nys-nbgp:lb%nyn-nbgp,i-nbgp) = array_3d(:,i,lb%nys:lb%nyn)
1009	ENDDO
1010	ELSE
1011	DO i = nxl, nxr
1012	data(:,nys:nyn,i) = array_3d(:,i,nys:nyn)
1013	ENDDO
1014	ENDIF
1015
1016	ELSE
1017
1018	message_string = '3d-REAL soil array "' // TRIM( name ) // '" not found in restart file'
1019	CALL message( 'rrd_mpi_io_real_3d_soil', 'PA0722', 3, 2, 0, 6, 0 )
1020
1021	ENDIF
1022
1023	END SUBROUTINE rrd_mpi_io_real_3d_soil
1024
1025
1026
1027	!--------------------------------------------------------------------------------------------------!
1028	! Description:
1029	! ------------
1030	!> Read CHARACTER with MPI-IO
1031	!--------------------------------------------------------------------------------------------------!
1032	SUBROUTINE rrd_mpi_io_char( name, text )
1033
1034	IMPLICIT NONE
1035
1036	CHARACTER(LEN=*), INTENT(IN) :: name
1037	CHARACTER(LEN=*), INTENT(OUT) :: text
1038	CHARACTER(LEN=128) :: line
1039
1040	INTEGER(iwp) :: i
1041
1042	LOGICAL :: found
1043
1044
1045	found = .FALSE.
1046	text = ' '
1047
1048	DO i = 1, tgh%nr_char
1049	line = text_lines(i)
1050	IF ( TRIM( line(1:32) ) == TRIM( name ) ) THEN
1051	text = line(33:)
1052	found = .TRUE.
1053	EXIT
1054	ENDIF
1055	ENDDO
1056
1057	IF ( .NOT. found ) THEN
1058	message_string = 'CHARACTER variable "' // TRIM( name ) // '" not found in restart file'
1059	CALL message( 'rrd_mpi_io_char', 'PA0722', 3, 2, 0, 6, 0 )
1060	ENDIF
1061
1062	END SUBROUTINE rrd_mpi_io_char
1063
1064
1065
1066	!--------------------------------------------------------------------------------------------------!
1067	! Description:
1068	! ------------
1069	!> Read LOGICAL with MPI-IO
1070	!--------------------------------------------------------------------------------------------------!
1071	SUBROUTINE rrd_mpi_io_logical( name, value )
1072
1073	IMPLICIT NONE
1074
1075	CHARACTER(LEN=*), INTENT(IN) :: name
1076
1077	INTEGER(iwp) :: logical_as_integer
1078
1079	LOGICAL, INTENT(OUT) :: value
1080
1081
1082	CALL rrd_mpi_io_int( name, logical_as_integer )
1083	value = ( logical_as_integer == 1 )
1084
1085	END SUBROUTINE rrd_mpi_io_logical
1086
1087
1088
1089	!--------------------------------------------------------------------------------------------------!
1090	! Description:
1091	! ------------
1092	!> Write INTEGER with MPI-IO
1093	!--------------------------------------------------------------------------------------------------!
1094	SUBROUTINE wrd_mpi_io_int( name, value )
1095
1096	IMPLICIT NONE
1097
1098	CHARACTER(LEN=*), INTENT(IN) :: name
1099
1100	INTEGER(KIND=iwp), INTENT(IN) :: value
1101
1102
1103	int_names(header_int_index) = name
1104	int_values(header_int_index) = value
1105	header_int_index = header_int_index + 1
1106
1107	END SUBROUTINE wrd_mpi_io_int
1108
1109
1110
1111	SUBROUTINE wrd_mpi_io_real( name, value )
1112
1113	IMPLICIT NONE
1114
1115	CHARACTER(LEN=*), INTENT(IN) :: name
1116
1117	REAL(wp), INTENT(IN) :: value
1118
1119
1120	real_names(header_real_index) = name
1121	real_values(header_real_index) = value
1122	header_real_index = header_real_index + 1
1123
1124	END SUBROUTINE wrd_mpi_io_real
1125
1126
1127
1128	!--------------------------------------------------------------------------------------------------!
1129	! Description:
1130	! ------------
1131	!> Write 2d-REAL array with MPI-IO
1132	!--------------------------------------------------------------------------------------------------!
1133	SUBROUTINE wrd_mpi_io_real_2d( name, data )
1134
1135	IMPLICIT NONE
1136
1137	CHARACTER(LEN=*), INTENT(IN) :: name
1138
1139	INTEGER(iwp) :: i
1140
1141	#if defined( __parallel )
1142	INTEGER, DIMENSION(rd_status_size) :: status
1143	#endif
1144
1145	REAL(wp), INTENT(IN), DIMENSION(nysg:nyng,nxlg:nxrg) :: data
1146
1147
1148	array_names(header_arr_index) = name
1149	array_offset(header_arr_index) = array_position
1150	header_arr_index = header_arr_index + 1
1151
1152	IF ( include_total_domain_boundaries ) THEN
1153	!
1154	!-- Prepare Output with outer boundaries
1155	DO i = lb%nxl, lb%nxr
1156	array_2d(i,lb%nys:lb%nyn) = data(lb%nys-nbgp:lb%nyn-nbgp,i-nbgp)
1157	ENDDO
1158
1159	ELSE
1160	!
1161	!-- Prepare Output without outer boundaries
1162	DO i = nxl,nxr
1163	array_2d(i,lb%nys:lb%nyn) = data(nys:nyn,i)
1164	ENDDO
1165
1166	ENDIF
1167
1168	#if defined( __parallel )
1169	CALL sm_io%sm_node_barrier() ! has no effect if I/O on limited number of cores is inactive
1170	IF ( sm_io%iam_io_pe ) THEN
1171	CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_2d, 'native', MPI_INFO_NULL, ierr )
1172	CALL MPI_FILE_WRITE_ALL( fh, array_2d, SIZE( array_2d), MPI_REAL, status, ierr )
1173	ENDIF
1174	CALL sm_io%sm_node_barrier()
1175	#else
1176	CALL posix_lseek( fh, array_position )
1177	CALL posix_write( fh, array_2d, SIZE( array_2d ) )
1178	#endif
1179	!
1180	!-- Type conversion required, otherwise rigth hand side brackets are calculated assuming 4 byte INT.
1181	!-- Maybe a compiler problem.
1182	array_position = array_position + ( INT( lb%ny, KIND=rd_offset_kind ) + 1 ) * &
1183	( INT( lb%nx, KIND=rd_offset_kind ) + 1 ) * wp
1184
1185	END SUBROUTINE wrd_mpi_io_real_2d
1186
1187
1188
1189	!--------------------------------------------------------------------------------------------------!
1190	! Description:
1191	! ------------
1192	!> Write 2d-INTEGER array with MPI-IO
1193	!--------------------------------------------------------------------------------------------------!
1194	SUBROUTINE wrd_mpi_io_int_2d( name, data )
1195
1196	IMPLICIT NONE
1197
1198	CHARACTER(LEN=*), INTENT(IN) :: name
1199
1200	INTEGER(iwp) :: i
1201	INTEGER(iwp) :: j
1202
1203	#if defined( __parallel )
1204	INTEGER, DIMENSION(rd_status_size) :: status
1205	#endif
1206	INTEGER(KIND=iwp), INTENT(IN), DIMENSION(:,:) :: data
1207
1208
1209	array_names(header_arr_index) = name
1210	array_offset(header_arr_index) = array_position
1211	header_arr_index = header_arr_index + 1
1212
1213	IF ( ( nxr-nxl + 1 + 2 * nbgp ) == SIZE( data, 2 ) ) THEN
1214	!
1215	!-- Integer arrays with ghost layers are not implemented yet. These kind of arrays would be
1216	!-- dimensioned in the caller subroutine as
1217	!-- INTEGER, DIMENSION(nysg:nyng,nxlg:nxrg) :: data
1218	message_string = '2d-INTEGER array "' // TRIM( name ) // '" to be written to restart ' // &
1219	'file is defined with illegal dimensions in the PALM code'
1220	CALL message( 'wrd_mpi_io_int_2d', 'PA0723', 3, 2, 0, 6, 0 )
1221
1222	ELSEIF ( ( nxr-nxl+1 ) == SIZE( data, 2 ) ) THEN
1223	!
1224	!-- INTEGER input array without ghost layers.
1225	!-- This kind of array is dimensioned in the caller subroutine as
1226	!-- INTEGER, DIMENSION(nys:nyn,nxl:nxr) :: data
1227	DO j = nys, nyn
1228	DO i = nxl, nxr
1229	array_2di(i,j) = data(j-nys+1,i-nxl+1)
1230	ENDDO
1231	ENDDO
1232	#if defined( __parallel )
1233	CALL sm_io%sm_node_barrier() ! has no effect if I/O on limited number of cores is inactive
1234	IF ( sm_io%iam_io_pe ) THEN
1235	CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_INTEGER, ft_2di_nb, 'native', &
1236	MPI_INFO_NULL, ierr )
1237	CALL MPI_FILE_WRITE_ALL( fh, array_2di, SIZE( array_2di ), MPI_INTEGER, status, ierr )
1238	ENDIF
1239	CALL sm_io%sm_node_barrier()
1240	#else
1241	CALL posix_lseek( fh, array_position )
1242	CALL posix_write( fh, array_2di, SIZE( array_2di ) )
1243	#endif
1244	!
1245	!-- Type conversion required, otherwise rigth hand side brackets are calculated assuming 4 byte
1246	!-- INT. Maybe a compiler problem.
1247	array_position = array_position + INT( (ny+1), KIND=rd_offset_kind ) * &
1248	INT( (nx+1), KIND=rd_offset_kind ) * 4
1249
1250	ELSE
1251
1252	message_string = '2d-INTEGER array "' // TRIM( name ) // '" to be written to restart ' // &
1253	'file is defined with illegal dimensions in the PALM code'
1254	CALL message( 'wrd_mpi_io_int_2d', 'PA0723', 3, 2, 0, 6, 0 )
1255
1256	ENDIF
1257
1258	END SUBROUTINE wrd_mpi_io_int_2d
1259
1260
1261
1262	!--------------------------------------------------------------------------------------------------!
1263	! Description:
1264	! ------------
1265	!> Write 3d-REAL array with MPI-IO
1266	!--------------------------------------------------------------------------------------------------!
1267	SUBROUTINE wrd_mpi_io_real_3d( name, data )
1268
1269	IMPLICIT NONE
1270
1271	CHARACTER(LEN=*), INTENT(IN) :: name
1272
1273	INTEGER(iwp) :: i
1274	#if defined( __parallel )
1275	INTEGER, DIMENSION(rd_status_size) :: status
1276	#endif
1277	REAL(wp), INTENT(IN), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: data
1278
1279
1280	array_names(header_arr_index) = name
1281	array_offset(header_arr_index) = array_position
1282	header_arr_index = header_arr_index + 1
1283
1284	IF ( include_total_domain_boundaries ) THEN
1285	!
1286	!-- Prepare output of 3d-REAL-array with ghost layers.
1287	!-- In the virtual PE grid, the first dimension is PEs along x, and the second along y.
1288	!-- For MPI-IO it is recommended to have the index order of the array in the same way, i.e.
1289	!-- the first dimension should be along x and the second along y.
1290	!-- For this reason, the original PALM data need to be swaped.
1291	DO i = lb%nxl, lb%nxr
1292	array_3d(:,i,lb%nys:lb%nyn) = data(:,lb%nys-nbgp:lb%nyn-nbgp,i-nbgp)
1293	ENDDO
1294
1295	ELSE
1296	!
1297	!-- Prepare output of 3d-REAL-array without ghost layers
1298	DO i = nxl, nxr
1299	array_3d(:,i,lb%nys:lb%nyn) = data(:,nys:nyn,i)
1300	ENDDO
1301
1302	ENDIF
1303	#if defined( __parallel )
1304	CALL sm_io%sm_node_barrier() ! has no effect if I/O on limited number of cores is inactive
1305	IF ( sm_io%iam_io_pe ) THEN
1306	CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3d, 'native', MPI_INFO_NULL, ierr )
1307	CALL MPI_FILE_WRITE_ALL( fh, array_3d, SIZE( array_3d ), MPI_REAL, status, ierr )
1308	ENDIF
1309	CALL sm_io%sm_node_barrier()
1310	#else
1311	CALL posix_lseek( fh, array_position )
1312	CALL posix_write( fh, array_3d, SIZE( array_3d ) )
1313	#endif
1314	!
1315	!-- Type conversion required, otherwise rigth hand side brackets are calculated assuming 4 byte INT.
1316	!-- Maybe a compiler problem.
1317	array_position = array_position + INT( (nz+2), KIND=rd_offset_kind ) * &
1318	INT( (lb%ny+1), KIND=rd_offset_kind ) * &
1319	INT( (lb%nx+1), KIND=rd_offset_kind ) * wp
1320
1321	END SUBROUTINE wrd_mpi_io_real_3d
1322
1323
1324
1325	!--------------------------------------------------------------------------------------------------!
1326	! Description:
1327	! ------------
1328	!> Write 3d-REAL soil array with MPI-IO.
1329	!> nzb_soil, nzt_soil are located in the module land_surface_model_mod. Since Fortran does not allow
1330	!> cross referencing of module variables, it is required to pass these variables as arguments.
1331	!--------------------------------------------------------------------------------------------------!
1332	SUBROUTINE wrd_mpi_io_real_3d_soil( name, data, nzb_soil, nzt_soil )
1333
1334	IMPLICIT NONE
1335
1336	CHARACTER(LEN=*), INTENT(IN) :: name
1337
1338	INTEGER(iwp) :: i
1339	INTEGER, INTENT(IN) :: nzb_soil
1340	INTEGER, INTENT(IN) :: nzt_soil
1341
1342	#if defined( __parallel )
1343	INTEGER, DIMENSION(rd_status_size) :: status
1344	#endif
1345
1346	REAL(wp), INTENT(IN), DIMENSION(nzb_soil:nzt_soil,nysg:nyng,nxlg:nxrg) :: data
1347
1348
1349	array_names(header_arr_index) = name
1350	array_offset(header_arr_index) = array_position
1351	header_arr_index = header_arr_index + 1
1352
1353	#if defined( __parallel )
1354	CALL rd_mpi_io_create_filetypes_3dsoil( nzb_soil, nzt_soil )
1355	#endif
1356
1357	IF ( include_total_domain_boundaries) THEN
1358	!
1359	!-- Prepare output of 3d-REAL-array with ghost layers.
1360	!-- In the virtual PE grid, the first dimension is PEs along x, and the second along y.
1361	!-- For MPI-IO it is recommended to have the index order of the array in the same way, i.e.
1362	!-- the first dimension should be along x and the second along y.
1363	!-- For this reason, the original PALM data need to be swaped.
1364	DO i = lb%nxl, lb%nxr
1365	array_3d_soil(:,i,lb%nys:lb%nyn) = data(:,lb%nys-nbgp:lb%nyn-nbgp,i-nbgp)
1366	ENDDO
1367
1368	ELSE
1369	!
1370	!-- Prepare output of 3d-REAL-array without ghost layers
1371	DO i = nxl, nxr
1372	array_3d_soil(:,i,lb%nys:lb%nyn) = data(:,nys:nyn,i)
1373	ENDDO
1374
1375	ENDIF
1376	#if defined( __parallel )
1377	CALL sm_io%sm_node_barrier() ! has no effect if I/O on limited number of cores is inactive
1378	IF ( sm_io%iam_io_pe ) THEN
1379	CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_3dsoil, 'native', MPI_INFO_NULL, &
1380	ierr )
1381	CALL MPI_FILE_WRITE_ALL( fh, array_3d_soil, SIZE( array_3d_soil ), MPI_REAL, status, ierr )
1382	ENDIF
1383	CALL sm_io%sm_node_barrier()
1384	#else
1385	CALL posix_lseek( fh, array_position )
1386	CALL posix_write( fh, array_3d_soil, SIZE( array_3d_soil ) )
1387	#endif
1388	!
1389	!-- Type conversion required, otherwise rigth hand side brackets are calculated assuming 4 byte INT.
1390	!-- Maybe a compiler problem.
1391	array_position = array_position + INT( (nzt_soil-nzb_soil+1), KIND=rd_offset_kind ) * &
1392	INT( (lb%ny+1), KIND=rd_offset_kind ) * &
1393	INT( (lb%nx+1), KIND=rd_offset_kind ) * wp
1394
1395	END SUBROUTINE wrd_mpi_io_real_3d_soil
1396
1397
1398
1399	!--------------------------------------------------------------------------------------------------!
1400	! Description:
1401	! ------------
1402	!> Write CHARATCTER with MPI-IO
1403	!--------------------------------------------------------------------------------------------------!
1404	SUBROUTINE wrd_mpi_io_char( name, text )
1405
1406	IMPLICIT NONE
1407
1408	CHARACTER(LEN=128) :: lo_line
1409	CHARACTER(LEN=*), INTENT(IN) :: name
1410	CHARACTER(LEN=*), INTENT(IN) :: text
1411
1412
1413	lo_line = name
1414	lo_line(33:) = text
1415	text_lines(header_char_index) = lo_line
1416	header_char_index = header_char_index + 1
1417
1418	END SUBROUTINE wrd_mpi_io_char
1419
1420
1421
1422	!--------------------------------------------------------------------------------------------------!
1423	! Description:
1424	! ------------
1425	!> Write LOGICAL with MPI-IO
1426	!--------------------------------------------------------------------------------------------------!
1427	SUBROUTINE wrd_mpi_io_logical( name, value )
1428
1429	IMPLICIT NONE
1430
1431	CHARACTER(LEN=*), INTENT(IN) :: name
1432
1433	INTEGER(iwp) :: logical_as_integer
1434
1435	LOGICAL, INTENT(IN) :: value
1436
1437
1438	IF ( value ) THEN
1439	logical_as_integer = 1
1440	ELSE
1441	logical_as_integer = 0
1442	ENDIF
1443
1444	CALL wrd_mpi_io_int( name, logical_as_integer )
1445
1446	END SUBROUTINE wrd_mpi_io_logical
1447
1448
1449
1450	!--------------------------------------------------------------------------------------------------!
1451	! Description:
1452	! ------------
1453	!> Read 1d-REAL global array with MPI-IO.
1454	!> Array contains identical data on all PEs.
1455	!--------------------------------------------------------------------------------------------------!
1456	SUBROUTINE rrd_mpi_io_global_array_real_1d( name, data )
1457
1458	IMPLICIT NONE
1459
1460	CHARACTER(LEN=*), INTENT(IN) :: name
1461
1462	INTEGER(iwp) :: i
1463	INTEGER(KIND=rd_offset_kind) :: offset
1464
1465	#if defined( __parallel )
1466	INTEGER, DIMENSION(rd_status_size) :: status
1467	#endif
1468
1469	LOGICAL :: found
1470
1471	REAL(KIND=wp), INTENT(INOUT), DIMENSION(:) :: data
1472
1473
1474	offset = 0
1475	found = .FALSE.
1476
1477	DO i = 1, tgh%nr_arrays
1478	IF ( TRIM(array_names(i)) == TRIM( name ) ) THEN
1479	array_position = array_offset(i)
1480	found = .TRUE.
1481	EXIT
1482	ENDIF
1483	ENDDO
1484
1485	IF ( found ) THEN
1486	!
1487	!-- Set default view
1488	#if defined( __parallel )
1489	IF ( sm_io%iam_io_pe ) THEN
1490	CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
1491	CALL MPI_FILE_SEEK( fh, array_position, MPI_SEEK_SET, ierr )
1492	CALL MPI_FILE_READ_ALL( fh, data, SIZE( data ), MPI_REAL, status, ierr )
1493	ENDIF
1494	IF ( sm_io%is_sm_active() ) THEN
1495	CALL MPI_BCAST( data, SIZE(data), MPI_REAL, 0, sm_io%comm_shared, ierr )
1496	ENDIF
1497	#else
1498	CALL posix_lseek( fh, array_position )
1499	CALL posix_read( fh, data, SIZE( data ) )
1500	#endif
1501
1502	ELSE
1503
1504	message_string = '1d/2d/3d/4d-REAL global array "' // TRIM( name ) // '" not found in ' // &
1505	'restart file'
1506	CALL message( 'rrd_mpi_io_global_array_real_1d', 'PA0722', 3, 2, 0, 6, 0 )
1507
1508	ENDIF
1509
1510	END SUBROUTINE rrd_mpi_io_global_array_real_1d
1511
1512
1513
1514	!--------------------------------------------------------------------------------------------------!
1515	! Description:
1516	! ------------
1517	!> Read 2d-REAL global array with MPI-IO.
1518	!> Array contains identical data on all PEs.
1519	!--------------------------------------------------------------------------------------------------!
1520	SUBROUTINE rrd_mpi_io_global_array_real_2d( name, data )
1521
1522	IMPLICIT NONE
1523
1524	CHARACTER(LEN=*), INTENT(IN) :: name
1525
1526	INTEGER, DIMENSION(1) :: bufshape
1527
1528	REAL(KIND=wp), INTENT(IN), DIMENSION(:,:), TARGET :: data
1529	REAL(KIND=wp), POINTER, DIMENSION(:) :: buf
1530
1531	TYPE(C_PTR) :: c_data
1532
1533
1534	c_data = C_LOC( data )
1535	bufshape(1) = SIZE( data )
1536	CALL C_F_POINTER( c_data, buf, bufshape )
1537
1538	CALL rrd_mpi_io_global_array_real_1d( name, buf )
1539
1540	END SUBROUTINE rrd_mpi_io_global_array_real_2d
1541
1542
1543
1544	!--------------------------------------------------------------------------------------------------!
1545	! Description:
1546	! ------------
1547	!> Read 3d-REAL global array with MPI-IO.
1548	!> Array contains identical data on all PEs.
1549	!--------------------------------------------------------------------------------------------------!
1550	SUBROUTINE rrd_mpi_io_global_array_real_3d( name, data )
1551
1552	IMPLICIT NONE
1553
1554	CHARACTER(LEN=*), INTENT(IN) :: name
1555
1556	INTEGER, DIMENSION(1) :: bufshape
1557
1558	REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:), TARGET :: data
1559	REAL(KIND=wp), POINTER, DIMENSION(:) :: buf
1560
1561	TYPE(C_PTR) :: c_data
1562
1563
1564	c_data = C_LOC( data )
1565	bufshape(1) = SIZE( data )
1566	CALL C_F_POINTER( c_data, buf, bufshape )
1567
1568	CALL rrd_mpi_io_global_array_real_1d( name, buf )
1569
1570	END SUBROUTINE rrd_mpi_io_global_array_real_3d
1571
1572
1573
1574	!--------------------------------------------------------------------------------------------------!
1575	! Description:
1576	! ------------
1577	!> Read 4d-REAL global array with MPI-IO.
1578	!> Array contains identical data on all PEs.
1579	!--------------------------------------------------------------------------------------------------!
1580	SUBROUTINE rrd_mpi_io_global_array_real_4d( name, data )
1581
1582	IMPLICIT NONE
1583
1584	CHARACTER(LEN=*), INTENT(IN) :: name
1585
1586	INTEGER, DIMENSION(1) :: bufshape
1587
1588	REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:,:), TARGET :: data
1589	REAL(KIND=wp), POINTER, DIMENSION(:) :: buf
1590
1591	TYPE(C_PTR) :: c_data
1592
1593
1594	c_data = C_LOC( data )
1595	bufshape(1) = SIZE( data)
1596	CALL C_F_POINTER( c_data, buf, bufshape )
1597
1598	CALL rrd_mpi_io_global_array_real_1d( name, buf )
1599
1600	END SUBROUTINE rrd_mpi_io_global_array_real_4d
1601
1602
1603
1604	!--------------------------------------------------------------------------------------------------!
1605	! Description:
1606	! ------------
1607	!> Read 1d-INTEGER global array with MPI-IO.
1608	!> Array contains identical data on all PEs.
1609	!--------------------------------------------------------------------------------------------------!
1610	SUBROUTINE rrd_mpi_io_global_array_int_1d( name, data )
1611
1612	IMPLICIT NONE
1613
1614	CHARACTER(LEN=*), INTENT(IN) :: name
1615
1616	INTEGER(iwp) :: i
1617	INTEGER(KIND=rd_offset_kind) :: offset
1618
1619	#if defined( __parallel )
1620	INTEGER, DIMENSION(rd_status_size) :: status
1621	#endif
1622	INTEGER(KIND=iwp), INTENT(INOUT), DIMENSION(:) :: data
1623
1624	LOGICAL :: found
1625
1626
1627	offset = 0
1628	found = .FALSE.
1629
1630	DO i = 1, tgh%nr_arrays
1631	IF ( TRIM(array_names(i)) == TRIM( name ) ) THEN
1632	array_position = array_offset(i)
1633	found = .TRUE.
1634	EXIT
1635	ENDIF
1636	ENDDO
1637
1638	IF ( found ) THEN
1639	!
1640	!-- Set default view
1641	#if defined( __parallel )
1642	IF ( sm_io%iam_io_pe ) THEN
1643	CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
1644	CALL MPI_FILE_SEEK( fh, array_position, MPI_SEEK_SET, ierr )
1645	CALL MPI_FILE_READ_ALL( fh, data, SIZE( data), MPI_INTEGER, status, ierr )
1646	ENDIF
1647	IF ( sm_io%is_sm_active() ) THEN
1648	CALL MPI_BCAST( data, SIZE(data), MPI_INTEGER, 0, sm_io%comm_shared, ierr )
1649	ENDIF
1650	#else
1651	CALL posix_lseek( fh, array_position )
1652	CALL posix_read( fh, data, SIZE( data ) )
1653	#endif
1654	ELSE
1655
1656	message_string = '1d-INTEGER global array "' // TRIM( name ) // '" not found in ' // &
1657	'restart file'
1658	CALL message( 'rrd_mpi_io_global_array_int_1d', 'PA0722', 3, 2, 0, 6, 0 )
1659
1660	ENDIF
1661
1662	END SUBROUTINE rrd_mpi_io_global_array_int_1d
1663
1664
1665
1666	!--------------------------------------------------------------------------------------------------!
1667	! Description:
1668	! ------------
1669	!> Write 1d-REAL global array with MPI-IO.
1670	!> Array contains identical data on all PEs.
1671	!--------------------------------------------------------------------------------------------------!
1672	SUBROUTINE wrd_mpi_io_global_array_real_1d( name, data )
1673
1674	IMPLICIT NONE
1675
1676	CHARACTER(LEN=*), INTENT(IN) :: name
1677
1678	INTEGER(KIND=rd_offset_kind) :: offset
1679
1680	#if defined( __parallel )
1681	INTEGER, DIMENSION(rd_status_size) :: status
1682	#endif
1683
1684	REAL(KIND=wp), INTENT(IN), DIMENSION(:) :: data
1685
1686
1687	offset = 0
1688
1689	array_names(header_arr_index) = name
1690	array_offset(header_arr_index) = array_position
1691	header_arr_index = header_arr_index + 1
1692
1693	!
1694	!-- Set default view
1695	#if defined( __parallel )
1696	IF ( sm_io%iam_io_pe ) THEN
1697	CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
1698	ENDIF
1699	!
1700	!-- Only PE 0 writes replicated data
1701	IF ( myid == 0 ) THEN
1702	CALL MPI_FILE_SEEK( fh, array_position, MPI_SEEK_SET, ierr )
1703	CALL MPI_FILE_WRITE( fh, data, SIZE( data), MPI_REAL, status, ierr )
1704	ENDIF
1705	#else
1706	CALL posix_lseek( fh, array_position )
1707	CALL posix_write( fh, data, SIZE( data ) )
1708	#endif
1709	array_position = array_position + SIZE( data ) * wp
1710
1711	END SUBROUTINE wrd_mpi_io_global_array_real_1d
1712
1713
1714
1715	!--------------------------------------------------------------------------------------------------!
1716	! Description:
1717	! ------------
1718	!> Write 2d-REAL global array with MPI-IO.
1719	!> Array contains identical data on all PEs.
1720	!--------------------------------------------------------------------------------------------------!
1721	SUBROUTINE wrd_mpi_io_global_array_real_2d( name, data )
1722
1723	IMPLICIT NONE
1724
1725	CHARACTER(LEN=*), INTENT(IN) :: name
1726
1727	INTEGER, DIMENSION(1) :: bufshape
1728
1729	REAL(KIND=wp), POINTER, DIMENSION(:) :: buf
1730	REAL(KIND=wp), INTENT(IN), DIMENSION(:,:), TARGET :: data
1731
1732	TYPE(C_PTR) :: c_data
1733
1734
1735	c_data = C_LOC( data )
1736	bufshape(1) = SIZE( data)
1737	CALL C_F_POINTER( c_data, buf, bufshape )
1738
1739	CALL wrd_mpi_io_global_array_real_1d( name, buf )
1740
1741	END SUBROUTINE wrd_mpi_io_global_array_real_2d
1742
1743
1744
1745	!--------------------------------------------------------------------------------------------------!
1746	! Description:
1747	! ------------
1748	!> Write 3d-REAL global array with MPI-IO.
1749	!> Array contains identical data on all PEs.
1750	!--------------------------------------------------------------------------------------------------!
1751	SUBROUTINE wrd_mpi_io_global_array_real_3d( name, data )
1752
1753	IMPLICIT NONE
1754
1755	CHARACTER(LEN=*), INTENT(IN) :: name
1756
1757	INTEGER, DIMENSION(1) :: bufshape
1758
1759	REAL(KIND=wp), POINTER, DIMENSION(:) :: buf
1760	REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:), TARGET :: data
1761
1762	TYPE(C_PTR) :: c_data
1763
1764
1765	c_data = C_LOC( data )
1766	bufshape(1) = SIZE( data )
1767	CALL C_F_POINTER( c_data, buf, bufshape )
1768
1769	CALL wrd_mpi_io_global_array_real_1d( name, buf )
1770
1771	END SUBROUTINE wrd_mpi_io_global_array_real_3d
1772
1773
1774
1775	!--------------------------------------------------------------------------------------------------!
1776	! Description:
1777	! ------------
1778	!> Write 4d-REAL global array with MPI-IO.
1779	!> Array contains identical data on all PEs.
1780	!--------------------------------------------------------------------------------------------------!
1781	SUBROUTINE wrd_mpi_io_global_array_real_4d( name, data )
1782
1783	IMPLICIT NONE
1784
1785	CHARACTER(LEN=*), INTENT(IN) :: name
1786
1787	INTEGER, DIMENSION(1) :: bufshape
1788
1789	REAL(KIND=wp), POINTER, DIMENSION(:) :: buf
1790	REAL(KIND=wp), INTENT(IN), DIMENSION(:,:,:,:), TARGET :: data
1791
1792	TYPE(C_PTR) :: c_data
1793
1794
1795	c_data = C_LOC( data )
1796	bufshape(1) = SIZE( data)
1797	CALL C_F_POINTER( c_data, buf, bufshape )
1798
1799	CALL wrd_mpi_io_global_array_real_1d( name, buf )
1800
1801	END SUBROUTINE wrd_mpi_io_global_array_real_4d
1802
1803
1804
1805	!--------------------------------------------------------------------------------------------------!
1806	! Description:
1807	! ------------
1808	!> Write 1d-INTEGER global array with MPI-IO.
1809	!> Array contains identical data on all PEs.
1810	!--------------------------------------------------------------------------------------------------!
1811	SUBROUTINE wrd_mpi_io_global_array_int_1d( name, data )
1812
1813	IMPLICIT NONE
1814
1815	CHARACTER(LEN=*), INTENT(IN) :: name
1816
1817	INTEGER(KIND=rd_offset_kind) :: offset
1818
1819	INTEGER(KIND=iwp), INTENT(IN), DIMENSION(:) :: data
1820	#if defined( __parallel )
1821	INTEGER, DIMENSION(rd_status_size) :: status
1822	#endif
1823
1824	offset = 0
1825	array_names(header_arr_index) = name
1826	array_offset(header_arr_index) = array_position
1827	header_arr_index = header_arr_index + 1
1828
1829	!
1830	!-- Set default view
1831	#if defined( __parallel )
1832	IF ( sm_io%iam_io_pe ) THEN
1833	CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
1834	ENDIF
1835	!
1836	!-- Only PE 0 writes replicated data
1837	IF ( myid == 0 ) THEN !
1838	CALL MPI_FILE_SEEK( fh, array_position, MPI_SEEK_SET, ierr )
1839	CALL MPI_FILE_WRITE( fh, data, SIZE( data), MPI_INTEGER, status, ierr )
1840	ENDIF
1841	#else
1842	CALL posix_lseek( fh, array_position )
1843	CALL posix_write( fh, data, SIZE( data ) )
1844	#endif
1845	array_position = array_position + SIZE( data ) * 4
1846
1847	END SUBROUTINE wrd_mpi_io_global_array_int_1d
1848
1849
1850
1851	!--------------------------------------------------------------------------------------------------!
1852	! Description:
1853	! ------------
1854	!> Read 1d-REAL surface data array with MPI-IO.
1855	!--------------------------------------------------------------------------------------------------!
1856	SUBROUTINE rrd_mpi_io_surface( name, data, first_index )
1857
1858	IMPLICIT NONE
1859
1860	CHARACTER(LEN=*), INTENT(IN) :: name
1861
1862	INTEGER(KIND=rd_offset_kind) :: disp !< displacement of actual indices
1863	INTEGER(KIND=rd_offset_kind) :: disp_f !< displacement in file
1864	INTEGER(KIND=rd_offset_kind) :: disp_n !< displacement of next column
1865	INTEGER(iwp), OPTIONAL :: first_index
1866
1867	INTEGER(iwp) :: i
1868	INTEGER(iwp) :: i_f
1869	INTEGER(iwp) :: j
1870	INTEGER(iwp) :: j_f
1871	INTEGER(iwp) :: lo_first_index
1872	INTEGER(iwp) :: nr_bytes
1873	INTEGER(iwp) :: nr_bytes_f
1874	INTEGER(iwp) :: nr_words
1875	#if defined( __parallel )
1876	INTEGER, DIMENSION(rd_status_size) :: status
1877	#endif
1878
1879	LOGICAL :: found
1880
1881	REAL(wp), INTENT(OUT), DIMENSION(:) :: data
1882
1883
1884	found = .FALSE.
1885	lo_first_index = 1
1886
1887	IF ( MAXVAL( m_global_start ) == -1 ) RETURN ! nothing to do on this PE
1888
1889	IF ( PRESENT( first_index ) ) THEN
1890	lo_first_index = first_index
1891	ENDIF
1892
1893	DO i = 1, tgh%nr_arrays
1894	IF ( TRIM( array_names(i) ) == TRIM( name ) ) THEN
1895	array_position = array_offset(i) + ( lo_first_index - 1 ) * &
1896	total_number_of_surface_values * wp
1897	found = .TRUE.
1898	EXIT
1899	ENDIF
1900	ENDDO
1901
1902	disp = -1
1903	disp_f = -1
1904	disp_n = -1
1905	IF ( found ) THEN
1906
1907	DO i = nxl, nxr
1908	DO j = nys, nyn
1909
1910	IF ( m_global_start(j,i) > 0 ) THEN
1911	disp = array_position+(m_global_start(j,i)-1) * wp
1912	nr_words = m_end_index(j,i)-m_start_index(j,i)+1
1913	nr_bytes = nr_words * wp
1914	ENDIF
1915	IF ( disp >= 0 .AND. disp_f == -1 ) THEN ! first Entry
1916	disp_f = disp
1917	nr_bytes_f = 0
1918	i_f = i
1919	j_f = j
1920	ENDIF
1921	IF ( j == nyn .AND. i == nxr ) THEN ! last Entry
1922	disp_n = -1
1923	IF ( nr_bytes > 0 ) THEN
1924	nr_bytes_f = nr_bytes_f+nr_bytes
1925	ENDIF
1926	ELSEIF ( j == nyn ) THEN ! next x
1927	IF ( m_global_start(nys,i+1) > 0 .AND. disp > 0 ) THEN
1928	disp_n = array_position + ( m_global_start(nys,i+1) - 1 ) * wp
1929	ELSE
1930	CYCLE
1931	ENDIF
1932	ELSE
1933	IF ( m_global_start(j+1,i) > 0 .AND. disp > 0 ) THEN
1934	disp_n = array_position + ( m_global_start(j+1,i) - 1 ) * wp
1935	ELSE
1936	CYCLE
1937	ENDIF
1938	ENDIF
1939
1940
1941	IF ( disp + nr_bytes == disp_n ) THEN ! contiguous block
1942	nr_bytes_f = nr_bytes_f + nr_bytes
1943	ELSE ! read
1944	#if defined( __parallel )
1945	CALL MPI_FILE_SEEK( fhs, disp_f, MPI_SEEK_SET, ierr )
1946	nr_words = nr_bytes_f / wp
1947	CALL MPI_FILE_READ( fhs, data(m_start_index(j_f,i_f)), nr_words, MPI_REAL, status, ierr )
1948	#else
1949	CALL posix_lseek( fh, disp_f )
1950	CALL posix_read( fh, data(m_start_index(j_f,i_f):), nr_bytes_f )
1951	#endif
1952	disp_f = disp
1953	nr_bytes_f = nr_bytes
1954	i_f = i
1955	j_f = j
1956	ENDIF
1957
1958	ENDDO
1959	ENDDO
1960
1961	ELSE
1962
1963	message_string = 'surface array "' // TRIM( name ) // '" not found in restart file'
1964	CALL message( 'rrd_mpi_io_global_array_int_1d', 'PA0722', 3, 2, 0, 6, 0 )
1965
1966	ENDIF
1967
1968	! IF ( lo_first_index == 1 ) THEN
1969	! IF ( debug_level >= 2 .AND. nr_val > 0 ) WRITE(9,*) 'r_surf_1 ', TRIM( name ), ' ', nr_val, SUM( data(1:nr_val) )
1970	! ELSE
1971	! IF ( debug_level >= 2 .AND. nr_val > 0 ) WRITE(9,*) 'r_surf_next ', TRIM( name ), ' ', &
1972	! lo_first_index,nr_val, SUM( data(1:nr_val) )
1973	! ENDIF
1974
1975	END SUBROUTINE rrd_mpi_io_surface
1976
1977
1978
1979	!--------------------------------------------------------------------------------------------------!
1980	! Description:
1981	! ------------
1982	!> Read 2d-REAL surface data array with MPI-IO.
1983	!> These consist of multiple 1d-REAL surface data arrays.
1984	!--------------------------------------------------------------------------------------------------!
1985	SUBROUTINE rrd_mpi_io_surface_2d( name, data )
1986
1987	IMPLICIT NONE
1988
1989	CHARACTER(LEN=*), INTENT(IN) :: name
1990
1991	INTEGER(iwp) :: i
1992
1993	REAL(wp), INTENT(OUT), DIMENSION(:,:) :: data
1994	REAL(wp), DIMENSION(SIZE( data,2)) :: tmp
1995
1996
1997	DO i = 1, SIZE( data,1)
1998	CALL rrd_mpi_io_surface( name, tmp, first_index = i )
1999	data(i,:) = tmp
2000	ENDDO
2001
2002	!
2003	!-- Comment from Klaus Ketelsen (September 2018)
2004	!-- The intention of the following loop was let the compiler do the copying on return.
2005	!-- In my understanding is it standard conform to pass the second dimension to a 1d-
2006	!-- array inside a subroutine and the compiler is responsible to generate code for
2007	!-- copying. Acually this works fine for INTENT(IN) variables (wrd_mpi_io_surface_2d).
2008	!-- For INTENT(OUT) like in this case the code works on pgi compiler. But both, the Intel 16
2009	!-- and the Cray compiler show wrong answers using this loop.
2010	!-- That is the reason why the above auxiliary array tmp was introduced.
2011	! DO i = 1, SIZE( data,1)
2012	! CALL rrd_mpi_io_surface( name, data(i,:), first_index = i )
2013	! ENDDO
2014
2015	END SUBROUTINE rrd_mpi_io_surface_2d
2016
2017
2018
2019	!--------------------------------------------------------------------------------------------------!
2020	! Description:
2021	! ------------
2022	!> Write 1d-REAL surface data array with MPI-IO.
2023	!--------------------------------------------------------------------------------------------------!
2024	SUBROUTINE wrd_mpi_io_surface( name, data, first_index )
2025
2026	IMPLICIT NONE
2027
2028	CHARACTER(LEN=*), INTENT(IN) :: name
2029
2030	#if defined( __parallel )
2031	INTEGER(KIND=rd_offset_kind) :: disp
2032	#endif
2033	INTEGER(iwp), OPTIONAL :: first_index
2034	#if defined( __parallel )
2035	INTEGER(iwp) :: i
2036	#endif
2037	INTEGER(iwp) :: lo_first_index
2038	INTEGER(KIND=rd_offset_kind) :: offset
2039
2040	#if defined( __parallel )
2041	INTEGER, DIMENSION(rd_status_size) :: status
2042	#endif
2043
2044	REAL(wp), INTENT(IN), DIMENSION(:), TARGET :: data
2045
2046
2047	offset = 0
2048	lo_first_index = 1
2049
2050	IF ( PRESENT(first_index) ) THEN
2051	lo_first_index = first_index
2052	ENDIF
2053	!
2054	!-- In case of 2d-data, name is writen only once
2055	IF ( lo_first_index == 1 ) THEN
2056	array_names(header_arr_index) = name
2057	array_offset(header_arr_index) = array_position
2058	header_arr_index = header_arr_index + 1
2059	ENDIF
2060	#if defined( __parallel )
2061	IF ( sm_io%is_sm_active() ) THEN
2062	DO i = 1, nr_val
2063	array_1d(i+local_start) = data(i)
2064	ENDDO
2065	ELSE
2066	! array_1d => data !kk Did not work in all cases why???
2067	ALLOCATE( array_1d( SIZE( data ) ) )
2068	array_1d = data
2069	ENDIF
2070
2071	CALL sm_io%sm_node_barrier() ! has no effect if I/O on limited number of cores is inactive
2072	IF ( sm_io%iam_io_pe ) THEN
2073	IF ( all_pes_write ) THEN
2074	CALL MPI_FILE_SET_VIEW( fh, array_position, MPI_REAL, ft_surf, 'native', MPI_INFO_NULL, &
2075	ierr )
2076	CALL MPI_FILE_WRITE_ALL( fh, array_1d, nr_iope, MPI_REAL, status, ierr )
2077	ELSE
2078	CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
2079	IF ( nr_val > 0 ) THEN
2080	disp = array_position + 8 * ( glo_start - 1 )
2081	CALL MPI_FILE_SEEK( fh, disp, MPI_SEEK_SET, ierr )
2082	CALL MPI_FILE_WRITE( fh, array_1d, nr_iope, MPI_REAL, status, ierr )
2083	ENDIF
2084	ENDIF
2085	ENDIF
2086	CALL sm_io%sm_node_barrier()
2087	IF( .NOT. sm_io%is_sm_active() ) DEALLOCATE( array_1d )
2088	#else
2089	CALL posix_lseek( fh, array_position )
2090	CALL posix_write( fh, data, nr_val )
2091	#endif
2092	array_position = array_position + total_number_of_surface_values * wp
2093
2094	! IF ( lo_first_index == 1 ) THEN
2095	! IF ( debug_level >= 2 .AND. nr_val > 0 ) WRITE(9,*) 'w_surf_1 ', TRIM( name ), ' ', nr_val, SUM( data(1:nr_val) )
2096	! ELSE
2097	! IF ( debug_level >= 2 .AND. nr_val > 0 ) WRITE(9,*) 'w_surf_n ', TRIM( name ), ' ', &
2098	! lo_first_index, nr_val, SUM( data(1:nr_val) )
2099	! ENDIF
2100
2101	END SUBROUTINE wrd_mpi_io_surface
2102
2103
2104
2105	!--------------------------------------------------------------------------------------------------!
2106	! Description:
2107	! ------------
2108	!> Read 2d-REAL surface data array with MPI-IO.
2109	!> These consist of multiple 1d-REAL surface data arrays.
2110	!--------------------------------------------------------------------------------------------------!
2111	SUBROUTINE wrd_mpi_io_surface_2d( name, data )
2112
2113	IMPLICIT NONE
2114
2115	CHARACTER(LEN=*), INTENT(IN) :: name
2116
2117	INTEGER(iwp) :: i
2118
2119	REAL(wp), INTENT(IN), DIMENSION(:,:) :: data
2120
2121
2122	DO i = 1, SIZE( data,1)
2123	CALL wrd_mpi_io_surface( name, data(i,:), first_index = i )
2124	ENDDO
2125
2126	END SUBROUTINE wrd_mpi_io_surface_2d
2127
2128
2129
2130	!--------------------------------------------------------------------------------------------------!
2131	! Description:
2132	! ------------
2133	!> Close restart file for MPI-IO
2134	!--------------------------------------------------------------------------------------------------!
2135	SUBROUTINE rd_mpi_io_close
2136
2137	IMPLICIT NONE
2138
2139	INTEGER(iwp) :: gh_size
2140	INTEGER(KIND=rd_offset_kind) :: offset
2141	#if defined( __parallel )
2142	INTEGER, DIMENSION(rd_status_size) :: status
2143	#endif
2144
2145	#if ! defined( __parallel )
2146	TYPE(C_PTR) :: buf_ptr
2147	#endif
2148
2149
2150	offset = 0
2151
2152	IF ( wr_flag .AND. sm_io%iam_io_pe ) THEN
2153
2154	tgh%nr_int = header_int_index - 1
2155	tgh%nr_char = header_char_index - 1
2156	tgh%nr_real = header_real_index - 1
2157	tgh%nr_arrays = header_arr_index - 1
2158	tgh%total_nx = lb%nx + 1
2159	tgh%total_ny = lb%ny + 1
2160	IF ( include_total_domain_boundaries ) THEN ! not sure, if LOGICAL interpretation is the same for all compilers,
2161	tgh%i_outer_bound = 1 ! therefore store as INTEGER in general header
2162	ELSE
2163	tgh%i_outer_bound = 0
2164	ENDIF
2165	!
2166	!-- Check for big/little endian format. This check is currently not used, and could be removed
2167	!-- if we can assume little endian as the default on all machines.
2168	CALL rd_mpi_io_check_endian( tgh%endian )
2169
2170	!
2171	!-- Set default view
2172	#if defined( __parallel )
2173	CALL MPI_FILE_SET_VIEW( fh, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
2174	#endif
2175	!
2176	!-- Write header file
2177	gh_size = storage_size(tgh) / 8
2178	IF ( myid == 0 ) THEN ! myid = 0 always performs I/O, even if I/O is limited to some cores
2179	#if defined( __parallel )
2180	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2181	CALL MPI_FILE_WRITE( fh, tgh, gh_size, MPI_INT, status, ierr )
2182	header_position = header_position + gh_size
2183	!
2184	!-- INTEGER values
2185	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2186	CALL MPI_FILE_WRITE( fh, int_names, SIZE( int_names )*32, MPI_CHAR, status, ierr )
2187	header_position = header_position + SIZE( int_names ) * 32
2188
2189	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2190	CALL MPI_FILE_WRITE( fh, int_values, SIZE( int_values ), MPI_INT, status, ierr )
2191	header_position = header_position + SIZE( int_values ) * iwp
2192	!
2193	!-- Character entries
2194	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2195	CALL MPI_FILE_WRITE( fh, text_lines, SIZE( text_lines )*128, MPI_CHAR, status, ierr )
2196	header_position = header_position + SIZE( text_lines ) * 128
2197	!
2198	!--- REAL values
2199	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2200	CALL MPI_FILE_WRITE( fh, real_names, SIZE( real_names )*32, MPI_CHAR, status, ierr )
2201	header_position = header_position + SIZE( real_names ) * 32
2202
2203	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2204	CALL MPI_FILE_WRITE( fh, real_values, SIZE( real_values ), MPI_REAL, status, ierr )
2205	header_position = header_position + SIZE( real_values ) * wp
2206	!
2207	!-- 2d- and 3d- distributed array headers, all replicated array headers
2208	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2209	CALL MPI_FILE_WRITE( fh, array_names, SIZE( array_names )*32, MPI_CHAR, status, ierr )
2210	header_position = header_position + SIZE( array_names ) * 32
2211
2212	CALL MPI_FILE_SEEK( fh, header_position, MPI_SEEK_SET, ierr )
2213	CALL MPI_FILE_WRITE( fh, array_offset, SIZE( array_offset )*MPI_OFFSET_KIND, MPI_BYTE, &
2214	status, ierr ) ! There is no I*8 datatype in Fortran
2215	header_position = header_position + SIZE( array_offset ) * rd_offset_kind
2216	#else
2217	CALL posix_lseek( fh, header_position )
2218	buf_ptr = C_LOC( tgh )
2219	CALL posix_write( fh, buf_ptr, gh_size )
2220	header_position = header_position + gh_size
2221	!
2222	!-- INTEGER values
2223	CALL posix_lseek( fh, header_position )
2224	CALL posix_write( fh, int_names )
2225	header_position = header_position + SIZE( int_names ) * 32
2226
2227	CALL posix_lseek( fh, header_position )
2228	CALL posix_write( fh, int_values, SIZE( int_values ) )
2229	header_position = header_position + SIZE( int_values ) * iwp
2230	!
2231	!-- Character entries
2232	CALL posix_lseek( fh, header_position )
2233	CALL posix_write( fh, text_lines )
2234	header_position = header_position + SIZE( text_lines ) * 128
2235	!
2236	!-- REAL values
2237	CALL posix_lseek( fh, header_position )
2238	CALL posix_write( fh, real_names )
2239	header_position = header_position + SIZE( real_names ) * 32
2240
2241	CALL posix_lseek( fh, header_position )
2242	CALL posix_write( fh, real_values, SIZE( real_values ) )
2243	header_position = header_position + SIZE( real_values ) * wp
2244	!
2245	!-- 2d- and 3d-distributed array headers, all replicated array headers
2246	CALL posix_lseek( fh, header_position )
2247	CALL posix_write( fh, array_names )
2248	header_position = header_position + SIZE( array_names ) * 32
2249
2250	CALL posix_lseek( fh, header_position )
2251	CALL posix_write( fh, array_offset, SIZE( array_offset ) )
2252	header_position = header_position + SIZE( array_offset ) * rd_offset_kind
2253	#endif
2254	IF ( debug_output ) CALL rd_mpi_io_print_header
2255	ENDIF
2256
2257	ENDIF
2258
2259	!
2260	!-- Free file types
2261	CALL rd_mpi_io_free_filetypes
2262
2263	!
2264	!-- Close MPI-IO files
2265	#if defined( __parallel )
2266	!
2267	!-- Restart file has been opened with comm2d
2268	IF ( fhs /= -1 ) THEN
2269	CALL MPI_FILE_CLOSE( fhs, ierr )
2270	ENDIF
2271	#endif
2272
2273	IF ( sm_io%iam_io_pe ) THEN
2274
2275	#if defined( __parallel )
2276	CALL MPI_FILE_CLOSE( fh, ierr )
2277	#else
2278	CALL posix_close( fh )
2279	#endif
2280
2281	ENDIF
2282
2283	restart_file_size = array_position / ( 1024.0_dp * 1024.0_dp )
2284
2285	END SUBROUTINE rd_mpi_io_close
2286
2287
2288
2289	!--------------------------------------------------------------------------------------------------!
2290	! Description:
2291	! ------------
2292	!> This subroutine prepares a filetype and some variables for the I/O of surface data.
2293	!> Whenever a new set of start_index and end_index is used, rd_mpi_io_surface_filetypes has to be
2294	!> called. A main feature of this subroutine is computing the global start indices of the 1d- and
2295	!> 2d- surface arrays.
2296	!> Even if I/O is done by a limited number of cores only, the surface data are read by ALL cores!
2297	!> Reading them by some cores and then distributing the data would result in complicated code
2298	!> which is suspectable for errors and overloads the reading subroutine. Since reading of surface
2299	!> data is not time critical (data size is comparably small), it will be read by all cores.
2300	!--------------------------------------------------------------------------------------------------!
2301	SUBROUTINE rd_mpi_io_surface_filetypes( start_index, end_index, data_to_write, global_start )
2302
2303	IMPLICIT NONE
2304
2305	INTEGER(iwp) :: i !< loop index
2306	INTEGER(KIND=rd_offset_kind) :: offset
2307
2308	INTEGER(iwp), DIMENSION(1) :: dims1
2309	INTEGER(iwp), DIMENSION(1) :: lize1
2310	INTEGER(iwp), DIMENSION(1) :: start1
2311	INTEGER(iwp), DIMENSION(0:numprocs-1) :: lo_nr_val !< local number of values in x and y direction
2312	INTEGER(iwp), DIMENSION(0:numprocs-1) :: all_nr_val !< number of values for all PEs
2313
2314	INTEGER, INTENT(IN), DIMENSION(nys:nyn,nxl:nxr) :: end_index
2315	INTEGER, INTENT(OUT), DIMENSION(nys:nyn,nxl:nxr) :: global_start
2316	INTEGER, INTENT(IN), DIMENSION(nys:nyn,nxl:nxr) :: start_index
2317
2318	LOGICAL, INTENT(OUT) :: data_to_write !< returns, if surface data have to be written
2319
2320
2321	offset = 0
2322	lo_nr_val= 0
2323	lo_nr_val(myid) = MAXVAL( end_index )
2324	#if defined( __parallel )
2325	CALL MPI_ALLREDUCE( lo_nr_val, all_nr_val, numprocs, MPI_INTEGER, MPI_SUM, comm2d, ierr )
2326	IF ( ft_surf /= -1 .AND. sm_io%iam_io_pe ) THEN
2327	CALL MPI_TYPE_FREE( ft_surf, ierr ) ! if set, free last surface filetype
2328	ENDIF
2329
2330	IF ( win_surf /= -1 ) THEN
2331	IF ( sm_io%is_sm_active() ) THEN
2332	CALL MPI_WIN_FREE( win_surf, ierr )
2333	ENDIF
2334	win_surf = -1
2335	ENDIF
2336
2337	IF ( sm_io%is_sm_active() .AND. rd_flag ) THEN
2338	IF ( fhs == -1 ) THEN
2339	CALL MPI_FILE_OPEN( comm2d, TRIM( io_file_name ), MPI_MODE_RDONLY, MPI_INFO_NULL, fhs, &
2340	ierr )
2341	ENDIF
2342	ELSE
2343	fhs = fh
2344	ENDIF
2345	#else
2346	all_nr_val(myid) = lo_nr_val(myid)
2347	#endif
2348	nr_val = lo_nr_val(myid)
2349
2350	total_number_of_surface_values = 0
2351	DO i = 0, numprocs-1
2352	IF ( i == myid ) THEN
2353	glo_start = total_number_of_surface_values + 1
2354	ENDIF
2355	total_number_of_surface_values = total_number_of_surface_values + all_nr_val(i)
2356	ENDDO
2357
2358	!
2359	!-- Actions during read
2360	IF ( rd_flag ) THEN
2361	IF ( .NOT. ALLOCATED( m_start_index ) ) ALLOCATE( m_start_index(nys:nyn,nxl:nxr) )
2362	IF ( .NOT. ALLOCATED( m_end_index ) ) ALLOCATE( m_end_index(nys:nyn,nxl:nxr) )
2363	IF ( .NOT. ALLOCATED( m_global_start ) ) ALLOCATE( m_global_start(nys:nyn,nxl:nxr) )
2364	!
2365	!-- Save arrays for later reading
2366	m_start_index = start_index
2367	m_end_index = end_index
2368	m_global_start = global_start
2369	nr_val = MAXVAL( end_index )
2370
2371	#if defined( __parallel )
2372	CALL MPI_FILE_SET_VIEW( fhs, offset, MPI_BYTE, MPI_BYTE, 'native', MPI_INFO_NULL, ierr )
2373	#endif
2374	ENDIF
2375
2376	!
2377	!-- Actions during write
2378	IF ( wr_flag ) THEN
2379	!
2380	!-- Create surface filetype
2381	ft_surf = -1
2382	global_start = start_index + glo_start - 1
2383
2384	WHERE ( end_index < start_index )
2385	global_start = -1
2386	ENDWHERE
2387
2388	#if defined( __parallel )
2389	IF ( sm_io%is_sm_active() ) THEN
2390	IF ( sm_io%iam_io_pe ) THEN
2391	!
2392	!-- Calculate number of values of all PEs of an I/O group
2393	nr_iope = 0
2394	DO i = myid, myid+sm_io%sh_npes-1
2395	nr_iope = nr_iope + all_nr_val(i)
2396	ENDDO
2397	ELSE
2398	local_start = 0
2399	DO i = myid-sm_io%sh_rank, myid-1
2400	local_start = local_start + all_nr_val(i)
2401	ENDDO
2402	ENDIF
2403	!
2404	!-- Get the size of shared memory window on all PEs
2405	CALL MPI_BCAST( nr_iope, 1, MPI_INTEGER, 0, sm_io%comm_shared, ierr )
2406	CALL sm_io%sm_allocate_shared( array_1d, 1, MAX( 1, nr_iope ), win_surf )
2407	ELSE
2408	nr_iope = nr_val
2409	ENDIF
2410	#else
2411	nr_iope = nr_val
2412	#endif
2413
2414	!
2415	!-- Check, if surface data exist on this PE
2416	data_to_write = .TRUE.
2417	IF ( total_number_of_surface_values == 0 ) THEN
2418	data_to_write = .FALSE.
2419	RETURN
2420	ENDIF
2421
2422	IF ( sm_io%iam_io_pe ) THEN
2423
2424	all_pes_write = ( MINVAL( all_nr_val ) > 0 )
2425
2426	IF ( all_pes_write ) THEN
2427	dims1(1) = total_number_of_surface_values
2428	lize1(1) = nr_iope
2429	start1(1) = glo_start-1
2430
2431	#if defined( __parallel )
2432	IF ( total_number_of_surface_values > 0 ) THEN
2433	CALL MPI_TYPE_CREATE_SUBARRAY( 1, dims1, lize1, start1, MPI_ORDER_FORTRAN, &
2434	MPI_REAL, ft_surf, ierr )
2435	CALL MPI_TYPE_COMMIT( ft_surf, ierr )
2436	ENDIF
2437	#endif
2438	ENDIF
2439	ENDIF
2440
2441	ENDIF
2442
2443	END SUBROUTINE rd_mpi_io_surface_filetypes
2444
2445
2446
2447	!--------------------------------------------------------------------------------------------------!
2448	! Description:
2449	! ------------
2450	!> This subroutine creates file types to access 2d-/3d-REAL arrays and 2d-INTEGER arrays
2451	!> distributed in blocks among processes to a single file that contains the global arrays.
2452	!--------------------------------------------------------------------------------------------------!
2453	SUBROUTINE rd_mpi_io_create_filetypes
2454
2455	IMPLICIT NONE
2456
2457	INTEGER, DIMENSION(2) :: dims2
2458	INTEGER, DIMENSION(2) :: lize2
2459	INTEGER, DIMENSION(2) :: start2
2460
2461	INTEGER, DIMENSION(3) :: dims3
2462	INTEGER, DIMENSION(3) :: lize3
2463	INTEGER, DIMENSION(3) :: start3
2464
2465	TYPE(local_boundaries) :: save_io_grid !< temporary variable to store grid settings
2466
2467
2468	IF ( sm_io%is_sm_active() ) THEN
2469	save_io_grid = sm_io%io_grid
2470	ENDIF
2471
2472	!
2473	!-- Decision, if storage with or without ghost layers.
2474	!-- Please note that the indexing of the global array always starts at 0, even in Fortran.
2475	!-- Therefore the PE local indices have to be shifted by nbgp in the case with ghost layers.
2476	IF ( include_total_domain_boundaries ) THEN
2477
2478	lb%nxl = nxl + nbgp
2479	lb%nxr = nxr + nbgp
2480	lb%nys = nys + nbgp
2481	lb%nyn = nyn + nbgp
2482	lb%nnx = nnx
2483	lb%nny = nny
2484	lb%nx = nx + 2 * nbgp
2485	lb%ny = ny + 2 * nbgp
2486	IF ( myidx == 0 ) THEN
2487	lb%nxl = lb%nxl - nbgp
2488	lb%nnx = lb%nnx + nbgp
2489	ENDIF
2490	IF ( myidx == npex-1 .OR. npex == -1 ) THEN ! npex == 1 if -D__parallel not set
2491	lb%nxr = lb%nxr + nbgp
2492	lb%nnx = lb%nnx + nbgp
2493	ENDIF
2494	IF ( myidy == 0 ) THEN
2495	lb%nys = lb%nys - nbgp
2496	lb%nny = lb%nny + nbgp
2497	ENDIF
2498	IF ( myidy == npey-1 .OR. npey == -1 ) THEN ! npey == 1 if -D__parallel not set
2499	lb%nyn = lb%nyn + nbgp
2500	lb%nny = lb%nny + nbgp
2501	ENDIF
2502
2503	CALL sm_io%sm_adjust_outer_boundary()
2504
2505	ELSE
2506
2507	lb%nxl = nxl
2508	lb%nxr = nxr
2509	lb%nys = nys
2510	lb%nyn = nyn
2511	lb%nnx = nnx
2512	lb%nny = nny
2513	lb%nx = nx
2514	lb%ny = ny
2515
2516	ENDIF
2517
2518	IF ( sm_io%is_sm_active() ) THEN
2519	#if defined( __parallel )
2520	CALL sm_io%sm_allocate_shared( array_2d, sm_io%io_grid%nxl, sm_io%io_grid%nxr, &
2521	sm_io%io_grid%nys, sm_io%io_grid%nyn, win_2dr )
2522	CALL sm_io%sm_allocate_shared( array_2di, save_io_grid%nxl, save_io_grid%nxr, &
2523	save_io_grid%nys, save_io_grid%nyn, win_2di )
2524	CALL sm_io%sm_allocate_shared( array_3d, nzb, nzt+1, sm_io%io_grid%nxl, sm_io%io_grid%nxr, &
2525	sm_io%io_grid%nys, sm_io%io_grid%nyn, win_3dr )
2526	#endif
2527	ELSE
2528	ALLOCATE( array_2d(lb%nxl:lb%nxr,lb%nys:lb%nyn) )
2529	ALLOCATE( array_2di(nxl:nxr,nys:nyn) )
2530	ALLOCATE( array_3d(nzb:nzt+1,lb%nxl:lb%nxr,lb%nys:lb%nyn) )
2531	sm_io%io_grid = lb
2532	ENDIF
2533
2534	!
2535	!-- Create filetype for 2d-REAL array with ghost layers around the total domain
2536	dims2(1) = lb%nx + 1
2537	dims2(2) = lb%ny + 1
2538
2539	lize2(1) = sm_io%io_grid%nnx
2540	lize2(2) = sm_io%io_grid%nny
2541
2542	start2(1) = sm_io%io_grid%nxl
2543	start2(2) = sm_io%io_grid%nys
2544
2545	#if defined( __parallel )
2546	IF ( sm_io%iam_io_pe ) THEN
2547	CALL MPI_TYPE_CREATE_SUBARRAY( 2, dims2, lize2, start2, MPI_ORDER_FORTRAN, MPI_REAL, &
2548	ft_2d, ierr )
2549	CALL MPI_TYPE_COMMIT( ft_2d, ierr )
2550	ENDIF
2551	#endif
2552	!
2553	!-- Create filetype for 2d-INTEGER array without ghost layers around the total domain
2554	dims2(1) = nx + 1
2555	dims2(2) = ny + 1
2556
2557	IF ( sm_io%is_sm_active() ) THEN
2558
2559	lize2(1) = save_io_grid%nnx
2560	lize2(2) = save_io_grid%nny
2561
2562	start2(1) = save_io_grid%nxl
2563	start2(2) = save_io_grid%nys
2564
2565	ELSE
2566
2567	lize2(1) = nnx
2568	lize2(2) = nny
2569
2570	start2(1) = nxl
2571	start2(2) = nys
2572
2573	ENDIF
2574
2575	#if defined( __parallel )
2576	IF ( sm_io%iam_io_pe ) THEN
2577	CALL MPI_TYPE_CREATE_SUBARRAY( 2, dims2, lize2, start2, MPI_ORDER_FORTRAN, MPI_INTEGER, &
2578	ft_2di_nb, ierr )
2579	CALL MPI_TYPE_COMMIT( ft_2di_nb, ierr )
2580	ENDIF
2581	#endif
2582	!
2583	!-- Create filetype for 3d-REAL array
2584	dims3(1) = nz + 2
2585	dims3(2) = lb%nx + 1
2586	dims3(3) = lb%ny + 1
2587
2588	lize3(1) = dims3(1)
2589	lize3(2) = sm_io%io_grid%nnx
2590	lize3(3) = sm_io%io_grid%nny
2591
2592	start3(1) = nzb
2593	start3(2) = sm_io%io_grid%nxl
2594	start3(3) = sm_io%io_grid%nys
2595
2596	#if defined( __parallel )
2597	IF ( sm_io%iam_io_pe ) THEN
2598	CALL MPI_TYPE_CREATE_SUBARRAY( 3, dims3, lize3, start3, MPI_ORDER_FORTRAN, MPI_REAL, ft_3d, &
2599	ierr )
2600	CALL MPI_TYPE_COMMIT( ft_3d, ierr )
2601	ENDIF
2602	#endif
2603
2604	END SUBROUTINE rd_mpi_io_create_filetypes
2605
2606
2607
2608	!--------------------------------------------------------------------------------------------------!
2609	! Description:
2610	! ------------
2611	!> This subroutine creates file types to access 3d-soil arrays
2612	!> distributed in blocks among processes to a single file that contains the global arrays.
2613	!> It is not required for the serial mode.
2614	!--------------------------------------------------------------------------------------------------!
2615	#if defined( __parallel )
2616	SUBROUTINE rd_mpi_io_create_filetypes_3dsoil( nzb_soil, nzt_soil )
2617
2618	IMPLICIT NONE
2619
2620	INTEGER, INTENT(IN) :: nzb_soil
2621	INTEGER, INTENT(IN) :: nzt_soil
2622
2623	INTEGER, DIMENSION(3) :: dims3
2624	INTEGER, DIMENSION(3) :: lize3
2625	INTEGER, DIMENSION(3) :: start3
2626
2627
2628	IF ( sm_io%is_sm_active() ) THEN
2629	CALL sm_io%sm_allocate_shared( array_3d_soil, nzb_soil, nzt_soil, sm_io%io_grid%nxl, &
2630	sm_io%io_grid%nxr, sm_io%io_grid%nys, sm_io%io_grid%nyn, &
2631	win_3ds )
2632	ELSE
2633	ALLOCATE( array_3d_soil(nzb_soil:nzt_soil,lb%nxl:lb%nxr,lb%nys:lb%nyn) )
2634	sm_io%io_grid = lb
2635	ENDIF
2636
2637	!
2638	!-- Create filetype for 3d-soil array
2639	dims3(1) = nzt_soil - nzb_soil + 1
2640	dims3(2) = lb%nx + 1
2641	dims3(3) = lb%ny + 1
2642
2643	lize3(1) = dims3(1)
2644	lize3(2) = sm_io%io_grid%nnx
2645	lize3(3) = sm_io%io_grid%nny
2646
2647	start3(1) = nzb_soil
2648	start3(2) = sm_io%io_grid%nxl
2649	start3(3) = sm_io%io_grid%nys
2650
2651	IF ( sm_io%iam_io_pe ) THEN
2652	CALL MPI_TYPE_CREATE_SUBARRAY( 3, dims3, lize3, start3, MPI_ORDER_FORTRAN, MPI_REAL, &
2653	ft_3dsoil, ierr )
2654	CALL MPI_TYPE_COMMIT( ft_3dsoil, ierr )
2655	ENDIF
2656
2657	END SUBROUTINE rd_mpi_io_create_filetypes_3dsoil
2658	#endif
2659
2660
2661
2662	!--------------------------------------------------------------------------------------------------!
2663	! Description:
2664	! ------------
2665	!> Free all file types that have been created for MPI-IO.
2666	!--------------------------------------------------------------------------------------------------!
2667	SUBROUTINE rd_mpi_io_free_filetypes
2668
2669	IMPLICIT NONE
2670
2671
2672	#if defined( __parallel )
2673	IF ( filetypes_created ) THEN
2674
2675	IF ( sm_io%iam_io_pe ) THEN
2676	CALL MPI_TYPE_FREE( ft_2d, ierr )
2677	CALL MPI_TYPE_FREE( ft_2di_nb, ierr )
2678	CALL MPI_TYPE_FREE( ft_3d, ierr )
2679	ENDIF
2680
2681	IF ( sm_io%is_sm_active() ) THEN
2682	CALL sm_io%sm_free_shared( win_2dr )
2683	CALL sm_io%sm_free_shared( win_2di )
2684	CALL sm_io%sm_free_shared( win_3dr )
2685	ELSE
2686	DEALLOCATE( array_2d, array_2di, array_3d )
2687	ENDIF
2688
2689	ENDIF
2690	!
2691	!-- Free last surface filetype
2692	IF ( sm_io%iam_io_pe .AND. ft_surf /= -1 ) THEN
2693	CALL MPI_TYPE_FREE( ft_surf, ierr )
2694	ENDIF
2695
2696	IF ( sm_io%is_sm_active() .AND. win_surf /= -1 ) THEN
2697	CALL sm_io%sm_free_shared( win_surf )
2698	ENDIF
2699
2700	ft_surf = -1
2701	win_surf = -1
2702	#else
2703	DEALLOCATE( array_2d, array_2di, array_3d )
2704	#endif
2705
2706	END SUBROUTINE rd_mpi_io_free_filetypes
2707
2708
2709
2710	!--------------------------------------------------------------------------------------------------!
2711	! Description:
2712	! ------------
2713	!> Print the restart data file header (MPI-IO format) for debugging.
2714	!--------------------------------------------------------------------------------------------------!
2715	SUBROUTINE rd_mpi_io_print_header
2716
2717	IMPLICIT NONE
2718
2719	INTEGER(iwp) :: i
2720
2721
2722	WRITE (9,*) 'header position after reading the restart file header: ', header_position
2723	WRITE (9,*) ' '
2724	WRITE (9,*) 'restart file header content:'
2725	WRITE (9,*) '----------------------------'
2726	WRITE (9,*) ' '
2727
2728	WRITE (9,*) ' CHARACTER header values Total number: ', tgh%nr_char
2729	WRITE (9,*) ' '
2730	DO i = 1, tgh%nr_char
2731	WRITE( 9, '(I3,A,1X,A)' ) i, ': ', text_lines(i)(1:80)
2732	ENDDO
2733	WRITE (9,*) ' '
2734
2735	WRITE (9,*) ' INTEGER header variables and values Total number: ', tgh%nr_int
2736	WRITE (9,*) ' '
2737	DO i = 1, tgh%nr_int
2738	WRITE(9,*) ' variable: ', int_names(i), ' value: ', int_values(i)
2739	ENDDO
2740	WRITE (9,*) ' '
2741
2742	WRITE (9,*) ' REAL header variables and values Total number: ', tgh%nr_real
2743	WRITE (9,*) ' '
2744	DO i = 1, tgh%nr_real
2745	WRITE(9,*) ' variable: ', real_names(i), ' value: ', real_values(i)
2746	ENDDO
2747	WRITE (9,*) ' '
2748
2749	WRITE (9,*) ' Header entries with offset (2d/3d arrays) Total number: ', tgh%nr_arrays
2750	WRITE (9,*) ' '
2751	DO i = 1, tgh%nr_arrays
2752	WRITE(9,*) ' variable: ', array_names(i), ' offset: ', array_offset(i)
2753	ENDDO
2754	WRITE (9,*) ' '
2755
2756	END SUBROUTINE rd_mpi_io_print_header
2757
2758
2759
2760	!--------------------------------------------------------------------------------------------------!
2761	! Description:
2762	! ------------
2763	!> Check if big/little endian data format is used.
2764	!> An int4 pointer is set to a int8 variable, the int*8 is set to 1, and then it is checked, if
2765	!> the first 4 bytes of the pointer are equal 1 (little endian) or not.
2766	!--------------------------------------------------------------------------------------------------!
2767	SUBROUTINE rd_mpi_io_check_endian( i_endian )
2768
2769	IMPLICIT NONE
2770
2771	INTEGER, INTENT(out) :: i_endian
2772	INTEGER(KIND=8), TARGET :: int8
2773
2774	INTEGER, DIMENSION(1) :: bufshape
2775	INTEGER(KIND=4), POINTER, DIMENSION(:) :: int4
2776
2777	TYPE(C_PTR) :: ptr
2778
2779
2780	ptr = C_LOC( int8 )
2781	bufshape(1) = 2
2782	CALL C_F_POINTER( ptr, int4, bufshape )
2783
2784	int8 = 1
2785
2786	IF ( int4(1) == 1 ) THEN
2787	i_endian = 1 ! little endian
2788	ELSE
2789	i_endian = 2 ! big endian
2790	ENDIF
2791
2792	END SUBROUTINE rd_mpi_io_check_endian
2793
2794	END MODULE restart_data_mpi_io_mod

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |