Home

Context Navigation

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

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