Home

Context Navigation

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

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