Home

Context Navigation

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

Last change on this file since 4562 was 4539, checked in by raasch, 5 years ago
checks added, if index limits in header are exceeded (restart_data_mpi_io_mod), bugfix in rrd_mpi_io_int_2d, location and log_point names added/modified, cpu time per grid point and timestep does not included initialization and spinup any more (cpulog_mod)
Property svn:keywords set to `Id`
File size: 94.3 KB

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