Home

Context Navigation

source: palm/trunk/SOURCE/data_output_module.f90 @ 4129

Last change on this file since 4129 was 4124, checked in by gronemeier, 5 years ago
remove unused variables
Property svn:keywords set to `Id`
File size: 174.1 KB

Line
1	!> @file data_output_module.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
6	! terms of the GNU General Public License as published by the Free Software
7	! Foundation, either version 3 of the License, or (at your option) any later
8	! version.
9	!
10	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
13	!
14	! You should have received a copy of the GNU General Public License along with
15	! PALM. If not, see <http://www.gnu.org/licenses/>.
16	!
17	! Copyright 2019-2019 Leibniz Universitaet Hannover
18	!--------------------------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: data_output_module.f90 4124 2019-07-26 14:22:39Z gronemeier $
27	! Initial revision
28	!
29	!
30	! Authors:
31	! --------
32	!> @author Tobias Gronemeier
33	!> @author Helge Knoop
34	!
35	!--------------------------------------------------------------------------------------------------!
36	! Description:
37	! ------------
38	!> Data-output module to handle output of variables into output files.
39	!>
40	!> The module first creates an interal database containing all meta data of all
41	!> output quantities. Output files are then inititialized and prepared for
42	!> storing data, which are finally written to file.
43	!>
44	!> @todo Convert variable if type of given values do not fit specified type.
45	!> @todo Remove iwp from index (and similar) variables.
46	!--------------------------------------------------------------------------------------------------!
47	MODULE data_output_module
48
49	USE kinds
50
51	USE data_output_netcdf4_module, &
52	ONLY: netcdf4_init_dimension, &
53	netcdf4_get_error_message, &
54	netcdf4_init_end, &
55	netcdf4_init_module, &
56	netcdf4_init_variable, &
57	netcdf4_finalize, &
58	netcdf4_open_file, &
59	netcdf4_write_attribute, &
60	netcdf4_write_variable
61
62	USE data_output_binary_module, &
63	ONLY: binary_finalize, &
64	binary_get_error_message, &
65	binary_init_dimension, &
66	binary_init_end, &
67	binary_init_module, &
68	binary_init_variable, &
69	binary_open_file, &
70	binary_write_attribute, &
71	binary_write_variable
72
73	IMPLICIT NONE
74
75	INTEGER(iwp), PARAMETER :: charlen = 100_iwp !< maximum length of character variables
76
77	TYPE attribute_type
78	CHARACTER(LEN=charlen) :: data_type = '' !< data type
79	CHARACTER(LEN=charlen) :: name !< attribute name
80	CHARACTER(LEN=charlen) :: value_char !< attribute value if character
81	INTEGER(KIND=1) :: value_int8 !< attribute value if 8bit integer
82	INTEGER(KIND=2) :: value_int16 !< attribute value if 16bit integer
83	INTEGER(KIND=4) :: value_int32 !< attribute value if 32bit integer
84	REAL(KIND=4) :: value_real32 !< attribute value if 32bit real
85	REAL(KIND=8) :: value_real64 !< attribute value if 64bit real
86	END TYPE attribute_type
87
88	TYPE variable_type
89	CHARACTER(LEN=charlen) :: data_type = '' !< data type
90	CHARACTER(LEN=charlen) :: name !< variable name
91	INTEGER(iwp) :: id = -1 !< id within file
92	LOGICAL :: is_global = .FALSE. !< true if global variable
93	CHARACTER(LEN=charlen), DIMENSION(:), ALLOCATABLE :: dimension_names !< list of dimension names
94	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: dimension_ids !< list of dimension ids
95	TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes
96	END TYPE variable_type
97
98	TYPE dimension_type
99	CHARACTER(LEN=charlen) :: data_type = '' !< data type
100	CHARACTER(LEN=charlen) :: name !< dimension name
101	INTEGER(iwp) :: id = -1 !< dimension id within file
102	INTEGER(iwp) :: length !< length of dimension
103	INTEGER(iwp) :: length_mask !< length of masked dimension
104	INTEGER(iwp) :: var_id = -1 !< associated variable id within file
105	LOGICAL :: is_masked = .FALSE. !< true if masked
106	INTEGER(iwp), DIMENSION(2) :: bounds !< lower and upper bound of dimension
107	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: masked_indices !< list of masked indices of dimension
108	INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: masked_values_int8 !< masked dimension values if 16bit integer
109	INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: masked_values_int16 !< masked dimension values if 16bit integer
110	INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_int32 !< masked dimension values if 32bit integer
111	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: masked_values_intwp !< masked dimension values if working-precision int
112	INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: values_int8 !< dimension values if 16bit integer
113	INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: values_int16 !< dimension values if 16bit integer
114	INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: values_int32 !< dimension values if 32bit integer
115	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: values_intwp !< dimension values if working-precision integer
116	LOGICAL, DIMENSION(:), ALLOCATABLE :: mask !< mask
117	REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_real32 !< masked dimension values if 32bit real
118	REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: masked_values_real64 !< masked dimension values if 64bit real
119	REAL(wp), DIMENSION(:), ALLOCATABLE :: masked_values_realwp !< masked dimension values if working-precision real
120	REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: values_real32 !< dimension values if 32bit real
121	REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: values_real64 !< dimension values if 64bit real
122	REAL(wp), DIMENSION(:), ALLOCATABLE :: values_realwp !< dimension values if working-precision real
123	TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes
124	END TYPE dimension_type
125
126	TYPE file_type
127	CHARACTER(LEN=charlen) :: format = '' !< file format
128	CHARACTER(LEN=charlen) :: name = '' !< file name
129	INTEGER(iwp) :: id = -1 !< id of file
130	LOGICAL :: is_init = .FALSE. !< true if initialized
131	TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes
132	TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dimensions !< list of dimensions
133	TYPE(variable_type), DIMENSION(:), ALLOCATABLE :: variables !< list of variables
134	END TYPE file_type
135
136
137	CHARACTER(LEN=charlen) :: output_file_format = 'binary' !< file format (namelist parameter)
138	CHARACTER(LEN=charlen) :: output_file_suffix = '' !< file suffix added to each file name
139
140	CHARACTER(LEN=800) :: internal_error_message = '' !< string containing the last error message
141	CHARACTER(LEN=800) :: temp_string !< dummy string
142
143	INTEGER(iwp) :: debug_output_unit !< Fortran Unit Number of the debug-output file
144	INTEGER :: nf = 0 !< number of files
145	INTEGER :: master_rank = 0 !< master rank for tasks to be executed by single PE only
146	INTEGER :: output_group_comm !< MPI communicator addressing all MPI ranks which participate in output
147
148	INTEGER(iwp), PARAMETER :: no_var_id = -1 !< value of var_id if no variable is selected
149
150	LOGICAL :: print_debug_output = .FALSE. !< if true, debug output is printed
151
152	TYPE(file_type), DIMENSION(:), ALLOCATABLE :: files !< file list
153
154	SAVE
155
156	PRIVATE
157
158	!> Initialize the data-output module
159	INTERFACE dom_init
160	MODULE PROCEDURE dom_init
161	END INTERFACE dom_init
162
163	!> Add files to database
164	INTERFACE dom_def_file
165	MODULE PROCEDURE dom_def_file
166	END INTERFACE dom_def_file
167
168	!> Add dimensions to database
169	INTERFACE dom_def_dim
170	MODULE PROCEDURE dom_def_dim
171	END INTERFACE dom_def_dim
172
173	!> Add variables to database
174	INTERFACE dom_def_var
175	MODULE PROCEDURE dom_def_var
176	END INTERFACE dom_def_var
177
178	!> Add attributes to database
179	INTERFACE dom_def_att
180	MODULE PROCEDURE dom_def_att_char
181	MODULE PROCEDURE dom_def_att_int8
182	MODULE PROCEDURE dom_def_att_int16
183	MODULE PROCEDURE dom_def_att_int32
184	MODULE PROCEDURE dom_def_att_real32
185	MODULE PROCEDURE dom_def_att_real64
186	END INTERFACE dom_def_att
187
188	!> Prepare for output: evaluate database and create files
189	INTERFACE dom_start_output
190	MODULE PROCEDURE dom_start_output
191	END INTERFACE dom_start_output
192
193	!> Write variables to file
194	INTERFACE dom_write_var
195	MODULE PROCEDURE dom_write_var
196	END INTERFACE dom_write_var
197
198	!> Last actions required for output befor termination
199	INTERFACE dom_finalize_output
200	MODULE PROCEDURE dom_finalize_output
201	END INTERFACE dom_finalize_output
202
203	!> Return error message
204	INTERFACE dom_get_error_message
205	MODULE PROCEDURE dom_get_error_message
206	END INTERFACE dom_get_error_message
207
208	PUBLIC &
209	dom_database_debug_output, &
210	dom_def_att, &
211	dom_def_dim, &
212	dom_def_file, &
213	dom_def_var, &
214	dom_finalize_output, &
215	dom_get_error_message, &
216	dom_init, &
217	dom_start_output, &
218	dom_write_var
219
220	CONTAINS
221
222
223	!--------------------------------------------------------------------------------------------------!
224	! Description:
225	! ------------
226	!> Initialize data-output module
227	!--------------------------------------------------------------------------------------------------!
228	SUBROUTINE dom_init( file_suffix_of_output_group, mpi_comm_of_output_group, master_output_rank, &
229	program_debug_output_unit, debug_output )
230
231	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_suffix_of_output_group !< file-name suffix added to each file;
232	!> must be unique for each output group
233
234	INTEGER, INTENT(IN), OPTIONAL :: master_output_rank !< MPI rank executing tasks which must
235	!> be executed by a single PE only
236	INTEGER, INTENT(IN) :: mpi_comm_of_output_group !< MPI communicator specifying the MPI group
237	!> which participate in the output
238	INTEGER, INTENT(IN) :: program_debug_output_unit !< file unit number for debug output
239
240	LOGICAL, INTENT(IN) :: debug_output !< if true, debug output is printed
241
242
243	IF ( PRESENT( file_suffix_of_output_group ) ) output_file_suffix = file_suffix_of_output_group
244	IF ( PRESENT( master_output_rank ) ) master_rank = master_output_rank
245
246	output_group_comm = mpi_comm_of_output_group
247
248	debug_output_unit = program_debug_output_unit
249	print_debug_output = debug_output
250
251	CALL binary_init_module( output_file_suffix, output_group_comm, master_rank, &
252	debug_output_unit, debug_output, no_var_id )
253
254	CALL netcdf4_init_module( output_file_suffix, output_group_comm, master_rank, &
255	debug_output_unit, debug_output, no_var_id )
256
257	END SUBROUTINE dom_init
258
259	!--------------------------------------------------------------------------------------------------!
260	! Description:
261	! ------------
262	!> Debugging output. Print contents of output database to debug_output_unit.
263	!--------------------------------------------------------------------------------------------------!
264	SUBROUTINE dom_database_debug_output
265
266	CHARACTER(LEN=*), PARAMETER :: separation_string = '---' !< string separating blocks in output
267	CHARACTER(LEN=50) :: format1 !< format for write statements
268	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_database_debug_output' !< name of this routine
269
270	INTEGER :: f !< loop index
271	INTEGER, PARAMETER :: indent_depth = 3 !< space per indentation
272	INTEGER :: indent_level !< indentation level
273	INTEGER, PARAMETER :: max_keyname_length = 6 !< length of longest key name
274	INTEGER :: natt !< number of attributes
275	INTEGER :: ndim !< number of dimensions
276	INTEGER :: nvar !< number of variables
277
278
279	CALL internal_message( 'debug', routine_name // ': write data base to debug output' )
280
281	WRITE( debug_output_unit, '(A)' ) 'DOM data base:'
282	WRITE( debug_output_unit, '(A)' ) REPEAT( separation_string // ' ', 4 )
283
284	IF ( .NOT. ALLOCATED( files ) .OR. nf == 0 ) THEN
285
286	WRITE( debug_output_unit, '(A)' ) 'database is empty'
287
288	ELSE
289
290	indent_level = 1
291	WRITE( format1, '(A,I3,A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A,T', &
292	indent_level * indent_depth + 1 + max_keyname_length, &
293	',(": ")'
294
295	DO f = 1, nf
296
297	natt = 0
298	ndim = 0
299	nvar = 0
300	IF ( ALLOCATED( files(f)%attributes ) ) natt = SIZE( files(f)%attributes )
301	IF ( ALLOCATED( files(f)%dimensions ) ) ndim = SIZE( files(f)%dimensions )
302	IF ( ALLOCATED( files(f)%variables ) ) nvar = SIZE( files(f)%variables )
303
304	WRITE( debug_output_unit, '(A)' ) 'file:'
305	WRITE( debug_output_unit, TRIM( format1 ) // ',A)' ) 'name', TRIM( files(f)%name )
306	WRITE( debug_output_unit, TRIM( format1 ) // ',A)' ) 'format', TRIM( files(f)%format )
307	WRITE( debug_output_unit, TRIM( format1 ) // ',I7)' ) 'id', files(f)%id
308	WRITE( debug_output_unit, TRIM( format1 ) // ',L1)' ) 'is init', files(f)%is_init
309	WRITE( debug_output_unit, TRIM( format1 ) // ',I7)' ) '#atts', natt
310	WRITE( debug_output_unit, TRIM( format1 ) // ',I7)' ) '#dims', ndim
311	WRITE( debug_output_unit, TRIM( format1 ) // ',I7)' ) '#vars', nvar
312
313	IF ( natt /= 0 ) CALL print_attributes( indent_level, files(f)%attributes )
314	IF ( ndim /= 0 ) CALL print_dimensions( indent_level, files(f)%dimensions )
315	IF ( nvar /= 0 ) CALL print_variables( indent_level, files(f)%variables )
316
317	WRITE( debug_output_unit, '(/A/)' ) REPEAT( separation_string // ' ', 4 )
318
319	ENDDO
320
321	ENDIF
322
323	CONTAINS
324
325	!--------------------------------------------------------------------------------------------!
326	! Description:
327	! ------------
328	!> Print list of attributes.
329	!--------------------------------------------------------------------------------------------!
330	SUBROUTINE print_attributes( indent_level, attributes )
331
332	CHARACTER(LEN=50) :: format1 !< format for write statements
333	CHARACTER(LEN=50) :: format2 !< format for write statements
334
335	INTEGER :: i !< loop index
336	INTEGER, INTENT(IN) :: indent_level !< indentation level
337	INTEGER, PARAMETER :: max_keyname_length = 6 !< length of longest key name
338	INTEGER :: nelement !< number of elements to print
339
340	TYPE(attribute_type), DIMENSION(:), INTENT(IN) :: attributes !< list of attributes
341
342
343	WRITE( format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
344	WRITE( format2, '(A,I3,A,I3,A)' ) &
345	'(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
346	( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
347
348	WRITE( debug_output_unit, TRIM( format1 ) // ',A)' ) REPEAT( separation_string // ' ', 4 )
349	WRITE( debug_output_unit, TRIM( format1 ) // ')' ) 'attributes:'
350
351	nelement = SIZE( attributes )
352	DO i = 1, nelement
353	WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
354	'name', TRIM( attributes(i)%name )
355	WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
356	'type', TRIM( attributes(i)%data_type )
357
358	IF ( TRIM( attributes(i)%data_type ) == 'char' ) THEN
359	WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
360	'value', TRIM( attributes(i)%value_char )
361	ELSEIF ( TRIM( attributes(i)%data_type ) == 'int8' ) THEN
362	WRITE( debug_output_unit, TRIM( format2 ) // ',I4)' ) &
363	'value', attributes(i)%value_int8
364	ELSEIF ( TRIM( attributes(i)%data_type ) == 'int16' ) THEN
365	WRITE( debug_output_unit, TRIM( format2 ) // ',I6)' ) &
366	'value', attributes(i)%value_int16
367	ELSEIF ( TRIM( attributes(i)%data_type ) == 'int32' ) THEN
368	WRITE( debug_output_unit, TRIM( format2 ) // ',I11)' ) &
369	'value', attributes(i)%value_int32
370	ELSEIF ( TRIM( attributes(i)%data_type ) == 'real32' ) THEN
371	WRITE( debug_output_unit, TRIM( format2 ) // ',E14.7)' ) &
372	'value', attributes(i)%value_real32
373	ELSEIF ( TRIM(attributes(i)%data_type) == 'real64' ) THEN
374	WRITE( debug_output_unit, TRIM( format2 ) // ',E22.15)' ) &
375	'value', attributes(i)%value_real64
376	ENDIF
377	IF ( i < nelement ) &
378	WRITE( debug_output_unit, TRIM( format1 ) // ')' ) separation_string
379	ENDDO
380
381	END SUBROUTINE print_attributes
382
383	!--------------------------------------------------------------------------------------------!
384	! Description:
385	! ------------
386	!> Print list of dimensions.
387	!--------------------------------------------------------------------------------------------!
388	SUBROUTINE print_dimensions( indent_level, dimensions )
389
390	CHARACTER(LEN=50) :: format1 !< format for write statements
391	CHARACTER(LEN=50) :: format2 !< format for write statements
392
393	INTEGER :: i !< loop index
394	INTEGER, INTENT(IN) :: indent_level !< indentation level
395	INTEGER :: j !< loop index
396	INTEGER, PARAMETER :: max_keyname_length = 15 !< length of longest key name
397	INTEGER :: nelement !< number of elements to print
398
399	LOGICAL :: is_masked !< true if dimension is masked
400
401	TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< list of dimensions
402
403
404	WRITE( format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
405	WRITE( format2, '(A,I3,A,I3,A)' ) &
406	'(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
407	( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
408
409	WRITE( debug_output_unit, TRIM( format1 ) // ',A)' ) REPEAT( separation_string // ' ', 4 )
410	WRITE( debug_output_unit, TRIM( format1 ) // ')' ) 'dimensions:'
411
412	nelement = SIZE( dimensions )
413	DO i = 1, nelement
414	is_masked = dimensions(i)%is_masked
415
416	!-- Print general information
417	WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
418	'name', TRIM( dimensions(i)%name )
419	WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
420	'type', TRIM( dimensions(i)%data_type )
421	WRITE( debug_output_unit, TRIM( format2 ) // ',I7)' ) &
422	'id', dimensions(i)%id
423	WRITE( debug_output_unit, TRIM( format2 ) // ',I7)' ) &
424	'length', dimensions(i)%length
425	WRITE( debug_output_unit, TRIM( format2 ) // ',I7,A,I7)' ) &
426	'bounds', dimensions(i)%bounds(1), ',', dimensions(i)%bounds(2)
427	WRITE( debug_output_unit, TRIM( format2 ) // ',L1)' ) &
428	'is masked', dimensions(i)%is_masked
429
430	!-- Print information about mask
431	IF ( is_masked ) THEN
432	WRITE( debug_output_unit, TRIM( format2 ) // ',I7)' ) &
433	'masked length', dimensions(i)%length_mask
434
435	WRITE( debug_output_unit, TRIM( format2 ) // ',L1)', ADVANCE='no' ) &
436	'mask', dimensions(i)%mask(dimensions(i)%bounds(1))
437	DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
438	WRITE( debug_output_unit, '(A,L1)', ADVANCE='no' ) ',', dimensions(i)%mask(j)
439	ENDDO
440	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
441
442	WRITE( debug_output_unit, TRIM( format2 ) // ',I6)', ADVANCE='no' ) &
443	'masked indices', dimensions(i)%masked_indices(0)
444	DO j = 1, dimensions(i)%length_mask-1
445	WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
446	',', dimensions(i)%masked_indices(j)
447	ENDDO
448	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
449	ENDIF
450
451	!-- Print saved values
452	IF ( ALLOCATED( dimensions(i)%values_int8 ) ) THEN
453
454	WRITE( debug_output_unit, TRIM( format2 ) // ',I4)', ADVANCE='no' ) &
455	'values', dimensions(i)%values_int8(dimensions(i)%bounds(1))
456	DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
457	WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) &
458	',', dimensions(i)%values_int8(j)
459	ENDDO
460	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
461	IF ( is_masked ) THEN
462	WRITE( debug_output_unit, TRIM( format2 ) // ',I4)', ADVANCE='no' ) &
463	'masked values', dimensions(i)%masked_values_int8(0)
464	DO j = 1, dimensions(i)%length_mask-1
465	WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) &
466	',', dimensions(i)%masked_values_int8(j)
467	ENDDO
468	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
469	ENDIF
470
471	ELSEIF ( ALLOCATED( dimensions(i)%values_int16 ) ) THEN
472
473	WRITE( debug_output_unit, TRIM( format2 ) // ',I6)', ADVANCE='no' ) &
474	'values', dimensions(i)%values_int16(dimensions(i)%bounds(1))
475	DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
476	WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
477	',', dimensions(i)%values_int16(j)
478	ENDDO
479	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
480	IF ( is_masked ) THEN
481	WRITE( debug_output_unit, TRIM( format2 ) // ',I6)', ADVANCE='no' ) &
482	'masked values', dimensions(i)%masked_values_int16(0)
483	DO j = 1, dimensions(i)%length_mask-1
484	WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
485	',', dimensions(i)%masked_values_int16(j)
486	ENDDO
487	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
488	ENDIF
489
490	ELSEIF ( ALLOCATED( dimensions(i)%values_int32 ) ) THEN
491
492	WRITE( debug_output_unit, TRIM( format2 ) // ',I11)', ADVANCE='no' ) &
493	'values', dimensions(i)%values_int32(dimensions(i)%bounds(1))
494	DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
495	WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
496	',', dimensions(i)%values_int32(j)
497	ENDDO
498	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
499	IF ( is_masked ) THEN
500	WRITE( debug_output_unit, TRIM( format2 ) // ',I11)', ADVANCE='no' ) &
501	'masked values', dimensions(i)%masked_values_int32(0)
502	DO j = 1, dimensions(i)%length_mask-1
503	WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
504	',', dimensions(i)%masked_values_int32(j)
505	ENDDO
506	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
507	ENDIF
508
509	ELSEIF ( ALLOCATED( dimensions(i)%values_intwp ) ) THEN
510
511	WRITE( debug_output_unit, TRIM( format2 ) // ',I11)', ADVANCE='no' ) &
512	'values', dimensions(i)%values_intwp(dimensions(i)%bounds(1))
513	DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
514	WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
515	',', dimensions(i)%values_intwp(j)
516	ENDDO
517	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
518	IF ( is_masked ) THEN
519	WRITE( debug_output_unit, TRIM( format2 ) // ',I11)', ADVANCE='no' ) &
520	'masked values', dimensions(i)%masked_values_intwp(0)
521	DO j = 1, dimensions(i)%length_mask-1
522	WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
523	',', dimensions(i)%masked_values_intwp(j)
524	ENDDO
525	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
526	ENDIF
527
528	ELSEIF ( ALLOCATED( dimensions(i)%values_real32 ) ) THEN
529
530	WRITE( debug_output_unit, TRIM( format2 ) // ',E14.7)', ADVANCE='no' ) &
531	'values', dimensions(i)%values_real32(dimensions(i)%bounds(1))
532	DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
533	WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) &
534	',', dimensions(i)%values_real32(j)
535	ENDDO
536	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
537	IF ( is_masked ) THEN
538	WRITE( debug_output_unit, TRIM( format2 ) // ',E14.7)', ADVANCE='no' ) &
539	'masked values', dimensions(i)%masked_values_real32(0)
540	DO j = 1, dimensions(i)%length_mask-1
541	WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) &
542	',', dimensions(i)%masked_values_real32(j)
543	ENDDO
544	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
545	ENDIF
546
547	ELSEIF ( ALLOCATED( dimensions(i)%values_real64 ) ) THEN
548
549	WRITE( debug_output_unit, TRIM( format2 ) // ',E22.15)', ADVANCE='no' ) &
550	'values', dimensions(i)%values_real64(dimensions(i)%bounds(1))
551	DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
552	WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
553	',', dimensions(i)%values_real64(j)
554	ENDDO
555	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
556	IF ( is_masked ) THEN
557	WRITE( debug_output_unit, TRIM( format2 ) // ',E22.15)', ADVANCE='no' ) &
558	'masked values', dimensions(i)%masked_values_real64(0)
559	DO j = 1, dimensions(i)%length_mask-1
560	WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
561	',', dimensions(i)%masked_values_real64(j)
562	ENDDO
563	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
564	ENDIF
565
566	ELSEIF ( ALLOCATED( dimensions(i)%values_realwp ) ) THEN
567
568	WRITE( debug_output_unit, TRIM( format2 ) // ',E22.15)', ADVANCE='no' ) &
569	'values', dimensions(i)%values_realwp(dimensions(i)%bounds(1))
570	DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
571	WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
572	',', dimensions(i)%values_realwp(j)
573	ENDDO
574	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
575	IF ( is_masked ) THEN
576	WRITE( debug_output_unit, TRIM( format2 ) // ',E22.15)', ADVANCE='no' ) &
577	'masked values', dimensions(i)%masked_values_realwp(0)
578	DO j = 1, dimensions(i)%length_mask-1
579	WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
580	',', dimensions(i)%masked_values_realwp(j)
581	ENDDO
582	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
583	ENDIF
584
585	ENDIF
586
587	IF ( ALLOCATED( dimensions(i)%attributes ) ) &
588	CALL print_attributes( indent_level+1, dimensions(i)%attributes )
589
590	IF ( i < nelement ) &
591	WRITE( debug_output_unit, TRIM( format1 ) // ')' ) separation_string
592	ENDDO
593
594	END SUBROUTINE print_dimensions
595
596	!--------------------------------------------------------------------------------------------!
597	! Description:
598	! ------------
599	!> Print list of variables.
600	!--------------------------------------------------------------------------------------------!
601	SUBROUTINE print_variables( indent_level, variables )
602
603	CHARACTER(LEN=50) :: format1 !< format for write statements
604	CHARACTER(LEN=50) :: format2 !< format for write statements
605
606	INTEGER :: i !< loop index
607	INTEGER, INTENT(IN) :: indent_level !< indentation level
608	INTEGER :: j !< loop index
609	INTEGER, PARAMETER :: max_keyname_length = 16 !< length of longest key name
610	INTEGER :: nelement !< number of elements to print
611
612	TYPE(variable_type), DIMENSION(:), INTENT(IN) :: variables !< list of variables
613
614
615	WRITE( format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
616	WRITE( format2, '(A,I3,A,I3,A)' ) &
617	'(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
618	( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
619
620	WRITE( debug_output_unit, TRIM( format1 ) // ',A)' ) REPEAT( separation_string // ' ', 4 )
621	WRITE( debug_output_unit, TRIM( format1 ) // ')' ) 'variables:'
622
623	nelement = SIZE( variables )
624	DO i = 1, nelement
625	WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
626	'name', TRIM( variables(i)%name )
627	WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
628	'type', TRIM( variables(i)%data_type )
629	WRITE( debug_output_unit, TRIM( format2 ) // ',I7)' ) &
630	'id', variables(i)%id
631	WRITE( debug_output_unit, TRIM( format2 ) // ',L1)' ) &
632	'is global', variables(i)%is_global
633
634	WRITE( debug_output_unit, TRIM( format2 ) // ',A)', ADVANCE='no' ) &
635	'dimension names', TRIM( variables(i)%dimension_names(1) )
636	DO j = 2, SIZE( variables(i)%dimension_names )
637	WRITE( debug_output_unit, '(A,A)', ADVANCE='no' ) &
638	',', TRIM( variables(i)%dimension_names(j) )
639	ENDDO
640	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
641
642	WRITE( debug_output_unit, TRIM( format2 ) // ',I7)', ADVANCE='no' ) &
643	'dimension ids', variables(i)%dimension_ids(1)
644	DO j = 2, SIZE( variables(i)%dimension_names )
645	WRITE( debug_output_unit, '(A,I7)', ADVANCE='no' ) &
646	',', variables(i)%dimension_ids(j)
647	ENDDO
648	WRITE( debug_output_unit, '(A)' ) '' ! write line-end
649
650	IF ( ALLOCATED( variables(i)%attributes ) ) &
651	CALL print_attributes( indent_level+1, variables(i)%attributes )
652	IF ( i < nelement ) &
653	WRITE( debug_output_unit, TRIM( format1 ) // ')' ) separation_string
654	ENDDO
655
656	END SUBROUTINE print_variables
657
658	END SUBROUTINE dom_database_debug_output
659
660	!--------------------------------------------------------------------------------------------------!
661	! Description:
662	! ------------
663	!> Define output file.
664	!--------------------------------------------------------------------------------------------------!
665	FUNCTION dom_def_file( filename, format ) RESULT( return_value )
666
667	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file to be created
668	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: format !< format of file to be created
669
670	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_file' !< name of this routine
671
672	INTEGER(iwp) :: f !< loop index
673	INTEGER(iwp) :: return_value !< return value
674
675	TYPE(file_type), DIMENSION(:), ALLOCATABLE :: files_tmp !< temporary file list
676
677
678	return_value = 0
679
680	CALL internal_message( 'debug', routine_name // ': define file "' // TRIM( filename ) // '"' )
681
682	!-- Allocate file list or extend it by 1
683	IF ( .NOT. ALLOCATED( files ) ) THEN
684
685	nf = 1
686	ALLOCATE( files(nf) )
687
688	ELSE
689
690	nf = SIZE( files )
691	!-- Check if file already exists
692	DO f = 1, nf
693	IF ( files(f)%name == TRIM( filename ) ) THEN
694	return_value = 1
695	CALL internal_message( 'error', routine_name // ': file "' // TRIM( filename ) // &
696	'" already exists' )
697	EXIT
698	ENDIF
699	ENDDO
700
701	!-- Extend file list
702	IF ( return_value == 0 ) THEN
703	ALLOCATE( files_tmp(nf) )
704	files_tmp = files
705	DEALLOCATE( files )
706	nf = nf + 1
707	ALLOCATE( files(nf) )
708	files(:nf-1) = files_tmp
709	DEALLOCATE( files_tmp )
710	ENDIF
711
712	ENDIF
713
714	!-- Add new file to database
715	IF ( return_value == 0 ) THEN
716	files(nf)%name = TRIM( filename )
717	IF ( PRESENT( format ) ) THEN
718	files(nf)%format = TRIM( format )
719	ELSE
720	files(nf)%format = TRIM( output_file_format )
721	ENDIF
722	ENDIF
723
724	END FUNCTION dom_def_file
725
726	!--------------------------------------------------------------------------------------------------!
727	! Description:
728	! ------------
729	!> Define dimension of type integer.
730	!>
731	!> @todo Convert given values into selected output_type.
732	!--------------------------------------------------------------------------------------------------!
733	FUNCTION dom_def_dim( filename, name, output_type, bounds, &
734	values_int8, values_int16, values_int32, values_intwp, &
735	values_real32, values_real64, values_realwp, &
736	mask ) RESULT( return_value )
737
738	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
739	CHARACTER(LEN=*), INTENT(IN) :: name !< name of dimension
740	CHARACTER(LEN=*), INTENT(IN) :: output_type !< data type of dimension variable in output file
741
742	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_dim' !< name of this routine
743
744	INTEGER(iwp) :: d !< loop index
745	INTEGER(iwp) :: f !< loop index
746	INTEGER(iwp) :: i !< loop index
747	INTEGER(iwp) :: j !< loop index
748	INTEGER(iwp) :: ndim !< number of dimensions in file
749	INTEGER(iwp) :: return_value !< return value
750
751	INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds !< lower and upper bound of dimension variable
752
753	INTEGER(KIND=1), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int8 !< values of dimension
754	INTEGER(KIND=2), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int16 !< values of dimension
755	INTEGER(KIND=4), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int32 !< values of dimension
756	INTEGER(iwp), DIMENSION(:), INTENT(IN), OPTIONAL :: values_intwp !< values of dimension
757
758	LOGICAL, DIMENSION(:), INTENT(IN), OPTIONAL :: mask !< mask of dimesion
759
760	REAL(KIND=4), DIMENSION(:), INTENT(IN), OPTIONAL :: values_real32 !< values of dimension
761	REAL(KIND=8), DIMENSION(:), INTENT(IN), OPTIONAL :: values_real64 !< values of dimension
762	REAL(wp), DIMENSION(:), INTENT(IN), OPTIONAL :: values_realwp !< values of dimension
763
764	TYPE(dimension_type) :: dimension !< new dimension
765
766	TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dims_tmp !< temporary dimension list
767
768
769	return_value = 0
770
771	CALL internal_message( 'debug', routine_name // &
772	': define dimension "' // TRIM( name ) // &
773	'" in file "' // TRIM( filename ) // '"' )
774
775	dimension%name = TRIM( name )
776	dimension%data_type = TRIM( output_type )
777
778	!-- Check dimension bounds and allocate dimension according to bounds
779	IF ( SIZE( bounds ) == 1 ) THEN
780
781	!-- Dimension has only lower bound, which means it changes its size
782	!-- during simulation.
783	!-- Set length to -1 as indicator.
784	dimension%bounds(:) = bounds(1)
785	dimension%length = -1_iwp
786
787	IF ( PRESENT( mask ) ) THEN
788	return_value = 1
789	CALL internal_message( 'error', routine_name // &
790	': unlimited dimension "' // TRIM( name ) // &
791	'" in file "' // TRIM( filename ) // '" cannot be masked' )
792	ENDIF
793
794	ELSEIF ( SIZE( bounds ) == 2 ) THEN
795
796	dimension%bounds = bounds
797	dimension%length = bounds(2) - bounds(1) + 1
798
799	!-- Save dimension values
800	IF ( PRESENT( values_int8 ) ) THEN
801	ALLOCATE( dimension%values_int8(dimension%bounds(1):dimension%bounds(2)) )
802	IF ( SIZE( values_int8 ) == dimension%length ) THEN
803	dimension%values_int8 = values_int8
804	ELSEIF ( SIZE( values_int8 ) == 1 ) THEN
805	dimension%values_int8(:) = values_int8
806	ELSE
807	return_value = 2
808	ENDIF
809	ELSEIF( PRESENT( values_int16 ) ) THEN
810	ALLOCATE( dimension%values_int16(dimension%bounds(1):dimension%bounds(2)) )
811	IF ( SIZE( values_int16 ) == dimension%length ) THEN
812	dimension%values_int16 = values_int16
813	ELSEIF ( SIZE( values_int16 ) == 1 ) THEN
814	dimension%values_int16(:) = values_int16
815	ELSE
816	return_value = 2
817	ENDIF
818	ELSEIF( PRESENT( values_int32 ) ) THEN
819	ALLOCATE( dimension%values_int32(dimension%bounds(1):dimension%bounds(2)) )
820	IF ( SIZE( values_int32 ) == dimension%length ) THEN
821	dimension%values_int32 = values_int32
822	ELSEIF ( SIZE( values_int32 ) == 1 ) THEN
823	dimension%values_int32(:) = values_int32
824	ELSE
825	return_value = 2
826	ENDIF
827	ELSEIF( PRESENT( values_intwp ) ) THEN
828	ALLOCATE( dimension%values_intwp(dimension%bounds(1):dimension%bounds(2)) )
829	IF ( SIZE( values_intwp ) == dimension%length ) THEN
830	dimension%values_intwp = values_intwp
831	ELSEIF ( SIZE( values_intwp ) == 1 ) THEN
832	dimension%values_intwp(:) = values_intwp
833	ELSE
834	return_value = 2
835	ENDIF
836	ELSEIF( PRESENT( values_real32 ) ) THEN
837	ALLOCATE( dimension%values_real32(dimension%bounds(1):dimension%bounds(2)) )
838	IF ( SIZE( values_real32 ) == dimension%length ) THEN
839	dimension%values_real32 = values_real32
840	ELSEIF ( SIZE( values_real32 ) == 1 ) THEN
841	dimension%values_real32(:) = values_real32
842	ELSE
843	return_value = 2
844	ENDIF
845	ELSEIF( PRESENT( values_real64 ) ) THEN
846	ALLOCATE( dimension%values_real64(dimension%bounds(1):dimension%bounds(2)) )
847	IF ( SIZE( values_real64 ) == dimension%length ) THEN
848	dimension%values_real64 = values_real64
849	ELSEIF ( SIZE( values_real64 ) == 1 ) THEN
850	dimension%values_real64(:) = values_real64
851	ELSE
852	return_value = 2
853	ENDIF
854	ELSEIF( PRESENT( values_realwp ) ) THEN
855	ALLOCATE( dimension%values_realwp(dimension%bounds(1):dimension%bounds(2)) )
856	IF ( SIZE( values_realwp ) == dimension%length ) THEN
857	dimension%values_realwp = values_realwp
858	ELSEIF ( SIZE( values_realwp ) == 1 ) THEN
859	dimension%values_realwp(:) = values_realwp
860	ELSE
861	return_value = 2
862	ENDIF
863	ELSE
864	return_value = 1
865	CALL internal_message( 'error', routine_name // ': ' // &
866	TRIM( name ) // ': no values given' )
867	ENDIF
868
869	IF ( return_value == 2 ) THEN
870	return_value = 1
871	CALL internal_message( 'error', routine_name // &
872	': dimension ' // TRIM( name ) // &
873	': number of values and given bounds do not match' )
874	ENDIF
875
876	!-- Initialize mask
877	IF ( PRESENT( mask ) .AND. return_value == 0 ) THEN
878
879	dimension%is_masked = .TRUE.
880
881	IF ( dimension%length == SIZE( mask ) ) THEN
882
883	dimension%length_mask = COUNT( mask )
884
885	ALLOCATE( dimension%mask(dimension%bounds(1):dimension%bounds(2)) )
886	ALLOCATE( dimension%masked_indices(0:dimension%length_mask-1) )
887
888	dimension%mask = mask
889
890	!-- Save masked positions and masked values
891	IF ( ALLOCATED( dimension%values_int8 ) ) THEN
892
893	ALLOCATE( dimension%masked_values_int8(0:dimension%length_mask-1) )
894	j = 0
895	DO i = 0, dimension%length-1
896	IF ( dimension%mask(i) ) THEN
897	dimension%masked_values_int8(j) = dimension%values_int8(i)
898	dimension%masked_indices(j) = i
899	j = j + 1
900	ENDIF
901	ENDDO
902
903	ELSEIF ( ALLOCATED( dimension%values_int16 ) ) THEN
904
905	ALLOCATE( dimension%masked_values_int16(0:dimension%length_mask-1) )
906	j = 0
907	DO i = 0, dimension%length-1
908	IF ( dimension%mask(i) ) THEN
909	dimension%masked_values_int16(j) = dimension%values_int16(i)
910	dimension%masked_indices(j) = i
911	j = j + 1
912	ENDIF
913	ENDDO
914
915	ELSEIF ( ALLOCATED( dimension%values_int32 ) ) THEN
916
917	ALLOCATE( dimension%masked_values_int32(0:dimension%length_mask-1) )
918	j = 0
919	DO i = 0, dimension%length-1
920	IF ( dimension%mask(i) ) THEN
921	dimension%masked_values_int32(j) = dimension%values_int32(i)
922	dimension%masked_indices(j) = i
923	j = j + 1
924	ENDIF
925	ENDDO
926
927	ELSEIF ( ALLOCATED( dimension%values_intwp ) ) THEN
928
929	ALLOCATE( dimension%masked_values_intwp(0:dimension%length_mask-1) )
930	j = 0
931	DO i = 0, dimension%length-1
932	IF ( dimension%mask(i) ) THEN
933	dimension%masked_values_intwp(j) = dimension%values_intwp(i)
934	dimension%masked_indices(j) = i
935	j = j + 1
936	ENDIF
937	ENDDO
938
939	ELSEIF ( ALLOCATED( dimension%values_real32 ) ) THEN
940
941	ALLOCATE( dimension%masked_values_real32(0:dimension%length_mask-1) )
942	j = 0
943	DO i = 0, dimension%length-1
944	IF ( dimension%mask(i) ) THEN
945	dimension%masked_values_real32(j) = dimension%values_real32(i)
946	dimension%masked_indices(j) = i
947	j = j + 1
948	ENDIF
949	ENDDO
950
951	ELSEIF ( ALLOCATED(dimension%values_real64) ) THEN
952
953	ALLOCATE( dimension%masked_values_real64(0:dimension%length_mask-1) )
954	j = 0
955	DO i = 0, dimension%length-1
956	IF ( dimension%mask(i) ) THEN
957	dimension%masked_values_real64(j) = dimension%values_real64(i)
958	dimension%masked_indices(j) = i
959	j = j + 1
960	ENDIF
961	ENDDO
962
963	ELSEIF ( ALLOCATED(dimension%values_realwp) ) THEN
964
965	ALLOCATE( dimension%masked_values_realwp(0:dimension%length_mask-1) )
966	j = 0
967	DO i = dimension%bounds(1), dimension%bounds(2) !> @todo change loop also for other data types
968	IF ( dimension%mask(i) ) THEN
969	dimension%masked_values_realwp(j) = dimension%values_realwp(i)
970	dimension%masked_indices(j) = i
971	j = j + 1
972	ENDIF
973	ENDDO
974
975	ENDIF
976
977	ELSE
978	return_value = 1
979	CALL internal_message( 'error', routine_name // &
980	': dimension ' // TRIM( name ) // &
981	': size of mask and given bounds do not match' )
982	ENDIF
983
984	ENDIF
985
986	ELSE
987
988	return_value = 1
989	CALL internal_message( 'error', routine_name // &
990	': at least one but no more than two bounds must be given ' // &
991	'(dimension "' // TRIM( name ) // &
992	'", file "' // TRIM( filename ) // &
993	'")!' )
994
995	ENDIF
996
997	!-- Add dimension to database
998	IF ( return_value == 0 ) THEN
999
1000	DO f = 1, nf
1001
1002	IF ( TRIM( filename ) == files(f)%name ) THEN
1003
1004	IF ( files(f)%is_init ) THEN
1005
1006	return_value = 1
1007	CALL internal_message( 'error', &
1008	routine_name // ': file "' // TRIM( filename ) // &
1009	'" is already initialized. No further dimension definition allowed!' )
1010	EXIT
1011
1012	ELSEIF ( .NOT. ALLOCATED( files(f)%dimensions ) ) THEN
1013
1014	ndim = 1
1015	ALLOCATE( files(f)%dimensions(ndim) )
1016
1017	ELSE
1018
1019	!-- Check if any variable of the same name as the new dimension is already defined
1020	IF ( ALLOCATED( files(f)%variables ) ) THEN
1021	DO i = 1, SIZE( files(f)%variables )
1022	IF ( files(f)%variables(i)%name == dimension%name ) THEN
1023	return_value = 1
1024	CALL internal_message( 'error', routine_name // &
1025	': file "' // TRIM( filename ) // &
1026	'" already has a variable of name "' // &
1027	TRIM( dimension%name ) // '" defined. ' // &
1028	'Defining a dimension of the same ' // &
1029	'name is not allowed.' )
1030	EXIT
1031	ENDIF
1032	ENDDO
1033	ENDIF
1034
1035	IF ( return_value == 0 ) THEN
1036	!-- Check if dimension already exists in file
1037	ndim = SIZE( files(f)%dimensions )
1038
1039	DO d = 1, ndim
1040	IF ( files(f)%dimensions(d)%name == dimension%name ) THEN
1041	return_value = 1
1042	CALL internal_message( 'error', &
1043	routine_name // &
1044	': dimension "' // TRIM( name ) // &
1045	'" already exists in file "' // TRIM( filename ) // '"' )
1046	EXIT
1047	ENDIF
1048	ENDDO
1049
1050	!-- Extend dimension list
1051	IF ( return_value == 0 ) THEN
1052	ALLOCATE( dims_tmp(ndim) )
1053	dims_tmp = files(f)%dimensions
1054	DEALLOCATE( files(f)%dimensions )
1055	ndim = ndim + 1
1056	ALLOCATE( files(f)%dimensions(ndim) )
1057	files(f)%dimensions(:ndim-1) = dims_tmp
1058	DEALLOCATE( dims_tmp )
1059	ENDIF
1060	ENDIF
1061
1062	ENDIF
1063
1064	!-- Add new dimension to database
1065	IF ( return_value == 0 ) files(f)%dimensions(ndim) = dimension
1066
1067	EXIT
1068
1069	ENDIF
1070	ENDDO
1071
1072	IF ( f > nf ) THEN
1073	return_value = 1
1074	CALL internal_message( 'error', routine_name // &
1075	': file not found (dimension "' // TRIM( name ) // &
1076	'", file "' // TRIM( filename ) // '")!' )
1077	ENDIF
1078
1079	ENDIF
1080
1081	END FUNCTION dom_def_dim
1082
1083	!--------------------------------------------------------------------------------------------------!
1084	! Description:
1085	! ------------
1086	!> Add variable to database.
1087	!> Example call:
1088	!> dom_def_var( filename = 'DATA_OUTPUT_3D', &
1089	!> name = 'u', &
1090	!> dimension_names = (/'x ', 'y ', 'z ', 'time'/), &
1091	!> output_type = 'real32' )
1092	!> @note The order of dimensions must match in reversed order to the dimensions of the
1093	!> corresponding variable array. The last given dimension can also be non-existent within the
1094	!> variable array if at any given call of 'dom_write_var' for this variable, the last
1095	!> dimension has only a single index.
1096	!> Hence, the array 'u' must be allocated with dimension 'x' as its last dimension, preceded
1097	!> by 'y', then 'z', and 'time' being the first dimension. If at any given write statement,
1098	!> only a single index of dimension 'time' is to be written, the dimension can be non-present
1099	!> in the variable array leaving dimension 'z' as the first dimension.
1100	!> So, the variable array needs to be allocated like either:
1101	!> ALLOCATE( u(<time>,<z>,<y>,<x>) )
1102	!> or
1103	!> ALLOCATE( u(<z>,<y>,<x>) )
1104	!--------------------------------------------------------------------------------------------------!
1105	FUNCTION dom_def_var( filename, name, dimension_names, output_type, is_global ) &
1106	RESULT( return_value )
1107
1108	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1109	CHARACTER(LEN=*), INTENT(IN) :: name !< name of variable
1110	CHARACTER(LEN=*), INTENT(IN) :: output_type !< data type of variable
1111
1112	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_var' !< name of this routine
1113
1114	CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: dimension_names !< list of dimension names
1115
1116	INTEGER(iwp) :: d !< loop index
1117	INTEGER(iwp) :: f !< loop index
1118	INTEGER(iwp) :: i !< loop index
1119	INTEGER(iwp) :: nvar !< number of variables in file
1120	INTEGER(iwp) :: return_value !< return value
1121
1122	LOGICAL :: found = .FALSE. !< true if requested dimension is defined in file
1123	LOGICAL, INTENT(IN), OPTIONAL :: is_global !< true if variable is global (same on all PE)
1124
1125	TYPE(variable_type) :: variable !< new variable
1126
1127	TYPE(variable_type), DIMENSION(:), ALLOCATABLE :: vars_tmp !< temporary variable list
1128
1129
1130	return_value = 0
1131
1132	CALL internal_message( 'debug', routine_name // &
1133	': define variable "' // TRIM( name ) // &
1134	'" in file "' // TRIM( filename ) // '"' )
1135
1136	variable%name = TRIM( name )
1137
1138	ALLOCATE( variable%dimension_names(SIZE( dimension_names )) )
1139	ALLOCATE( variable%dimension_ids(SIZE( dimension_names )) )
1140
1141	variable%dimension_names = dimension_names
1142	variable%dimension_ids = -1
1143	variable%data_type = TRIM( output_type )
1144
1145	IF ( PRESENT( is_global ) ) THEN
1146	variable%is_global = is_global
1147	ELSE
1148	variable%is_global = .FALSE.
1149	ENDIF
1150
1151	!-- Add variable to database
1152	DO f = 1, nf
1153
1154	IF ( TRIM( filename ) == files(f)%name ) THEN
1155
1156	IF ( files(f)%is_init ) THEN
1157
1158	return_value = 1
1159	CALL internal_message( 'error', routine_name // ': file "' // TRIM( filename ) // &
1160	'" is already initialized. No further variable definition allowed!' )
1161	EXIT
1162
1163	ELSEIF ( ALLOCATED( files(f)%dimensions ) ) THEN
1164
1165	!-- Check if any dimension of the same name as the new variable is already defined
1166	DO d = 1, SIZE( files(f)%dimensions )
1167	IF ( files(f)%dimensions(d)%name == variable%name ) THEN
1168	return_value = 1
1169	CALL internal_message( 'error', routine_name // &
1170	': file "' // TRIM( filename ) // &
1171	'" already has a dimension of name "' // &
1172	TRIM( variable%name ) // '" defined. ' // &
1173	'Defining a variable of the same name is not allowed.' )
1174	EXIT
1175	ENDIF
1176	ENDDO
1177
1178	!-- Check if dimensions assigned to variable are defined within file
1179	IF ( return_value == 0 ) THEN
1180	DO i = 1, SIZE( variable%dimension_names )
1181	found = .FALSE.
1182	DO d = 1, SIZE( files(f)%dimensions )
1183	IF ( files(f)%dimensions(d)%name == variable%dimension_names(i) ) THEN
1184	found = .TRUE.
1185	EXIT
1186	ENDIF
1187	ENDDO
1188	IF ( .NOT. found ) THEN
1189	return_value = 1
1190	CALL internal_message( 'error', &
1191	routine_name // &
1192	': required dimension "' // &
1193	TRIM( variable%dimension_names(i) ) // &
1194	'" for variable "' // TRIM( name ) // &
1195	'" is not defined in file "' // TRIM( filename ) // &
1196	'"!' )
1197	EXIT
1198	ENDIF
1199	ENDDO
1200	ENDIF
1201
1202	ELSE
1203
1204	return_value = 1
1205	CALL internal_message( 'error', routine_name // &
1206	': cannot define variable "' // TRIM( name ) // &
1207	'" in file "' // TRIM( filename ) // &
1208	'" because no dimensions defined in file.' )
1209
1210	ENDIF
1211
1212	IF ( return_value == 0 ) THEN
1213
1214	!-- Check if variable already exists
1215	IF ( .NOT. ALLOCATED( files(f)%variables ) ) THEN
1216
1217	nvar = 1
1218	ALLOCATE( files(f)%variables(nvar) )
1219
1220	ELSE
1221
1222	nvar = SIZE( files(f)%variables )
1223	DO i = 1, nvar
1224	IF ( files(f)%variables(i)%name == variable%name ) THEN
1225	return_value = 1
1226	CALL internal_message( 'error', routine_name // &
1227	': variable "' // TRIM( name ) // &
1228	'" already exists in file "' // &
1229	TRIM( filename ) // '"!' )
1230	EXIT
1231	ENDIF
1232	ENDDO
1233
1234	IF ( return_value == 0 ) THEN
1235	!-- Extend variable list
1236	ALLOCATE( vars_tmp(nvar) )
1237	vars_tmp = files(f)%variables
1238	DEALLOCATE( files(f)%variables )
1239	nvar = nvar + 1
1240	ALLOCATE( files(f)%variables(nvar) )
1241	files(f)%variables(:nvar-1) = vars_tmp
1242	DEALLOCATE( vars_tmp )
1243	ENDIF
1244
1245	ENDIF
1246
1247	!-- Add new variable to database
1248	IF ( return_value == 0 ) files(f)%variables(nvar) = variable
1249
1250	ENDIF
1251
1252	EXIT
1253
1254	ENDIF
1255
1256	ENDDO
1257
1258	IF ( f > nf ) THEN
1259	return_value = 1
1260	CALL internal_message( 'error', routine_name // &
1261	': file not found (variable "' // TRIM( name ) // &
1262	'", file "' // TRIM( filename ) // '")!' )
1263	ENDIF
1264
1265	END FUNCTION dom_def_var
1266
1267	!--------------------------------------------------------------------------------------------------!
1268	! Description:
1269	! ------------
1270	!> Create attribute with value of type character.
1271	!--------------------------------------------------------------------------------------------------!
1272	FUNCTION dom_def_att_char( filename, variable, name, value, append ) RESULT( return_value )
1273
1274	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1275	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1276	CHARACTER(LEN=*), INTENT(IN) :: value !< attribute value
1277	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1278
1279	! CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_char' !< name of routine
1280
1281	INTEGER(iwp) :: return_value !< return value
1282
1283	LOGICAL :: append_internal !< same as 'append'
1284	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1285
1286	TYPE(attribute_type) :: attribute !< new attribute
1287
1288
1289	return_value = 0
1290
1291	IF ( PRESENT( append ) ) THEN
1292	append_internal = append
1293	ELSE
1294	append_internal = .FALSE.
1295	ENDIF
1296
1297	attribute%name = TRIM( name )
1298	attribute%data_type = 'char'
1299	attribute%value_char = TRIM( value )
1300
1301	IF ( PRESENT( variable ) ) THEN
1302	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1303	attribute=attribute, append=append_internal )
1304	ELSE
1305	return_value = dom_def_att_save( TRIM( filename ), &
1306	attribute=attribute, append=append_internal )
1307	ENDIF
1308
1309	END FUNCTION dom_def_att_char
1310
1311	!--------------------------------------------------------------------------------------------------!
1312	! Description:
1313	! ------------
1314	!> Create attribute with value of type int8.
1315	!--------------------------------------------------------------------------------------------------!
1316	FUNCTION dom_def_att_int8( filename, variable, name, value, append ) RESULT( return_value )
1317
1318	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1319	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1320	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1321
1322	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int8' !< name of routine
1323
1324	INTEGER(KIND=1), INTENT(IN) :: value !< attribute value
1325
1326	INTEGER(iwp) :: return_value !< return value
1327
1328	LOGICAL :: append_internal !< same as 'append'
1329	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1330
1331	TYPE(attribute_type) :: attribute !< new attribute
1332
1333
1334	return_value = 0
1335
1336	IF ( PRESENT( append ) ) THEN
1337	IF ( append ) THEN
1338	return_value = 1
1339	CALL internal_message( 'error', &
1340	routine_name // &
1341	': attribute "' // TRIM( name ) // &
1342	'": append of numeric attribute not possible.' )
1343	ENDIF
1344	ENDIF
1345
1346	IF ( return_value == 0 ) THEN
1347	append_internal = .FALSE.
1348
1349	attribute%name = TRIM( name )
1350	attribute%data_type = 'int8'
1351	attribute%value_int8 = value
1352
1353	IF ( PRESENT( variable ) ) THEN
1354	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1355	attribute=attribute, append=append_internal )
1356	ELSE
1357	return_value = dom_def_att_save( TRIM( filename ), &
1358	attribute=attribute, append=append_internal )
1359	ENDIF
1360	ENDIF
1361
1362	END FUNCTION dom_def_att_int8
1363
1364	!--------------------------------------------------------------------------------------------------!
1365	! Description:
1366	! ------------
1367	!> Create attribute with value of type int16.
1368	!--------------------------------------------------------------------------------------------------!
1369	FUNCTION dom_def_att_int16( filename, variable, name, value, append ) RESULT( return_value )
1370
1371	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1372	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1373	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1374
1375	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int16' !< name of routine
1376
1377	INTEGER(KIND=2), INTENT(IN) :: value !< attribute value
1378
1379	INTEGER(iwp) :: return_value !< return value
1380
1381	LOGICAL :: append_internal !< same as 'append'
1382	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1383
1384	TYPE(attribute_type) :: attribute !< new attribute
1385
1386
1387	return_value = 0
1388
1389	IF ( PRESENT( append ) ) THEN
1390	IF ( append ) THEN
1391	return_value = 1
1392	CALL internal_message( 'error', &
1393	routine_name // &
1394	': attribute "' // TRIM( name ) // &
1395	'": append of numeric attribute not possible.' )
1396	ENDIF
1397	ENDIF
1398
1399	IF ( return_value == 0 ) THEN
1400	append_internal = .FALSE.
1401
1402	attribute%name = TRIM( name )
1403	attribute%data_type = 'int16'
1404	attribute%value_int16 = value
1405
1406	IF ( PRESENT( variable ) ) THEN
1407	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1408	attribute=attribute, append=append_internal )
1409	ELSE
1410	return_value = dom_def_att_save( TRIM( filename ), &
1411	attribute=attribute, append=append_internal )
1412	ENDIF
1413	ENDIF
1414
1415	END FUNCTION dom_def_att_int16
1416
1417	!--------------------------------------------------------------------------------------------------!
1418	! Description:
1419	! ------------
1420	!> Create attribute with value of type int32.
1421	!--------------------------------------------------------------------------------------------------!
1422	FUNCTION dom_def_att_int32( filename, variable, name, value, append ) RESULT( return_value )
1423
1424	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1425	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1426	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1427
1428	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int32' !< name of routine
1429
1430	INTEGER(KIND=4), INTENT(IN) :: value !< attribute value
1431
1432	INTEGER(iwp) :: return_value !< return value
1433
1434	LOGICAL :: append_internal !< same as 'append'
1435	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1436
1437	TYPE(attribute_type) :: attribute !< new attribute
1438
1439
1440	return_value = 0
1441
1442	IF ( PRESENT( append ) ) THEN
1443	IF ( append ) THEN
1444	return_value = 1
1445	CALL internal_message( 'error', &
1446	routine_name // &
1447	': attribute "' // TRIM( name ) // &
1448	'": append of numeric attribute not possible.' )
1449	ENDIF
1450	ENDIF
1451
1452	IF ( return_value == 0 ) THEN
1453	append_internal = .FALSE.
1454
1455	attribute%name = TRIM( name )
1456	attribute%data_type = 'int32'
1457	attribute%value_int32 = value
1458
1459	IF ( PRESENT( variable ) ) THEN
1460	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1461	attribute=attribute, append=append_internal )
1462	ELSE
1463	return_value = dom_def_att_save( TRIM( filename ), &
1464	attribute=attribute, append=append_internal )
1465	ENDIF
1466	ENDIF
1467
1468	END FUNCTION dom_def_att_int32
1469
1470	!--------------------------------------------------------------------------------------------------!
1471	! Description:
1472	! ------------
1473	!> Create attribute with value of type real32.
1474	!--------------------------------------------------------------------------------------------------!
1475	FUNCTION dom_def_att_real32( filename, variable, name, value, append ) RESULT( return_value )
1476
1477	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1478	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1479	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1480
1481	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real32' !< name of routine
1482
1483	INTEGER(iwp) :: return_value !< return value
1484
1485	LOGICAL :: append_internal !< same as 'append'
1486	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1487
1488	REAL(KIND=4), INTENT(IN) :: value !< attribute value
1489
1490	TYPE(attribute_type) :: attribute !< new attribute
1491
1492
1493	return_value = 0
1494
1495	IF ( PRESENT( append ) ) THEN
1496	IF ( append ) THEN
1497	return_value = 1
1498	CALL internal_message( 'error', &
1499	routine_name // &
1500	': attribute "' // TRIM( name ) // &
1501	'": append of numeric attribute not possible.' )
1502	ENDIF
1503	ENDIF
1504
1505	IF ( return_value == 0 ) THEN
1506	append_internal = .FALSE.
1507
1508	attribute%name = TRIM( name )
1509	attribute%data_type = 'real32'
1510	attribute%value_real32 = value
1511
1512	IF ( PRESENT( variable ) ) THEN
1513	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1514	attribute=attribute, append=append_internal )
1515	ELSE
1516	return_value = dom_def_att_save( TRIM( filename ), &
1517	attribute=attribute, append=append_internal )
1518	ENDIF
1519	ENDIF
1520
1521	END FUNCTION dom_def_att_real32
1522
1523	!--------------------------------------------------------------------------------------------------!
1524	! Description:
1525	! ------------
1526	!> Create attribute with value of type real64.
1527	!--------------------------------------------------------------------------------------------------!
1528	FUNCTION dom_def_att_real64( filename, variable, name, value, append ) RESULT( return_value )
1529
1530	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1531	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1532	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1533
1534	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real64' !< name of routine
1535
1536	INTEGER(iwp) :: return_value !< return value
1537
1538	LOGICAL :: append_internal !< same as 'append'
1539	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1540
1541	REAL(KIND=8), INTENT(IN) :: value !< attribute value
1542
1543	TYPE(attribute_type) :: attribute !< new attribute
1544
1545
1546	return_value = 0
1547
1548	IF ( PRESENT( append ) ) THEN
1549	IF ( append ) THEN
1550	return_value = 1
1551	CALL internal_message( 'error', &
1552	routine_name // &
1553	': attribute "' // TRIM( name ) // &
1554	'": append of numeric attribute not possible.' )
1555	ENDIF
1556	ENDIF
1557
1558	IF ( return_value == 0 ) THEN
1559	append_internal = .FALSE.
1560
1561	attribute%name = TRIM( name )
1562	attribute%data_type = 'real64'
1563	attribute%value_real64 = value
1564
1565	IF ( PRESENT( variable ) ) THEN
1566	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1567	attribute=attribute, append=append_internal )
1568	ELSE
1569	return_value = dom_def_att_save( TRIM( filename ), &
1570	attribute=attribute, append=append_internal )
1571	ENDIF
1572	ENDIF
1573
1574	END FUNCTION dom_def_att_real64
1575
1576	!--------------------------------------------------------------------------------------------------!
1577	! Description:
1578	! ------------
1579	!> Add attribute to database.
1580	!>
1581	!> @todo Try to combine similar code parts and shorten routine.
1582	!--------------------------------------------------------------------------------------------------!
1583	FUNCTION dom_def_att_save( filename, variable_name, attribute, append ) RESULT( return_value )
1584
1585	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1586	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable
1587
1588	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_save' !< name of routine
1589
1590	INTEGER(iwp) :: a !< loop index
1591	INTEGER(iwp) :: d !< loop index
1592	INTEGER(iwp) :: f !< loop index
1593	INTEGER(iwp) :: natt !< number of attributes
1594	INTEGER(iwp) :: return_value !< return value
1595
1596	LOGICAL :: found !< true if variable or dimension of name 'variable_name' found
1597	LOGICAL, INTENT(IN) :: append !< if true, append value to existing value
1598
1599	TYPE(attribute_type), INTENT(IN) :: attribute !< new attribute
1600
1601	TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: atts_tmp !< temporary attribute list
1602
1603
1604	return_value = 0
1605	found = .FALSE.
1606
1607	IF ( PRESENT( variable_name ) ) THEN
1608	CALL internal_message( 'debug', routine_name // &
1609	': define attribute "' // TRIM( attribute%name ) // &
1610	'" of variable "' // TRIM( variable_name ) // &
1611	'" in file "' // TRIM( filename ) // '"' )
1612	ELSE
1613	CALL internal_message( 'debug', routine_name // &
1614	': define attribute "' // TRIM( attribute%name ) // &
1615	'" in file "' // TRIM( filename ) // '"' )
1616	ENDIF
1617
1618	DO f = 1, nf
1619
1620	IF ( TRIM( filename ) == files(f)%name ) THEN
1621
1622	IF ( files(f)%is_init ) THEN
1623	return_value = 1
1624	CALL internal_message( 'error', routine_name // ': file "' // TRIM( filename ) // &
1625	'" is already initialized. No further attribute definition allowed!' )
1626	EXIT
1627	ENDIF
1628
1629	!-- Add attribute to file
1630	IF ( .NOT. PRESENT( variable_name ) ) THEN
1631
1632	!-- Initialize first file attribute
1633	IF ( .NOT. ALLOCATED( files(f)%attributes ) ) THEN
1634	natt = 1
1635	ALLOCATE( files(f)%attributes(natt) )
1636	ELSE
1637	natt = SIZE( files(f)%attributes )
1638
1639	!-- Check if attribute already exists
1640	DO a = 1, natt
1641	IF ( files(f)%attributes(a)%name == attribute%name ) THEN
1642	IF ( append ) THEN
1643	!-- Append existing string attribute
1644	files(f)%attributes(a)%value_char = &
1645	TRIM( files(f)%attributes(a)%value_char ) // &
1646	TRIM( attribute%value_char )
1647	ELSE
1648	files(f)%attributes(a) = attribute
1649	ENDIF
1650	found = .TRUE.
1651	EXIT
1652	ENDIF
1653	ENDDO
1654
1655	!-- Extend attribute list by 1
1656	IF ( .NOT. found ) THEN
1657	ALLOCATE( atts_tmp(natt) )
1658	atts_tmp = files(f)%attributes
1659	DEALLOCATE( files(f)%attributes )
1660	natt = natt + 1
1661	ALLOCATE( files(f)%attributes(natt) )
1662	files(f)%attributes(:natt-1) = atts_tmp
1663	DEALLOCATE( atts_tmp )
1664	ENDIF
1665	ENDIF
1666
1667	!-- Save new attribute to the end of the attribute list
1668	IF ( .NOT. found ) THEN
1669	files(f)%attributes(natt) = attribute
1670	found = .TRUE.
1671	ENDIF
1672
1673	EXIT
1674
1675	ELSE
1676
1677	!-- Add attribute to dimension
1678	IF ( ALLOCATED( files(f)%dimensions ) ) THEN
1679
1680	DO d = 1, SIZE( files(f)%dimensions )
1681
1682	IF ( files(f)%dimensions(d)%name == TRIM( variable_name ) ) THEN
1683
1684	IF ( .NOT. ALLOCATED( files(f)%dimensions(d)%attributes ) ) THEN
1685	!-- Initialize first attribute
1686	natt = 1
1687	ALLOCATE( files(f)%dimensions(d)%attributes(natt) )
1688	ELSE
1689	natt = SIZE( files(f)%dimensions(d)%attributes )
1690
1691	!-- Check if attribute already exists
1692	DO a = 1, natt
1693	IF ( files(f)%dimensions(d)%attributes(a)%name == attribute%name ) &
1694	THEN
1695	IF ( append ) THEN
1696	!-- Append existing character attribute
1697	files(f)%dimensions(d)%attributes(a)%value_char = &
1698	TRIM( files(f)%dimensions(d)%attributes(a)%value_char ) // &
1699	TRIM( attribute%value_char )
1700	ELSE
1701	!-- Update existing attribute
1702	files(f)%dimensions(d)%attributes(a) = attribute
1703	ENDIF
1704	found = .TRUE.
1705	EXIT
1706	ENDIF
1707	ENDDO
1708
1709	!-- Extend attribute list
1710	IF ( .NOT. found ) THEN
1711	ALLOCATE( atts_tmp(natt) )
1712	atts_tmp = files(f)%dimensions(d)%attributes
1713	DEALLOCATE( files(f)%dimensions(d)%attributes )
1714	natt = natt + 1
1715	ALLOCATE( files(f)%dimensions(d)%attributes(natt) )
1716	files(f)%dimensions(d)%attributes(:natt-1) = atts_tmp
1717	DEALLOCATE( atts_tmp )
1718	ENDIF
1719	ENDIF
1720
1721	!-- Add new attribute to database
1722	IF ( .NOT. found ) THEN
1723	files(f)%dimensions(d)%attributes(natt) = attribute
1724	found = .TRUE.
1725	ENDIF
1726
1727	EXIT
1728
1729	ENDIF ! dimension found
1730
1731	ENDDO ! loop over dimensions
1732
1733	ENDIF ! dimensions exist in file
1734
1735	!-- Add attribute to variable
1736	IF ( .NOT. found .AND. ALLOCATED( files(f)%variables) ) THEN
1737
1738	DO d = 1, SIZE( files(f)%variables )
1739
1740	IF ( files(f)%variables(d)%name == TRIM( variable_name ) ) THEN
1741
1742	IF ( .NOT. ALLOCATED( files(f)%variables(d)%attributes ) ) THEN
1743	!-- Initialize first attribute
1744	natt = 1
1745	ALLOCATE( files(f)%variables(d)%attributes(natt) )
1746	ELSE
1747	natt = SIZE( files(f)%variables(d)%attributes )
1748
1749	!-- Check if attribute already exists
1750	DO a = 1, natt
1751	IF ( files(f)%variables(d)%attributes(a)%name == attribute%name ) &
1752	THEN
1753	IF ( append ) THEN
1754	!-- Append existing character attribute
1755	files(f)%variables(d)%attributes(a)%value_char = &
1756	TRIM( files(f)%variables(d)%attributes(a)%value_char ) // &
1757	TRIM( attribute%value_char )
1758	ELSE
1759	!-- Update existing attribute
1760	files(f)%variables(d)%attributes(a) = attribute
1761	ENDIF
1762	found = .TRUE.
1763	EXIT
1764	ENDIF
1765	ENDDO
1766
1767	!-- Extend attribute list
1768	IF ( .NOT. found ) THEN
1769	ALLOCATE( atts_tmp(natt) )
1770	atts_tmp = files(f)%variables(d)%attributes
1771	DEALLOCATE( files(f)%variables(d)%attributes )
1772	natt = natt + 1
1773	ALLOCATE( files(f)%variables(d)%attributes(natt) )
1774	files(f)%variables(d)%attributes(:natt-1) = atts_tmp
1775	DEALLOCATE( atts_tmp )
1776	ENDIF
1777
1778	ENDIF
1779
1780	!-- Add new attribute to database
1781	IF ( .NOT. found ) THEN
1782	files(f)%variables(d)%attributes(natt) = attribute
1783	found = .TRUE.
1784	ENDIF
1785
1786	EXIT
1787
1788	ENDIF ! variable found
1789
1790	ENDDO ! loop over variables
1791
1792	ENDIF ! variables exist in file
1793
1794	IF ( .NOT. found ) THEN
1795	return_value = 1
1796	CALL internal_message( 'error', &
1797	routine_name // &
1798	': requested dimension/variable "' // TRIM( variable_name ) // &
1799	'" for attribute "' // TRIM( attribute%name ) // &
1800	'" does not exist in file "' // TRIM( filename ) // '"' )
1801	ENDIF
1802
1803	EXIT
1804
1805	ENDIF ! variable_name present
1806
1807	ENDIF ! check filename
1808
1809	ENDDO ! loop over files
1810
1811	IF ( .NOT. found .AND. return_value == 0 ) THEN
1812	return_value = 1
1813	CALL internal_message( 'error', &
1814	routine_name // &
1815	': requested file "' // TRIM( filename ) // &
1816	'" for attribute "' // TRIM( attribute%name ) // &
1817	'" does not exist' )
1818	ENDIF
1819
1820	END FUNCTION dom_def_att_save
1821
1822	!--------------------------------------------------------------------------------------------------!
1823	! Description:
1824	! ------------
1825	!> Start with output: clear database from unused files/dimensions, initialize
1826	!> files and write dimension values to files.
1827	!--------------------------------------------------------------------------------------------------!
1828	FUNCTION dom_start_output() RESULT( return_value )
1829
1830	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_start_output' !< name of routine
1831
1832	INTEGER(iwp) :: d !< loop index
1833	INTEGER(iwp) :: f !< loop index
1834	INTEGER(iwp) :: return_value !< return value
1835
1836	INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE, TARGET :: values_int8 !< target array for dimension values
1837	INTEGER(KIND=1), DIMENSION(:), POINTER, CONTIGUOUS :: values_int8_pointer !< pointer to target array
1838
1839	INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE, TARGET :: values_int16 !< target array for dimension values
1840	INTEGER(KIND=2), DIMENSION(:), POINTER, CONTIGUOUS :: values_int16_pointer !< pointer to target array
1841
1842	INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET :: values_int32 !< target array for dimension values
1843	INTEGER(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS :: values_int32_pointer !< pointer to target array
1844
1845	INTEGER(iwp), DIMENSION(:), ALLOCATABLE, TARGET :: values_intwp !< target array for dimension values
1846	INTEGER(iwp), DIMENSION(:), POINTER, CONTIGUOUS :: values_intwp_pointer !< pointer to target array
1847
1848	REAL(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET :: values_real32 !< target array for dimension values
1849	REAL(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS :: values_real32_pointer !< pointer to target array
1850
1851	REAL(KIND=8), DIMENSION(:), ALLOCATABLE, TARGET :: values_real64 !< target array for dimension values
1852	REAL(KIND=8), DIMENSION(:), POINTER, CONTIGUOUS :: values_real64_pointer !< pointer to target array
1853
1854	REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET :: values_realwp !< target array for dimension values
1855	REAL(wp), DIMENSION(:), POINTER, CONTIGUOUS :: values_realwp_pointer !< pointer to target array
1856
1857
1858	return_value = 0
1859	CALL internal_message( 'debug', routine_name // ': start' )
1860
1861	!-- Clear database from empty files and unused dimensions
1862	IF ( nf > 0 ) return_value = cleanup_database()
1863
1864	IF ( return_value == 0 ) THEN
1865	DO f = 1, nf
1866
1867	!-- Skip initialization if file is already initialized
1868	IF ( files(f)%is_init ) CYCLE
1869
1870	CALL internal_message( 'debug', routine_name // ': initialize file "' // &
1871	TRIM( files(f)%name ) // '"' )
1872
1873	!-- Open file
1874	CALL open_output_file( files(f)%format, files(f)%name, files(f)%id, &
1875	return_value=return_value )
1876
1877	!-- Initialize file header:
1878	!-- define dimensions and variables and write attributes
1879	IF ( return_value == 0 ) &
1880	CALL dom_init_file_header( files(f), return_value=return_value )
1881
1882	!-- End file definition
1883	IF ( return_value == 0 ) &
1884	CALL dom_init_end( files(f)%format, files(f)%id, files(f)%name, return_value )
1885
1886	IF ( return_value == 0 ) THEN
1887
1888	!-- Flag file as initialized
1889	files(f)%is_init = .TRUE.
1890
1891	!-- Write dimension values into file
1892	DO d = 1, SIZE( files(f)%dimensions )
1893	IF ( ALLOCATED( files(f)%dimensions(d)%values_int8 ) ) THEN
1894	ALLOCATE( values_int8(files(f)%dimensions(d)%bounds(1): &
1895	files(f)%dimensions(d)%bounds(2)) )
1896	values_int8 = files(f)%dimensions(d)%values_int8
1897	values_int8_pointer => values_int8
1898	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1899	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1900	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1901	var_int8_1d=values_int8_pointer )
1902	DEALLOCATE( values_int8 )
1903	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int16 ) ) THEN
1904	ALLOCATE( values_int16(files(f)%dimensions(d)%bounds(1): &
1905	files(f)%dimensions(d)%bounds(2)) )
1906	values_int16 = files(f)%dimensions(d)%values_int16
1907	values_int16_pointer => values_int16
1908	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1909	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1910	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1911	var_int16_1d=values_int16_pointer )
1912	DEALLOCATE( values_int16 )
1913	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int32 ) ) THEN
1914	ALLOCATE( values_int32(files(f)%dimensions(d)%bounds(1): &
1915	files(f)%dimensions(d)%bounds(2)) )
1916	values_int32 = files(f)%dimensions(d)%values_int32
1917	values_int32_pointer => values_int32
1918	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1919	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1920	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1921	var_int32_1d=values_int32_pointer )
1922	DEALLOCATE( values_int32 )
1923	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_intwp ) ) THEN
1924	ALLOCATE( values_intwp(files(f)%dimensions(d)%bounds(1): &
1925	files(f)%dimensions(d)%bounds(2)) )
1926	values_intwp = files(f)%dimensions(d)%values_intwp
1927	values_intwp_pointer => values_intwp
1928	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1929	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1930	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1931	var_intwp_1d=values_intwp_pointer )
1932	DEALLOCATE( values_intwp )
1933	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real32 ) ) THEN
1934	ALLOCATE( values_real32(files(f)%dimensions(d)%bounds(1): &
1935	files(f)%dimensions(d)%bounds(2)) )
1936	values_real32 = files(f)%dimensions(d)%values_real32
1937	values_real32_pointer => values_real32
1938	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1939	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1940	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1941	var_real32_1d=values_real32_pointer )
1942	DEALLOCATE( values_real32 )
1943	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real64 ) ) THEN
1944	ALLOCATE( values_real64(files(f)%dimensions(d)%bounds(1): &
1945	files(f)%dimensions(d)%bounds(2)) )
1946	values_real64 = files(f)%dimensions(d)%values_real64
1947	values_real64_pointer => values_real64
1948	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1949	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1950	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1951	var_real64_1d=values_real64_pointer )
1952	DEALLOCATE( values_real64 )
1953	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_realwp ) ) THEN
1954	ALLOCATE( values_realwp(files(f)%dimensions(d)%bounds(1): &
1955	files(f)%dimensions(d)%bounds(2)) )
1956	values_realwp = files(f)%dimensions(d)%values_realwp
1957	values_realwp_pointer => values_realwp
1958	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1959	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1960	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1961	var_realwp_1d=values_realwp_pointer )
1962	DEALLOCATE( values_realwp )
1963	ENDIF
1964	IF ( return_value /= 0 ) EXIT
1965	ENDDO
1966
1967	ENDIF
1968
1969	IF ( return_value /= 0 ) EXIT
1970
1971	ENDDO
1972	ENDIF
1973
1974	CALL internal_message( 'debug', routine_name // ': finished' )
1975
1976	END FUNCTION dom_start_output
1977
1978	!--------------------------------------------------------------------------------------------------!
1979	! Description:
1980	! ------------
1981	!> Check database and delete any unused dimensions and empty files (i.e. files
1982	!> without variables).
1983	!--------------------------------------------------------------------------------------------------!
1984	FUNCTION cleanup_database() RESULT( return_value )
1985
1986	! CHARACTER(LEN=*), PARAMETER :: routine_name = 'cleanup_database' !< name of routine
1987
1988	INTEGER(iwp) :: d !< loop index
1989	INTEGER(iwp) :: f !< loop index
1990	INTEGER(iwp) :: i !< loop index
1991	INTEGER(iwp) :: ndim !< number of dimensions in a file
1992	INTEGER(iwp) :: ndim_used !< number of used dimensions in a file
1993	INTEGER(iwp) :: nf_used !< number of used files
1994	INTEGER(iwp) :: nvar !< number of variables in a file
1995	INTEGER(iwp) :: return_value !< return value
1996
1997	LOGICAL, DIMENSION(1:nf) :: file_is_used !< true if file contains variables
1998	LOGICAL, DIMENSION(:), ALLOCATABLE :: dimension_is_used !< true if dimension is used by any variable
1999
2000	TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: used_dimensions !< list of used dimensions
2001
2002	TYPE(file_type), DIMENSION(:), ALLOCATABLE :: used_files !< list of used files
2003
2004
2005	return_value = 0
2006
2007	!-- Flag files which contain output variables as used
2008	file_is_used(:) = .FALSE.
2009	DO f = 1, nf
2010	IF ( ALLOCATED( files(f)%variables ) ) THEN
2011	file_is_used(f) = .TRUE.
2012	ENDIF
2013	ENDDO
2014
2015	!-- Copy flagged files into temporary list
2016	nf_used = COUNT( file_is_used )
2017	ALLOCATE( used_files(nf_used) )
2018	i = 0
2019	DO f = 1, nf
2020	IF ( file_is_used(f) ) THEN
2021	i = i + 1
2022	used_files(i) = files(f)
2023	ENDIF
2024	ENDDO
2025
2026	!-- Replace file list with list of used files
2027	DEALLOCATE( files )
2028	nf = nf_used
2029	ALLOCATE( files(nf) )
2030	files = used_files
2031	DEALLOCATE( used_files )
2032
2033	!-- Check every file for unused dimensions
2034	DO f = 1, nf
2035
2036	!-- If a file is already initialized, it was already checked previously
2037	IF ( files(f)%is_init ) CYCLE
2038
2039	!-- Get number of defined dimensions
2040	ndim = SIZE( files(f)%dimensions )
2041	ALLOCATE( dimension_is_used(ndim) )
2042
2043	!-- Go through all variables and flag all used dimensions
2044	nvar = SIZE( files(f)%variables )
2045	DO d = 1, ndim
2046	DO i = 1, nvar
2047	dimension_is_used(d) = &
2048	ANY( files(f)%dimensions(d)%name == files(f)%variables(i)%dimension_names )
2049	IF ( dimension_is_used(d) ) EXIT
2050	ENDDO
2051	ENDDO
2052
2053	!-- Copy used dimensions to temporary list
2054	ndim_used = COUNT( dimension_is_used )
2055	ALLOCATE( used_dimensions(ndim_used) )
2056	i = 0
2057	DO d = 1, ndim
2058	IF ( dimension_is_used(d) ) THEN
2059	i = i + 1
2060	used_dimensions(i) = files(f)%dimensions(d)
2061	ENDIF
2062	ENDDO
2063
2064	!-- Replace dimension list with list of used dimensions
2065	DEALLOCATE( files(f)%dimensions )
2066	ndim = ndim_used
2067	ALLOCATE( files(f)%dimensions(ndim) )
2068	files(f)%dimensions = used_dimensions
2069	DEALLOCATE( used_dimensions )
2070	DEALLOCATE( dimension_is_used )
2071
2072	ENDDO
2073
2074	END FUNCTION cleanup_database
2075
2076	!--------------------------------------------------------------------------------------------------!
2077	! Description:
2078	! ------------
2079	!> Open requested output file.
2080	!--------------------------------------------------------------------------------------------------!
2081	SUBROUTINE open_output_file( file_format, filename, file_id, return_value )
2082
2083	CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file
2084	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file to be checked
2085
2086	CHARACTER(LEN=*), PARAMETER :: routine_name = 'open_output_file' !< name of routine
2087
2088	INTEGER(iwp), INTENT(OUT) :: file_id !< file ID
2089	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2090	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
2091
2092
2093	return_value = 0
2094	output_return_value = 0
2095
2096	SELECT CASE ( TRIM( file_format ) )
2097
2098	CASE ( 'binary' )
2099	CALL binary_open_file( 'binary', filename, file_id, output_return_value )
2100
2101	CASE ( 'netcdf4-serial' )
2102	CALL netcdf4_open_file( 'serial', filename, file_id, output_return_value )
2103
2104	CASE ( 'netcdf4-parallel' )
2105	CALL netcdf4_open_file( 'parallel', filename, file_id, output_return_value )
2106
2107	CASE DEFAULT
2108	return_value = 1
2109
2110	END SELECT
2111
2112	IF ( output_return_value /= 0 ) THEN
2113	return_value = output_return_value
2114	CALL internal_message( 'error', routine_name // &
2115	': error while opening file "' // TRIM( filename ) // '"' )
2116	ELSEIF ( return_value /= 0 ) THEN
2117	CALL internal_message( 'error', routine_name // &
2118	': file "' // TRIM( filename ) // &
2119	'": file format "' // TRIM( file_format ) // &
2120	'" not supported' )
2121	ENDIF
2122
2123	END SUBROUTINE open_output_file
2124
2125	!--------------------------------------------------------------------------------------------------!
2126	! Description:
2127	! ------------
2128	!> Define attributes, dimensions and variables.
2129	!--------------------------------------------------------------------------------------------------!
2130	SUBROUTINE dom_init_file_header( file, return_value )
2131
2132	! CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_init_file_header' !< name of routine
2133
2134	INTEGER(iwp) :: a !< loop index
2135	INTEGER(iwp) :: d !< loop index
2136	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
2137
2138	TYPE(file_type), INTENT(INOUT) :: file !< initialize header of this file
2139
2140
2141	return_value = 0
2142
2143	!-- Write file attributes
2144	IF ( ALLOCATED( file%attributes ) ) THEN
2145	DO a = 1, SIZE( file%attributes )
2146	return_value = write_attribute( file%format, file%id, file%name, var_id=no_var_id, &
2147	attribute=file%attributes(a) )
2148	IF ( return_value /= 0 ) EXIT
2149	ENDDO
2150	ENDIF
2151
2152	IF ( return_value == 0 ) THEN
2153
2154	!-- Initialize file dimensions
2155	DO d = 1, SIZE( file%dimensions )
2156
2157	IF ( .NOT. file%dimensions(d)%is_masked ) THEN
2158
2159	!-- Initialize non-masked dimension
2160	CALL init_file_dimension( file%format, file%id, file%name, &
2161	file%dimensions(d)%id, file%dimensions(d)%var_id, &
2162	file%dimensions(d)%name, file%dimensions(d)%data_type, &
2163	file%dimensions(d)%length, return_value )
2164
2165	ELSE
2166
2167	!-- Initialize masked dimension
2168	CALL init_file_dimension( file%format, file%id, file%name, &
2169	file%dimensions(d)%id, file%dimensions(d)%var_id, &
2170	file%dimensions(d)%name, file%dimensions(d)%data_type, &
2171	file%dimensions(d)%length_mask, return_value )
2172
2173	ENDIF
2174
2175	IF ( return_value == 0 .AND. ALLOCATED( file%dimensions(d)%attributes ) ) THEN
2176	!-- Write dimension attributes
2177	DO a = 1, SIZE( file%dimensions(d)%attributes )
2178	return_value = write_attribute( file%format, file%id, file%name, &
2179	var_id=file%dimensions(d)%var_id, &
2180	var_name=file%dimensions(d)%name, &
2181	attribute=file%dimensions(d)%attributes(a) )
2182	IF ( return_value /= 0 ) EXIT
2183	ENDDO
2184	ENDIF
2185
2186	IF ( return_value /= 0 ) EXIT
2187
2188	ENDDO
2189
2190	!-- Save dimension IDs for variables wihtin database
2191	IF ( return_value == 0 ) &
2192	CALL collect_dimesion_ids_for_variables( file%variables, file%dimensions, return_value )
2193
2194	!-- Initialize file variables
2195	IF ( return_value == 0 ) THEN
2196	DO d = 1, SIZE( file%variables )
2197
2198	CALL init_file_variable( file%format, file%id, file%name, &
2199	file%variables(d)%id, file%variables(d)%name, file%variables(d)%data_type, &
2200	file%variables(d)%dimension_ids, &
2201	file%variables(d)%is_global, return_value )
2202
2203	IF ( return_value == 0 .AND. ALLOCATED( file%variables(d)%attributes ) ) THEN
2204	!-- Write variable attributes
2205	DO a = 1, SIZE( file%variables(d)%attributes )
2206	return_value = write_attribute( file%format, file%id, file%name, &
2207	var_id=file%variables(d)%id, &
2208	var_name=file%variables(d)%name, &
2209	attribute=file%variables(d)%attributes(a) )
2210	IF ( return_value /= 0 ) EXIT
2211	ENDDO
2212	ENDIF
2213
2214	IF ( return_value /= 0 ) EXIT
2215
2216	ENDDO
2217	ENDIF
2218
2219	ENDIF
2220
2221	END SUBROUTINE dom_init_file_header
2222
2223	!--------------------------------------------------------------------------------------------------!
2224	! Description:
2225	! ------------
2226	!> Write attribute to file.
2227	!--------------------------------------------------------------------------------------------------!
2228	FUNCTION write_attribute( file_format, file_id, file_name, var_id, var_name, attribute ) RESULT( return_value )
2229
2230	CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file
2231	CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name
2232	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: var_name !< variable name
2233
2234	CHARACTER(LEN=*), PARAMETER :: routine_name = 'write_attribute' !< file format chosen for file
2235
2236	INTEGER(iwp), INTENT(IN) :: file_id !< file ID
2237	INTEGER(iwp) :: return_value !< return value
2238	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2239	INTEGER(iwp), INTENT(IN) :: var_id !< variable ID
2240
2241	TYPE(attribute_type), INTENT(IN) :: attribute !< attribute to be written
2242
2243
2244	return_value = 0
2245	output_return_value = 0
2246
2247	!-- Prepare for possible error message
2248	IF ( PRESENT( var_name ) ) THEN
2249	temp_string = '(file "' // TRIM( file_name ) // &
2250	'", variable "' // TRIM( var_name ) // &
2251	'", attribute "' // TRIM( attribute%name ) // '")'
2252	ELSE
2253	temp_string = '(file "' // TRIM( file_name ) // &
2254	'", attribute "' // TRIM( attribute%name ) // '")'
2255	ENDIF
2256
2257	!-- Write attribute to file
2258	SELECT CASE ( TRIM( file_format ) )
2259
2260	CASE ( 'binary' )
2261
2262	SELECT CASE ( TRIM( attribute%data_type ) )
2263
2264	CASE( 'char' )
2265	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2266	att_name=attribute%name, att_value_char=attribute%value_char, &
2267	return_value=output_return_value )
2268
2269	CASE( 'int8' )
2270	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2271	att_name=attribute%name, att_value_int8=attribute%value_int8, &
2272	return_value=output_return_value )
2273
2274	CASE( 'int16' )
2275	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2276	att_name=attribute%name, att_value_int16=attribute%value_int16, &
2277	return_value=output_return_value )
2278
2279	CASE( 'int32' )
2280	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2281	att_name=attribute%name, att_value_int32=attribute%value_int32, &
2282	return_value=output_return_value )
2283
2284	CASE( 'real32' )
2285	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2286	att_name=attribute%name, att_value_real32=attribute%value_real32, &
2287	return_value=output_return_value )
2288
2289	CASE( 'real64' )
2290	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2291	att_name=attribute%name, att_value_real64=attribute%value_real64, &
2292	return_value=output_return_value )
2293
2294	CASE DEFAULT
2295	return_value = 1
2296	CALL internal_message( 'error', routine_name // &
2297	': file format "' // TRIM( file_format ) // &
2298	'" does not support attribute data type "'// &
2299	TRIM( attribute%data_type ) // &
2300	'" ' // TRIM( temp_string ) )
2301
2302	END SELECT
2303
2304	CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
2305
2306	SELECT CASE ( TRIM( attribute%data_type ) )
2307
2308	CASE( 'char' )
2309	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2310	att_name=attribute%name, att_value_char=attribute%value_char, &
2311	return_value=output_return_value )
2312
2313	CASE( 'int8' )
2314	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2315	att_name=attribute%name, att_value_int8=attribute%value_int8, &
2316	return_value=output_return_value )
2317
2318	CASE( 'int16' )
2319	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2320	att_name=attribute%name, att_value_int16=attribute%value_int16, &
2321	return_value=output_return_value )
2322
2323	CASE( 'int32' )
2324	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2325	att_name=attribute%name, att_value_int32=attribute%value_int32, &
2326	return_value=output_return_value )
2327
2328	CASE( 'real32' )
2329	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2330	att_name=attribute%name, att_value_real32=attribute%value_real32, &
2331	return_value=output_return_value )
2332
2333	CASE( 'real64' )
2334	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2335	att_name=attribute%name, att_value_real64=attribute%value_real64, &
2336	return_value=output_return_value )
2337
2338	CASE DEFAULT
2339	return_value = 1
2340	CALL internal_message( 'error', routine_name // &
2341	': file format "' // TRIM( file_format ) // &
2342	'" does not support attribute data type "'// &
2343	TRIM( attribute%data_type ) // &
2344	'" ' // TRIM( temp_string ) )
2345
2346	END SELECT
2347
2348	CASE DEFAULT
2349	return_value = 1
2350	CALL internal_message( 'error', &
2351	routine_name // &
2352	': unsupported file format "' // TRIM( file_format ) // &
2353	'" ' // TRIM( temp_string ) )
2354
2355	END SELECT
2356
2357	IF ( output_return_value /= 0 ) THEN
2358	return_value = output_return_value
2359	CALL internal_message( 'error', &
2360	routine_name // &
2361	': error while writing attribute ' // TRIM( temp_string ) )
2362	ENDIF
2363
2364	END FUNCTION write_attribute
2365
2366	!--------------------------------------------------------------------------------------------------!
2367	! Description:
2368	! ------------
2369	!> Initialize dimension in file.
2370	!--------------------------------------------------------------------------------------------------!
2371	SUBROUTINE init_file_dimension( file_format, file_id, file_name, dim_id, var_id, &
2372	dim_name, dim_type, dim_length, return_value )
2373
2374	CHARACTER(LEN=*), INTENT(IN) :: dim_name !< name of dimension
2375	CHARACTER(LEN=*), INTENT(IN) :: dim_type !< data type of dimension
2376	CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file
2377	CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file
2378
2379	CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_dimension' !< file format chosen for file
2380
2381	INTEGER(iwp), INTENT(OUT) :: dim_id !< dimension ID
2382	INTEGER(iwp), INTENT(IN) :: dim_length !< length of dimension
2383	INTEGER(iwp), INTENT(IN) :: file_id !< file ID
2384	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2385	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
2386	INTEGER(iwp), INTENT(OUT) :: var_id !< associated variable ID
2387
2388
2389	return_value = 0
2390	output_return_value = 0
2391
2392	temp_string = '(file "' // TRIM( file_name ) // &
2393	'", dimension "' // TRIM( dim_name ) // '")'
2394
2395	SELECT CASE ( TRIM( file_format ) )
2396
2397	CASE ( 'binary' )
2398	CALL binary_init_dimension( 'binary', file_id, dim_id, var_id, &
2399	dim_name, dim_type, dim_length, return_value=output_return_value )
2400
2401	CASE ( 'netcdf4-serial' )
2402	CALL netcdf4_init_dimension( 'serial', file_id, dim_id, var_id, &
2403	dim_name, dim_type, dim_length, return_value=output_return_value )
2404
2405	CASE ( 'netcdf4-parallel' )
2406	CALL netcdf4_init_dimension( 'parallel', file_id, dim_id, var_id, &
2407	dim_name, dim_type, dim_length, return_value=output_return_value )
2408
2409	CASE DEFAULT
2410	return_value = 1
2411	CALL internal_message( 'error', routine_name // &
2412	': file format "' // TRIM( file_format ) // &
2413	'" not supported ' // TRIM( temp_string ) )
2414
2415	END SELECT
2416
2417	IF ( output_return_value /= 0 ) THEN
2418	return_value = output_return_value
2419	CALL internal_message( 'error', routine_name // &
2420	': error while defining dimension ' // TRIM( temp_string ) )
2421	ENDIF
2422
2423	END SUBROUTINE init_file_dimension
2424
2425	!--------------------------------------------------------------------------------------------------!
2426	! Description:
2427	! ------------
2428	!> Get dimension IDs and save them to variables.
2429	!--------------------------------------------------------------------------------------------------!
2430	SUBROUTINE collect_dimesion_ids_for_variables( variables, dimensions, return_value )
2431
2432	CHARACTER(LEN=*), PARAMETER :: routine_name = 'collect_dimesion_ids_for_variables' !< file format chosen for file
2433
2434	INTEGER(iwp) :: d !< loop index
2435	INTEGER(iwp) :: i !< loop index
2436	INTEGER(iwp) :: j !< loop index
2437	INTEGER(iwp) :: ndim !< number of dimensions
2438	INTEGER(iwp) :: nvar !< number of variables
2439	INTEGER(iwp) :: return_value !< return value
2440
2441	LOGICAL :: found !< true if dimension required by variable was found in dimension list
2442
2443	TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< list of dimensions in file
2444
2445	TYPE(variable_type), DIMENSION(:), INTENT(INOUT) :: variables !< list of variables in file
2446
2447
2448	return_value = 0
2449	ndim = SIZE( dimensions )
2450	nvar = SIZE( variables )
2451
2452	DO i = 1, nvar
2453	DO j = 1, SIZE( variables(i)%dimension_names )
2454	found = .FALSE.
2455	DO d = 1, ndim
2456	IF ( variables(i)%dimension_names(j) == dimensions(d)%name ) THEN
2457	variables(i)%dimension_ids(j) = dimensions(d)%id
2458	found = .TRUE.
2459	EXIT
2460	ENDIF
2461	ENDDO
2462	IF ( .NOT. found ) THEN
2463	return_value = 1
2464	CALL internal_message( 'error', &
2465	routine_name // ': variable "' // TRIM( variables(i)%name ) // &
2466	'": required dimension "' // TRIM( variables(i)%dimension_names(j) ) // &
2467	'" is undefined' )
2468	EXIT
2469	ENDIF
2470	ENDDO
2471	IF ( .NOT. found ) EXIT
2472	ENDDO
2473
2474	END SUBROUTINE collect_dimesion_ids_for_variables
2475
2476	!--------------------------------------------------------------------------------------------------!
2477	! Description:
2478	! ------------
2479	!> Initialize variable.
2480	!--------------------------------------------------------------------------------------------------!
2481	SUBROUTINE init_file_variable( file_format, file_id, file_name, &
2482	var_id, var_name, var_type, var_dim_id, &
2483	is_global, return_value )
2484
2485	CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file
2486	CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name
2487	CHARACTER(LEN=*), INTENT(IN) :: var_name !< name of variable
2488	CHARACTER(LEN=*), INTENT(IN) :: var_type !< data type of variable
2489
2490	CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_variable' !< file format chosen for file
2491
2492	INTEGER(iwp), INTENT(IN) :: file_id !< file ID
2493	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2494	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
2495	INTEGER(iwp), INTENT(OUT) :: var_id !< variable ID
2496
2497	INTEGER(iwp), DIMENSION(:), INTENT(IN) :: var_dim_id !< list of dimension IDs used by variable
2498
2499	LOGICAL, INTENT(IN) :: is_global !< true if variable is global
2500
2501
2502	return_value = 0
2503	output_return_value = 0
2504
2505	temp_string = '(file "' // TRIM( file_name ) // &
2506	'", variable "' // TRIM( var_name ) // '")'
2507
2508	SELECT CASE ( TRIM( file_format ) )
2509
2510	CASE ( 'binary' )
2511	CALL binary_init_variable( 'binary', file_id, var_id, var_name, var_type, &
2512	var_dim_id, is_global, return_value=output_return_value )
2513
2514	CASE ( 'netcdf4-serial' )
2515	CALL netcdf4_init_variable( 'serial', file_id, var_id, var_name, var_type, &
2516	var_dim_id, is_global, return_value=output_return_value )
2517
2518	CASE ( 'netcdf4-parallel' )
2519	CALL netcdf4_init_variable( 'parallel', file_id, var_id, var_name, var_type, &
2520	var_dim_id, is_global, return_value=output_return_value )
2521
2522	CASE DEFAULT
2523	return_value = 1
2524	CALL internal_message( 'error', routine_name // &
2525	': file format "' // TRIM( file_format ) // &
2526	'" not supported ' // TRIM( temp_string ) )
2527
2528	END SELECT
2529
2530	IF ( output_return_value /= 0 ) THEN
2531	return_value = output_return_value
2532	CALL internal_message( 'error', routine_name // &
2533	': error while defining variable ' // TRIM( temp_string ) )
2534	ENDIF
2535
2536	END SUBROUTINE init_file_variable
2537
2538	!--------------------------------------------------------------------------------------------------!
2539	! Description:
2540	! ------------
2541	!> Finalize file definition/initialization.
2542	!>
2543	!> @todo Do we need an MPI barrier at the end?
2544	!--------------------------------------------------------------------------------------------------!
2545	SUBROUTINE dom_init_end( file_format, file_id, file_name, return_value )
2546
2547	CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format
2548	CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name
2549
2550	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_init_end' !< name of routine
2551
2552	INTEGER(iwp), INTENT(IN) :: file_id !< file id
2553	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2554	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
2555
2556
2557	return_value = 0
2558	output_return_value = 0
2559
2560	temp_string = '(file "' // TRIM( file_name ) // '")'
2561
2562	SELECT CASE ( TRIM( file_format ) )
2563
2564	CASE ( 'binary' )
2565	CALL binary_init_end( file_id, output_return_value )
2566
2567	CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
2568	CALL netcdf4_init_end( file_id, output_return_value )
2569
2570	CASE DEFAULT
2571	return_value = 1
2572	CALL internal_message( 'error', routine_name // &
2573	': file format "' // TRIM( file_format ) // &
2574	'" not supported ' // TRIM( temp_string ) )
2575
2576	END SELECT
2577
2578	IF ( output_return_value /= 0 ) THEN
2579	return_value = output_return_value
2580	CALL internal_message( 'error', routine_name // &
2581	': error while leaving file-definition state ' // &
2582	TRIM( temp_string ) )
2583	ENDIF
2584
2585	! CALL MPI_Barrier( MPI_COMM_WORLD, return_value )
2586
2587	END SUBROUTINE dom_init_end
2588
2589	!--------------------------------------------------------------------------------------------------!
2590	! Description:
2591	! ------------
2592	!> Write variable to file.
2593	!> Example call:
2594	!> dom_write_var( file_format = 'binary', &
2595	!> filename = 'DATA_OUTPUT_3D', &
2596	!> name = 'u', &
2597	!> var_real64_3d = u, &
2598	!> bounds_start = (/nxl, nys, nzb, time_step/), &
2599	!> bounds_end = (/nxr, nyn, nzt, time_step/) )
2600	!> @note The order of dimension bounds must match to the order of dimensions given in call
2601	!> 'dom_def_var'. I.e., the corresponding variable definition should be like:
2602	!> dom_def_var( filename = 'DATA_OUTPUT_3D', &
2603	!> name = 'u', &
2604	!> dimension_names = (/'x ', 'y ', 'z ', 'time'/), &
2605	!> output_type = <desired-output-type> )
2606	!--------------------------------------------------------------------------------------------------!
2607	FUNCTION dom_write_var( filename, name, bounds_start, bounds_end, &
2608	var_int8_0d, var_int8_1d, var_int8_2d, var_int8_3d, &
2609	var_int16_0d, var_int16_1d, var_int16_2d, var_int16_3d, &
2610	var_int32_0d, var_int32_1d, var_int32_2d, var_int32_3d, &
2611	var_intwp_0d, var_intwp_1d, var_intwp_2d, var_intwp_3d, &
2612	var_real32_0d, var_real32_1d, var_real32_2d, var_real32_3d, &
2613	var_real64_0d, var_real64_1d, var_real64_2d, var_real64_3d, &
2614	var_realwp_0d, var_realwp_1d, var_realwp_2d, var_realwp_3d &
2615	) RESULT( return_value )
2616
2617	CHARACTER(LEN=charlen) :: file_format !< file format chosen for file
2618	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
2619	CHARACTER(LEN=*), INTENT(IN) :: name !< name of variable
2620
2621	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_write_var' !< name of routine
2622
2623	INTEGER(iwp) :: file_id !< file ID
2624	INTEGER(iwp) :: i !< loop index
2625	INTEGER(iwp) :: j !< loop index
2626	INTEGER(iwp) :: k !< loop index
2627	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2628	INTEGER(iwp) :: return_value !< return value
2629	INTEGER(iwp) :: var_id !< variable ID
2630
2631	INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_end !< end index per dimension of variable
2632	INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_start !< start index per dimension of variable
2633	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: bounds_origin !< first index of each dimension
2634	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: bounds_start_internal !< start index per dim. for output after masking
2635	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: value_counts !< count of indices to be written per dimension
2636	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: masked_indices !< list containing all output indices along a dimension
2637
2638	LOGICAL :: do_output !< true if any data lies within given range of masked dimension
2639	LOGICAL :: is_global !< true if variable is global
2640
2641	INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL :: var_int8_0d !< output variable
2642	INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int8_1d !< output variable
2643	INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int8_2d !< output variable
2644	INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int8_3d !< output variable
2645
2646	INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:) :: var_int8_1d_resorted !< resorted output variable
2647	INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_int8_2d_resorted !< resorted output variable
2648	INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_int8_3d_resorted !< resorted output variable
2649
2650	INTEGER(KIND=1), POINTER :: var_int8_0d_pointer !< output variable
2651	INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:) :: var_int8_1d_pointer !< output variable
2652	INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_int8_2d_pointer !< output variable
2653	INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_int8_3d_pointer !< output variable
2654
2655	INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL :: var_int16_0d !< output variable
2656	INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int16_1d !< output variable
2657	INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int16_2d !< output variable
2658	INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int16_3d !< output variable
2659
2660	INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:) :: var_int16_1d_resorted !< resorted output variable
2661	INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_int16_2d_resorted !< resorted output variable
2662	INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_int16_3d_resorted !< resorted output variable
2663
2664	INTEGER(KIND=2), POINTER :: var_int16_0d_pointer !< output variable
2665	INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:) :: var_int16_1d_pointer !< output variable
2666	INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_int16_2d_pointer !< output variable
2667	INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_int16_3d_pointer !< output variable
2668
2669	INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL :: var_int32_0d !< output variable
2670	INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int32_1d !< output variable
2671	INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int32_2d !< output variable
2672	INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int32_3d !< output variable
2673
2674	INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: var_int32_1d_resorted !< resorted output variable
2675	INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_int32_2d_resorted !< resorted output variable
2676	INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_int32_3d_resorted !< resorted output variable
2677
2678	INTEGER(KIND=4), POINTER :: var_int32_0d_pointer !< output variable
2679	INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:) :: var_int32_1d_pointer !< output variable
2680	INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_int32_2d_pointer !< output variable
2681	INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_int32_3d_pointer !< output variable
2682
2683	INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL :: var_intwp_0d !< output variable
2684	INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_intwp_1d !< output variable
2685	INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_intwp_2d !< output variable
2686	INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_intwp_3d !< output variable
2687
2688	INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:) :: var_intwp_1d_resorted !< resorted output variable
2689	INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_intwp_2d_resorted !< resorted output variable
2690	INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_intwp_3d_resorted !< resorted output variable
2691
2692	INTEGER(iwp), POINTER :: var_intwp_0d_pointer !< output variable
2693	INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:) :: var_intwp_1d_pointer !< output variable
2694	INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_intwp_2d_pointer !< output variable
2695	INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_intwp_3d_pointer !< output variable
2696
2697	REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: var_real32_0d !< output variable
2698	REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_real32_1d !< output variable
2699	REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_real32_2d !< output variable
2700	REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_real32_3d !< output variable
2701
2702	REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: var_real32_1d_resorted !< resorted output variable
2703	REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_real32_2d_resorted !< resorted output variable
2704	REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_real32_3d_resorted !< resorted output variable
2705
2706	REAL(KIND=4), POINTER :: var_real32_0d_pointer !< output variable
2707	REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:) :: var_real32_1d_pointer !< output variable
2708	REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_real32_2d_pointer !< output variable
2709	REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_real32_3d_pointer !< output variable
2710
2711	REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL :: var_real64_0d !< output variable
2712	REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_real64_1d !< output variable
2713	REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_real64_2d !< output variable
2714	REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_real64_3d !< output variable
2715
2716	REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:) :: var_real64_1d_resorted !< resorted output variable
2717	REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_real64_2d_resorted !< resorted output variable
2718	REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_real64_3d_resorted !< resorted output variable
2719
2720	REAL(KIND=8), POINTER :: var_real64_0d_pointer !< output variable
2721	REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:) :: var_real64_1d_pointer !< output variable
2722	REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_real64_2d_pointer !< output variable
2723	REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_real64_3d_pointer !< output variable
2724
2725	REAL(wp), POINTER, INTENT(IN), OPTIONAL :: var_realwp_0d !< output variable
2726	REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_realwp_1d !< output variable
2727	REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_realwp_2d !< output variable
2728	REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_realwp_3d !< output variable
2729
2730	REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:) :: var_realwp_1d_resorted !< resorted output variable
2731	REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_realwp_2d_resorted !< resorted output variable
2732	REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_realwp_3d_resorted !< resorted output variable
2733
2734	REAL(wp), POINTER :: var_realwp_0d_pointer !< output variable
2735	REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:) :: var_realwp_1d_pointer !< output variable
2736	REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_realwp_2d_pointer !< output variable
2737	REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_realwp_3d_pointer !< output variable
2738
2739	TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dimension_list !< list of used dimensions of variable
2740
2741
2742	return_value = 0
2743	output_return_value = 0
2744
2745	CALL internal_message( 'debug', routine_name // ': write ' // TRIM( name ) // &
2746	' into file ' // TRIM( filename ) )
2747
2748	!-- Search for variable within file
2749	CALL find_var_in_file( filename, name, file_format, file_id, var_id, &
2750	is_global, dimension_list, return_value=return_value )
2751
2752	IF ( return_value == 0 ) THEN
2753
2754	!-- Check if the correct amount of variable bounds were given
2755	IF ( SIZE( bounds_start ) /= SIZE( dimension_list ) .OR. &
2756	SIZE( bounds_end ) /= SIZE( dimension_list ) ) THEN
2757	return_value = 1
2758	CALL internal_message( 'error', routine_name // &
2759	': variable "' // TRIM( name ) // &
2760	'" in file "' // TRIM( filename ) // &
2761	'": given bounds do not match with number of dimensions' )
2762	ENDIF
2763
2764	ENDIF
2765
2766
2767	IF ( return_value == 0 ) THEN
2768
2769	!-- Save starting index (lower bounds) of each dimension
2770	ALLOCATE( bounds_origin(SIZE( dimension_list )) )
2771	ALLOCATE( bounds_start_internal(SIZE( dimension_list )) )
2772	ALLOCATE( value_counts(SIZE( dimension_list )) )
2773
2774	WRITE( temp_string, * ) bounds_start
2775	CALL internal_message( 'debug', routine_name // &
2776	': file "' // TRIM( filename ) // &
2777	'": variable "' // TRIM( name ) // &
2778	'": bounds_start =' // TRIM( temp_string ) )
2779	WRITE( temp_string, * ) bounds_end
2780	CALL internal_message( 'debug', routine_name // &
2781	': file "' // TRIM( filename ) // &
2782	'": variable "' // TRIM( name ) // &
2783	'": bounds_end =' // TRIM( temp_string ) )
2784
2785	!-- Get bounds for masking
2786	CALL get_masked_indices_and_masked_dimension_bounds( dimension_list, &
2787	bounds_start, bounds_end, bounds_start_internal, value_counts, bounds_origin, &
2788	masked_indices )
2789
2790	do_output = .NOT. ANY( value_counts == 0 )
2791
2792	WRITE( temp_string, * ) bounds_start_internal
2793	CALL internal_message( 'debug', routine_name // &
2794	': file "' // TRIM( filename ) // &
2795	'": variable "' // TRIM( name ) // &
2796	'": bounds_start_internal =' // TRIM( temp_string ) )
2797	WRITE( temp_string, * ) value_counts
2798	CALL internal_message( 'debug', routine_name // &
2799	': file "' // TRIM( filename ) // &
2800	'": variable "' // TRIM( name ) // &
2801	'": value_counts =' // TRIM( temp_string ) )
2802
2803	!-- Mask and resort variable
2804	!-- 8bit integer output
2805	IF ( PRESENT( var_int8_0d ) ) THEN
2806	var_int8_0d_pointer => var_int8_0d
2807	ELSEIF ( PRESENT( var_int8_1d ) ) THEN
2808	IF ( do_output ) THEN
2809	ALLOCATE( var_int8_1d_resorted(0:value_counts(1)-1) )
2810	!$OMP PARALLEL PRIVATE (i)
2811	!$OMP DO
2812	DO i = 0, value_counts(1) - 1
2813	var_int8_1d_resorted(i) = var_int8_1d(masked_indices(1,i))
2814	ENDDO
2815	!$OMP END PARALLEL
2816	ELSE
2817	ALLOCATE( var_int8_1d_resorted(1) )
2818	var_int8_1d_resorted = 0_1
2819	ENDIF
2820	var_int8_1d_pointer => var_int8_1d_resorted
2821	ELSEIF ( PRESENT( var_int8_2d ) ) THEN
2822	IF ( do_output ) THEN
2823	ALLOCATE( var_int8_2d_resorted(0:value_counts(1)-1, &
2824	0:value_counts(2)-1) )
2825	!$OMP PARALLEL PRIVATE (i,j)
2826	!$OMP DO
2827	DO i = 0, value_counts(1) - 1
2828	DO j = 0, value_counts(2) - 1
2829	var_int8_2d_resorted(i,j) = var_int8_2d(masked_indices(2,j), &
2830	masked_indices(1,i) )
2831	ENDDO
2832	ENDDO
2833	!$OMP END PARALLEL
2834	ELSE
2835	ALLOCATE( var_int8_2d_resorted(1,1) )
2836	var_int8_2d_resorted = 0_1
2837	ENDIF
2838	var_int8_2d_pointer => var_int8_2d_resorted
2839	ELSEIF ( PRESENT( var_int8_3d ) ) THEN
2840	IF ( do_output ) THEN
2841	ALLOCATE( var_int8_3d_resorted(0:value_counts(1)-1, &
2842	0:value_counts(2)-1, &
2843	0:value_counts(3)-1) )
2844	!$OMP PARALLEL PRIVATE (i,j,k)
2845	!$OMP DO
2846	DO i = 0, value_counts(1) - 1
2847	DO j = 0, value_counts(2) - 1
2848	DO k = 0, value_counts(3) - 1
2849	var_int8_3d_resorted(i,j,k) = var_int8_3d(masked_indices(3,k), &
2850	masked_indices(2,j), &
2851	masked_indices(1,i) )
2852	ENDDO
2853	ENDDO
2854	ENDDO
2855	!$OMP END PARALLEL
2856	ELSE
2857	ALLOCATE( var_int8_3d_resorted(1,1,1) )
2858	var_int8_3d_resorted = 0_1
2859	ENDIF
2860	var_int8_3d_pointer => var_int8_3d_resorted
2861
2862	!-- 16bit integer output
2863	ELSEIF ( PRESENT( var_int16_0d ) ) THEN
2864	var_int16_0d_pointer => var_int16_0d
2865	ELSEIF ( PRESENT( var_int16_1d ) ) THEN
2866	IF ( do_output ) THEN
2867	ALLOCATE( var_int16_1d_resorted(0:value_counts(1)-1) )
2868	!$OMP PARALLEL PRIVATE (i)
2869	!$OMP DO
2870	DO i = 0, value_counts(1) - 1
2871	var_int16_1d_resorted(i) = var_int16_1d(masked_indices(1,i))
2872	ENDDO
2873	!$OMP END PARALLEL
2874	ELSE
2875	ALLOCATE( var_int16_1d_resorted(1) )
2876	var_int16_1d_resorted = 0_1
2877	ENDIF
2878	var_int16_1d_pointer => var_int16_1d_resorted
2879	ELSEIF ( PRESENT( var_int16_2d ) ) THEN
2880	IF ( do_output ) THEN
2881	ALLOCATE( var_int16_2d_resorted(0:value_counts(1)-1, &
2882	0:value_counts(2)-1) )
2883	!$OMP PARALLEL PRIVATE (i,j)
2884	!$OMP DO
2885	DO i = 0, value_counts(1) - 1
2886	DO j = 0, value_counts(2) - 1
2887	var_int16_2d_resorted(i,j) = var_int16_2d(masked_indices(2,j), &
2888	masked_indices(1,i))
2889	ENDDO
2890	ENDDO
2891	!$OMP END PARALLEL
2892	ELSE
2893	ALLOCATE( var_int16_2d_resorted(1,1) )
2894	var_int16_2d_resorted = 0_1
2895	ENDIF
2896	var_int16_2d_pointer => var_int16_2d_resorted
2897	ELSEIF ( PRESENT( var_int16_3d ) ) THEN
2898	IF ( do_output ) THEN
2899	ALLOCATE( var_int16_3d_resorted(0:value_counts(1)-1, &
2900	0:value_counts(2)-1, &
2901	0:value_counts(3)-1) )
2902	!$OMP PARALLEL PRIVATE (i,j,k)
2903	!$OMP DO
2904	DO i = 0, value_counts(1) - 1
2905	DO j = 0, value_counts(2) - 1
2906	DO k = 0, value_counts(3) - 1
2907	var_int16_3d_resorted(i,j,k) = var_int16_3d(masked_indices(3,k), &
2908	masked_indices(2,j), &
2909	masked_indices(1,i) )
2910	ENDDO
2911	ENDDO
2912	ENDDO
2913	!$OMP END PARALLEL
2914	ELSE
2915	ALLOCATE( var_int16_3d_resorted(1,1,1) )
2916	var_int16_3d_resorted = 0_1
2917	ENDIF
2918	var_int16_3d_pointer => var_int16_3d_resorted
2919
2920	!-- 32bit integer output
2921	ELSEIF ( PRESENT( var_int32_0d ) ) THEN
2922	var_int32_0d_pointer => var_int32_0d
2923	ELSEIF ( PRESENT( var_int32_1d ) ) THEN
2924	IF ( do_output ) THEN
2925	ALLOCATE( var_int32_1d_resorted(0:value_counts(1)-1) )
2926	!$OMP PARALLEL PRIVATE (i)
2927	!$OMP DO
2928	DO i = 0, value_counts(1) - 1
2929	var_int32_1d_resorted(i) = var_int32_1d(masked_indices(1,i))
2930	ENDDO
2931	!$OMP END PARALLEL
2932	ELSE
2933	ALLOCATE( var_int32_1d_resorted(1) )
2934	var_int32_1d_resorted = 0_1
2935	ENDIF
2936	var_int32_1d_pointer => var_int32_1d_resorted
2937	ELSEIF ( PRESENT( var_int32_2d ) ) THEN
2938	IF ( do_output ) THEN
2939	ALLOCATE( var_int32_2d_resorted(0:value_counts(1)-1, &
2940	0:value_counts(2)-1) )
2941	!$OMP PARALLEL PRIVATE (i,j)
2942	!$OMP DO
2943	DO i = 0, value_counts(1) - 1
2944	DO j = 0, value_counts(2) - 1
2945	var_int32_2d_resorted(i,j) = var_int32_2d(masked_indices(2,j), &
2946	masked_indices(1,i) )
2947	ENDDO
2948	ENDDO
2949	!$OMP END PARALLEL
2950	ELSE
2951	ALLOCATE( var_int32_2d_resorted(1,1) )
2952	var_int32_2d_resorted = 0_1
2953	ENDIF
2954	var_int32_2d_pointer => var_int32_2d_resorted
2955	ELSEIF ( PRESENT( var_int32_3d ) ) THEN
2956	IF ( do_output ) THEN
2957	ALLOCATE( var_int32_3d_resorted(0:value_counts(1)-1, &
2958	0:value_counts(2)-1, &
2959	0:value_counts(3)-1) )
2960	!$OMP PARALLEL PRIVATE (i,j,k)
2961	!$OMP DO
2962	DO i = 0, value_counts(1) - 1
2963	DO j = 0, value_counts(2) - 1
2964	DO k = 0, value_counts(3) - 1
2965	var_int32_3d_resorted(i,j,k) = var_int32_3d(masked_indices(3,k), &
2966	masked_indices(2,j), &
2967	masked_indices(1,i) )
2968	ENDDO
2969	ENDDO
2970	ENDDO
2971	!$OMP END PARALLEL
2972	ELSE
2973	ALLOCATE( var_int32_3d_resorted(1,1,1) )
2974	var_int32_3d_resorted = 0_1
2975	ENDIF
2976	var_int32_3d_pointer => var_int32_3d_resorted
2977
2978	!-- working-precision integer output
2979	ELSEIF ( PRESENT( var_intwp_0d ) ) THEN
2980	var_intwp_0d_pointer => var_intwp_0d
2981	ELSEIF ( PRESENT( var_intwp_1d ) ) THEN
2982	IF ( do_output ) THEN
2983	ALLOCATE( var_intwp_1d_resorted(0:value_counts(1)-1) )
2984	!$OMP PARALLEL PRIVATE (i)
2985	!$OMP DO
2986	DO i = 0, value_counts(1) - 1
2987	var_intwp_1d_resorted(i) = var_intwp_1d(masked_indices(1,i))
2988	ENDDO
2989	!$OMP END PARALLEL
2990	ELSE
2991	ALLOCATE( var_intwp_1d_resorted(1) )
2992	var_intwp_1d_resorted = 0_1
2993	ENDIF
2994	var_intwp_1d_pointer => var_intwp_1d_resorted
2995	ELSEIF ( PRESENT( var_intwp_2d ) ) THEN
2996	IF ( do_output ) THEN
2997	ALLOCATE( var_intwp_2d_resorted(0:value_counts(1)-1, &
2998	0:value_counts(2)-1) )
2999	!$OMP PARALLEL PRIVATE (i,j)
3000	!$OMP DO
3001	DO i = 0, value_counts(1) - 1
3002	DO j = 0, value_counts(2) - 1
3003	var_intwp_2d_resorted(i,j) = var_intwp_2d(masked_indices(2,j), &
3004	masked_indices(1,i) )
3005	ENDDO
3006	ENDDO
3007	!$OMP END PARALLEL
3008	ELSE
3009	ALLOCATE( var_intwp_2d_resorted(1,1) )
3010	var_intwp_2d_resorted = 0_1
3011	ENDIF
3012	var_intwp_2d_pointer => var_intwp_2d_resorted
3013	ELSEIF ( PRESENT( var_intwp_3d ) ) THEN
3014	IF ( do_output ) THEN
3015	ALLOCATE( var_intwp_3d_resorted(0:value_counts(1)-1, &
3016	0:value_counts(2)-1, &
3017	0:value_counts(3)-1) )
3018	!$OMP PARALLEL PRIVATE (i,j,k)
3019	!$OMP DO
3020	DO i = 0, value_counts(1) - 1
3021	DO j = 0, value_counts(2) - 1
3022	DO k = 0, value_counts(3) - 1
3023	var_intwp_3d_resorted(i,j,k) = var_intwp_3d(masked_indices(3,k), &
3024	masked_indices(2,j), &
3025	masked_indices(1,i) )
3026	ENDDO
3027	ENDDO
3028	ENDDO
3029	!$OMP END PARALLEL
3030	ELSE
3031	ALLOCATE( var_intwp_3d_resorted(1,1,1) )
3032	var_intwp_3d_resorted = 0_1
3033	ENDIF
3034	var_intwp_3d_pointer => var_intwp_3d_resorted
3035
3036	!-- 32bit real output
3037	ELSEIF ( PRESENT( var_real32_0d ) ) THEN
3038	var_real32_0d_pointer => var_real32_0d
3039	ELSEIF ( PRESENT( var_real32_1d ) ) THEN
3040	IF ( do_output ) THEN
3041	ALLOCATE( var_real32_1d_resorted(0:value_counts(1)-1) )
3042	!$OMP PARALLEL PRIVATE (i)
3043	!$OMP DO
3044	DO i = 0, value_counts(1) - 1
3045	var_real32_1d_resorted(i) = var_real32_1d(masked_indices(1,i))
3046	ENDDO
3047	!$OMP END PARALLEL
3048	ELSE
3049	ALLOCATE( var_real32_1d_resorted(1) )
3050	var_real32_1d_resorted = 0_1
3051	ENDIF
3052	var_real32_1d_pointer => var_real32_1d_resorted
3053	ELSEIF ( PRESENT( var_real32_2d ) ) THEN
3054	IF ( do_output ) THEN
3055	ALLOCATE( var_real32_2d_resorted(0:value_counts(1)-1, &
3056	0:value_counts(2)-1) )
3057	!$OMP PARALLEL PRIVATE (i,j)
3058	!$OMP DO
3059	DO i = 0, value_counts(1) - 1
3060	DO j = 0, value_counts(2) - 1
3061	var_real32_2d_resorted(i,j) = var_real32_2d(masked_indices(2,j), &
3062	masked_indices(1,i) )
3063	ENDDO
3064	ENDDO
3065	!$OMP END PARALLEL
3066	ELSE
3067	ALLOCATE( var_real32_2d_resorted(1,1) )
3068	var_real32_2d_resorted = 0_1
3069	ENDIF
3070	var_real32_2d_pointer => var_real32_2d_resorted
3071	ELSEIF ( PRESENT( var_real32_3d ) ) THEN
3072	IF ( do_output ) THEN
3073	ALLOCATE( var_real32_3d_resorted(0:value_counts(1)-1, &
3074	0:value_counts(2)-1, &
3075	0:value_counts(3)-1) )
3076	!$OMP PARALLEL PRIVATE (i,j,k)
3077	!$OMP DO
3078	DO i = 0, value_counts(1) - 1
3079	DO j = 0, value_counts(2) - 1
3080	DO k = 0, value_counts(3) - 1
3081	var_real32_3d_resorted(i,j,k) = var_real32_3d(masked_indices(3,k), &
3082	masked_indices(2,j), &
3083	masked_indices(1,i) )
3084	ENDDO
3085	ENDDO
3086	ENDDO
3087	!$OMP END PARALLEL
3088	ELSE
3089	ALLOCATE( var_real32_3d_resorted(1,1,1) )
3090	var_real32_3d_resorted = 0_1
3091	ENDIF
3092	var_real32_3d_pointer => var_real32_3d_resorted
3093
3094	!-- 64bit real output
3095	ELSEIF ( PRESENT( var_real64_0d ) ) THEN
3096	var_real64_0d_pointer => var_real64_0d
3097	ELSEIF ( PRESENT( var_real64_1d ) ) THEN
3098	IF ( do_output ) THEN
3099	ALLOCATE( var_real64_1d_resorted(0:value_counts(1)-1) )
3100	!$OMP PARALLEL PRIVATE (i)
3101	!$OMP DO
3102	DO i = 0, value_counts(1) - 1
3103	var_real64_1d_resorted(i) = var_real64_1d(masked_indices(1,i))
3104	ENDDO
3105	!$OMP END PARALLEL
3106	ELSE
3107	ALLOCATE( var_real64_1d_resorted(1) )
3108	var_real64_1d_resorted = 0_1
3109	ENDIF
3110	var_real64_1d_pointer => var_real64_1d_resorted
3111	ELSEIF ( PRESENT( var_real64_2d ) ) THEN
3112	IF ( do_output ) THEN
3113	ALLOCATE( var_real64_2d_resorted(0:value_counts(1)-1, &
3114	0:value_counts(2)-1) )
3115	!$OMP PARALLEL PRIVATE (i,j)
3116	!$OMP DO
3117	DO i = 0, value_counts(1) - 1
3118	DO j = 0, value_counts(2) - 1
3119	var_real64_2d_resorted(i,j) = var_real64_2d(masked_indices(2,j), &
3120	masked_indices(1,i) )
3121	ENDDO
3122	ENDDO
3123	!$OMP END PARALLEL
3124	ELSE
3125	ALLOCATE( var_real64_2d_resorted(1,1) )
3126	var_real64_2d_resorted = 0_1
3127	ENDIF
3128	var_real64_2d_pointer => var_real64_2d_resorted
3129	ELSEIF ( PRESENT( var_real64_3d ) ) THEN
3130	IF ( do_output ) THEN
3131	ALLOCATE( var_real64_3d_resorted(0:value_counts(1)-1, &
3132	0:value_counts(2)-1, &
3133	0:value_counts(3)-1) )
3134	!$OMP PARALLEL PRIVATE (i,j,k)
3135	!$OMP DO
3136	DO i = 0, value_counts(1) - 1
3137	DO j = 0, value_counts(2) - 1
3138	DO k = 0, value_counts(3) - 1
3139	var_real64_3d_resorted(i,j,k) = var_real64_3d(masked_indices(3,k), &
3140	masked_indices(2,j), &
3141	masked_indices(1,i) )
3142	ENDDO
3143	ENDDO
3144	ENDDO
3145	!$OMP END PARALLEL
3146	ELSE
3147	ALLOCATE( var_real64_3d_resorted(1,1,1) )
3148	var_real64_3d_resorted = 0_1
3149	ENDIF
3150	var_real64_3d_pointer => var_real64_3d_resorted
3151
3152	!-- working-precision real output
3153	ELSEIF ( PRESENT( var_realwp_0d ) ) THEN
3154	var_realwp_0d_pointer => var_realwp_0d
3155	ELSEIF ( PRESENT( var_realwp_1d ) ) THEN
3156	IF ( do_output ) THEN
3157	ALLOCATE( var_realwp_1d_resorted(0:value_counts(1)-1) )
3158	!$OMP PARALLEL PRIVATE (i)
3159	!$OMP DO
3160	DO i = 0, value_counts(1) - 1
3161	var_realwp_1d_resorted(i) = var_realwp_1d(masked_indices(1,i))
3162	ENDDO
3163	!$OMP END PARALLEL
3164	ELSE
3165	ALLOCATE( var_realwp_1d_resorted(1) )
3166	var_realwp_1d_resorted = 0_1
3167	ENDIF
3168	var_realwp_1d_pointer => var_realwp_1d_resorted
3169	ELSEIF ( PRESENT( var_realwp_2d ) ) THEN
3170	IF ( do_output ) THEN
3171	ALLOCATE( var_realwp_2d_resorted(0:value_counts(1)-1, &
3172	0:value_counts(2)-1) )
3173	!$OMP PARALLEL PRIVATE (i,j)
3174	!$OMP DO
3175	DO i = 0, value_counts(1) - 1
3176	DO j = 0, value_counts(2) - 1
3177	var_realwp_2d_resorted(i,j) = var_realwp_2d(masked_indices(2,j), &
3178	masked_indices(1,i) )
3179	ENDDO
3180	ENDDO
3181	!$OMP END PARALLEL
3182	ELSE
3183	ALLOCATE( var_realwp_2d_resorted(1,1) )
3184	var_realwp_2d_resorted = 0_1
3185	ENDIF
3186	var_realwp_2d_pointer => var_realwp_2d_resorted
3187	ELSEIF ( PRESENT( var_realwp_3d ) ) THEN
3188	IF ( do_output ) THEN
3189	ALLOCATE( var_realwp_3d_resorted(0:value_counts(1)-1, &
3190	0:value_counts(2)-1, &
3191	0:value_counts(3)-1) )
3192	!$OMP PARALLEL PRIVATE (i,j,k)
3193	!$OMP DO
3194	DO i = 0, value_counts(1) - 1
3195	DO j = 0, value_counts(2) - 1
3196	DO k = 0, value_counts(3) - 1
3197	var_realwp_3d_resorted(i,j,k) = var_realwp_3d(masked_indices(3,k), &
3198	masked_indices(2,j), &
3199	masked_indices(1,i) )
3200	ENDDO
3201	ENDDO
3202	ENDDO
3203	!$OMP END PARALLEL
3204	ELSE
3205	ALLOCATE( var_realwp_3d_resorted(1,1,1) )
3206	var_realwp_3d_resorted = 0_1
3207	ENDIF
3208	var_realwp_3d_pointer => var_realwp_3d_resorted
3209
3210	ELSE
3211	return_value = 1
3212	CALL internal_message( 'error', routine_name // &
3213	': variable "' // TRIM( name ) // &
3214	'" in file "' // TRIM( filename ) // &
3215	'": no values given to output' )
3216	ENDIF
3217
3218	DEALLOCATE( masked_indices )
3219
3220	ENDIF ! Check for error
3221
3222	IF ( return_value == 0 ) THEN
3223
3224	!-- Write variable into file
3225	SELECT CASE ( TRIM( file_format ) )
3226
3227	CASE ( 'binary' )
3228	!-- 8bit integer output
3229	IF ( PRESENT( var_int8_0d ) ) THEN
3230	CALL binary_write_variable( file_id, var_id, &
3231	bounds_start_internal, value_counts, bounds_origin, is_global, &
3232	var_int8_0d=var_int8_0d_pointer, return_value=output_return_value )
3233	ELSEIF ( PRESENT( var_int8_1d ) ) THEN
3234	CALL binary_write_variable( file_id, var_id, &
3235	bounds_start_internal, value_counts, bounds_origin, is_global, &
3236	var_int8_1d=var_int8_1d_pointer, return_value=output_return_value )
3237	ELSEIF ( PRESENT( var_int8_2d ) ) THEN
3238	CALL binary_write_variable( file_id, var_id, &
3239	bounds_start_internal, value_counts, bounds_origin, is_global, &
3240	var_int8_2d=var_int8_2d_pointer, return_value=output_return_value )
3241	ELSEIF ( PRESENT( var_int8_3d ) ) THEN
3242	CALL binary_write_variable( file_id, var_id, &
3243	bounds_start_internal, value_counts, bounds_origin, is_global, &
3244	var_int8_3d=var_int8_3d_pointer, return_value=output_return_value )
3245	!-- 16bit integer output
3246	ELSEIF ( PRESENT( var_int16_0d ) ) THEN
3247	CALL binary_write_variable( file_id, var_id, &
3248	bounds_start_internal, value_counts, bounds_origin, is_global, &
3249	var_int16_0d=var_int16_0d_pointer, return_value=output_return_value )
3250	ELSEIF ( PRESENT( var_int16_1d ) ) THEN
3251	CALL binary_write_variable( file_id, var_id, &
3252	bounds_start_internal, value_counts, bounds_origin, is_global, &
3253	var_int16_1d=var_int16_1d_pointer, return_value=output_return_value )
3254	ELSEIF ( PRESENT( var_int16_2d ) ) THEN
3255	CALL binary_write_variable( file_id, var_id, &
3256	bounds_start_internal, value_counts, bounds_origin, is_global, &
3257	var_int16_2d=var_int16_2d_pointer, return_value=output_return_value )
3258	ELSEIF ( PRESENT( var_int16_3d ) ) THEN
3259	CALL binary_write_variable( file_id, var_id, &
3260	bounds_start_internal, value_counts, bounds_origin, is_global, &
3261	var_int16_3d=var_int16_3d_pointer, return_value=output_return_value )
3262	!-- 32bit integer output
3263	ELSEIF ( PRESENT( var_int32_0d ) ) THEN
3264	CALL binary_write_variable( file_id, var_id, &
3265	bounds_start_internal, value_counts, bounds_origin, is_global, &
3266	var_int32_0d=var_int32_0d_pointer, return_value=output_return_value )
3267	ELSEIF ( PRESENT( var_int32_1d ) ) THEN
3268	CALL binary_write_variable( file_id, var_id, &
3269	bounds_start_internal, value_counts, bounds_origin, is_global, &
3270	var_int32_1d=var_int32_1d_pointer, return_value=output_return_value )
3271	ELSEIF ( PRESENT( var_int32_2d ) ) THEN
3272	CALL binary_write_variable( file_id, var_id, &
3273	bounds_start_internal, value_counts, bounds_origin, is_global, &
3274	var_int32_2d=var_int32_2d_pointer, return_value=output_return_value )
3275	ELSEIF ( PRESENT( var_int32_3d ) ) THEN
3276	CALL binary_write_variable( file_id, var_id, &
3277	bounds_start_internal, value_counts, bounds_origin, is_global, &
3278	var_int32_3d=var_int32_3d_pointer, return_value=output_return_value )
3279	!-- working-precision integer output
3280	ELSEIF ( PRESENT( var_intwp_0d ) ) THEN
3281	CALL binary_write_variable( file_id, var_id, &
3282	bounds_start_internal, value_counts, bounds_origin, is_global, &
3283	var_intwp_0d=var_intwp_0d_pointer, return_value=output_return_value )
3284	ELSEIF ( PRESENT( var_intwp_1d ) ) THEN
3285	CALL binary_write_variable( file_id, var_id, &
3286	bounds_start_internal, value_counts, bounds_origin, is_global, &
3287	var_intwp_1d=var_intwp_1d_pointer, return_value=output_return_value )
3288	ELSEIF ( PRESENT( var_intwp_2d ) ) THEN
3289	CALL binary_write_variable( file_id, var_id, &
3290	bounds_start_internal, value_counts, bounds_origin, is_global, &
3291	var_intwp_2d=var_intwp_2d_pointer, return_value=output_return_value )
3292	ELSEIF ( PRESENT( var_intwp_3d ) ) THEN
3293	CALL binary_write_variable( file_id, var_id, &
3294	bounds_start_internal, value_counts, bounds_origin, is_global, &
3295	var_intwp_3d=var_intwp_3d_pointer, return_value=output_return_value )
3296	!-- 32bit real output
3297	ELSEIF ( PRESENT( var_real32_0d ) ) THEN
3298	CALL binary_write_variable( file_id, var_id, &
3299	bounds_start_internal, value_counts, bounds_origin, is_global, &
3300	var_real32_0d=var_real32_0d_pointer, return_value=output_return_value )
3301	ELSEIF ( PRESENT( var_real32_1d ) ) THEN
3302	CALL binary_write_variable( file_id, var_id, &
3303	bounds_start_internal, value_counts, bounds_origin, is_global, &
3304	var_real32_1d=var_real32_1d_pointer, return_value=output_return_value )
3305	ELSEIF ( PRESENT( var_real32_2d ) ) THEN
3306	CALL binary_write_variable( file_id, var_id, &
3307	bounds_start_internal, value_counts, bounds_origin, is_global, &
3308	var_real32_2d=var_real32_2d_pointer, return_value=output_return_value )
3309	ELSEIF ( PRESENT( var_real32_3d ) ) THEN
3310	CALL binary_write_variable( file_id, var_id, &
3311	bounds_start_internal, value_counts, bounds_origin, is_global, &
3312	var_real32_3d=var_real32_3d_pointer, return_value=output_return_value )
3313	!-- 64bit real output
3314	ELSEIF ( PRESENT( var_real64_0d ) ) THEN
3315	CALL binary_write_variable( file_id, var_id, &
3316	bounds_start_internal, value_counts, bounds_origin, is_global, &
3317	var_real64_0d=var_real64_0d_pointer, return_value=output_return_value )
3318	ELSEIF ( PRESENT( var_real64_1d ) ) THEN
3319	CALL binary_write_variable( file_id, var_id, &
3320	bounds_start_internal, value_counts, bounds_origin, is_global, &
3321	var_real64_1d=var_real64_1d_pointer, return_value=output_return_value )
3322	ELSEIF ( PRESENT( var_real64_2d ) ) THEN
3323	CALL binary_write_variable( file_id, var_id, &
3324	bounds_start_internal, value_counts, bounds_origin, is_global, &
3325	var_real64_2d=var_real64_2d_pointer, return_value=output_return_value )
3326	ELSEIF ( PRESENT( var_real64_3d ) ) THEN
3327	CALL binary_write_variable( file_id, var_id, &
3328	bounds_start_internal, value_counts, bounds_origin, is_global, &
3329	var_real64_3d=var_real64_3d_pointer, return_value=output_return_value )
3330	!-- working-precision real output
3331	ELSEIF ( PRESENT( var_realwp_0d ) ) THEN
3332	CALL binary_write_variable( file_id, var_id, &
3333	bounds_start_internal, value_counts, bounds_origin, is_global, &
3334	var_realwp_0d=var_realwp_0d_pointer, return_value=output_return_value )
3335	ELSEIF ( PRESENT( var_realwp_1d ) ) THEN
3336	CALL binary_write_variable( file_id, var_id, &
3337	bounds_start_internal, value_counts, bounds_origin, is_global, &
3338	var_realwp_1d=var_realwp_1d_pointer, return_value=output_return_value )
3339	ELSEIF ( PRESENT( var_realwp_2d ) ) THEN
3340	CALL binary_write_variable( file_id, var_id, &
3341	bounds_start_internal, value_counts, bounds_origin, is_global, &
3342	var_realwp_2d=var_realwp_2d_pointer, return_value=output_return_value )
3343	ELSEIF ( PRESENT( var_realwp_3d ) ) THEN
3344	CALL binary_write_variable( file_id, var_id, &
3345	bounds_start_internal, value_counts, bounds_origin, is_global, &
3346	var_realwp_3d=var_realwp_3d_pointer, return_value=output_return_value )
3347	ELSE
3348	return_value = 1
3349	CALL internal_message( 'error', routine_name // &
3350	': variable "' // TRIM( name ) // &
3351	'" in file "' // TRIM( filename ) // &
3352	'": output_type not supported by file format "' // &
3353	TRIM( file_format ) // '"' )
3354	ENDIF
3355
3356	CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
3357	!-- 8bit integer output
3358	IF ( PRESENT( var_int8_0d ) ) THEN
3359	CALL netcdf4_write_variable( file_id, var_id, &
3360	bounds_start_internal, value_counts, bounds_origin, is_global, &
3361	var_int8_0d=var_int8_0d_pointer, return_value=output_return_value )
3362	ELSEIF ( PRESENT( var_int8_1d ) ) THEN
3363	CALL netcdf4_write_variable( file_id, var_id, &
3364	bounds_start_internal, value_counts, bounds_origin, is_global, &
3365	var_int8_1d=var_int8_1d_pointer, return_value=output_return_value )
3366	ELSEIF ( PRESENT( var_int8_2d ) ) THEN
3367	CALL netcdf4_write_variable( file_id, var_id, &
3368	bounds_start_internal, value_counts, bounds_origin, is_global, &
3369	var_int8_2d=var_int8_2d_pointer, return_value=output_return_value )
3370	ELSEIF ( PRESENT( var_int8_3d ) ) THEN
3371	CALL netcdf4_write_variable( file_id, var_id, &
3372	bounds_start_internal, value_counts, bounds_origin, is_global, &
3373	var_int8_3d=var_int8_3d_pointer, return_value=output_return_value )
3374	!-- 16bit integer output
3375	ELSEIF ( PRESENT( var_int16_0d ) ) THEN
3376	CALL netcdf4_write_variable( file_id, var_id, &
3377	bounds_start_internal, value_counts, bounds_origin, is_global, &
3378	var_int16_0d=var_int16_0d_pointer, return_value=output_return_value )
3379	ELSEIF ( PRESENT( var_int16_1d ) ) THEN
3380	CALL netcdf4_write_variable( file_id, var_id, &
3381	bounds_start_internal, value_counts, bounds_origin, is_global, &
3382	var_int16_1d=var_int16_1d_pointer, return_value=output_return_value )
3383	ELSEIF ( PRESENT( var_int16_2d ) ) THEN
3384	CALL netcdf4_write_variable( file_id, var_id, &
3385	bounds_start_internal, value_counts, bounds_origin, is_global, &
3386	var_int16_2d=var_int16_2d_pointer, return_value=output_return_value )
3387	ELSEIF ( PRESENT( var_int16_3d ) ) THEN
3388	CALL netcdf4_write_variable( file_id, var_id, &
3389	bounds_start_internal, value_counts, bounds_origin, is_global, &
3390	var_int16_3d=var_int16_3d_pointer, return_value=output_return_value )
3391	!-- 32bit integer output
3392	ELSEIF ( PRESENT( var_int32_0d ) ) THEN
3393	CALL netcdf4_write_variable( file_id, var_id, &
3394	bounds_start_internal, value_counts, bounds_origin, is_global, &
3395	var_int32_0d=var_int32_0d_pointer, return_value=output_return_value )
3396	ELSEIF ( PRESENT( var_int32_1d ) ) THEN
3397	CALL netcdf4_write_variable( file_id, var_id, &
3398	bounds_start_internal, value_counts, bounds_origin, is_global, &
3399	var_int32_1d=var_int32_1d_pointer, return_value=output_return_value )
3400	ELSEIF ( PRESENT( var_int32_2d ) ) THEN
3401	CALL netcdf4_write_variable( file_id, var_id, &
3402	bounds_start_internal, value_counts, bounds_origin, is_global, &
3403	var_int32_2d=var_int32_2d_pointer, return_value=output_return_value )
3404	ELSEIF ( PRESENT( var_int32_3d ) ) THEN
3405	CALL netcdf4_write_variable( file_id, var_id, &
3406	bounds_start_internal, value_counts, bounds_origin, is_global, &
3407	var_int32_3d=var_int32_3d_pointer, return_value=output_return_value )
3408	!-- working-precision integer output
3409	ELSEIF ( PRESENT( var_intwp_0d ) ) THEN
3410	CALL netcdf4_write_variable( file_id, var_id, &
3411	bounds_start_internal, value_counts, bounds_origin, is_global, &
3412	var_intwp_0d=var_intwp_0d_pointer, return_value=output_return_value )
3413	ELSEIF ( PRESENT( var_intwp_1d ) ) THEN
3414	CALL netcdf4_write_variable( file_id, var_id, &
3415	bounds_start_internal, value_counts, bounds_origin, is_global, &
3416	var_intwp_1d=var_intwp_1d_pointer, return_value=output_return_value )
3417	ELSEIF ( PRESENT( var_intwp_2d ) ) THEN
3418	CALL netcdf4_write_variable( file_id, var_id, &
3419	bounds_start_internal, value_counts, bounds_origin, is_global, &
3420	var_intwp_2d=var_intwp_2d_pointer, return_value=output_return_value )
3421	ELSEIF ( PRESENT( var_intwp_3d ) ) THEN
3422	CALL netcdf4_write_variable( file_id, var_id, &
3423	bounds_start_internal, value_counts, bounds_origin, is_global, &
3424	var_intwp_3d=var_intwp_3d_pointer, return_value=output_return_value )
3425	!-- 32bit real output
3426	ELSEIF ( PRESENT( var_real32_0d ) ) THEN
3427	CALL netcdf4_write_variable( file_id, var_id, &
3428	bounds_start_internal, value_counts, bounds_origin, is_global, &
3429	var_real32_0d=var_real32_0d_pointer, return_value=output_return_value )
3430	ELSEIF ( PRESENT( var_real32_1d ) ) THEN
3431	CALL netcdf4_write_variable( file_id, var_id, &
3432	bounds_start_internal, value_counts, bounds_origin, is_global, &
3433	var_real32_1d=var_real32_1d_pointer, return_value=output_return_value )
3434	ELSEIF ( PRESENT( var_real32_2d ) ) THEN
3435	CALL netcdf4_write_variable( file_id, var_id, &
3436	bounds_start_internal, value_counts, bounds_origin, is_global, &
3437	var_real32_2d=var_real32_2d_pointer, return_value=output_return_value )
3438	ELSEIF ( PRESENT( var_real32_3d ) ) THEN
3439	CALL netcdf4_write_variable( file_id, var_id, &
3440	bounds_start_internal, value_counts, bounds_origin, is_global, &
3441	var_real32_3d=var_real32_3d_pointer, return_value=output_return_value )
3442	!-- 64bit real output
3443	ELSEIF ( PRESENT( var_real64_0d ) ) THEN
3444	CALL netcdf4_write_variable( file_id, var_id, &
3445	bounds_start_internal, value_counts, bounds_origin, is_global, &
3446	var_real64_0d=var_real64_0d_pointer, return_value=output_return_value )
3447	ELSEIF ( PRESENT( var_real64_1d ) ) THEN
3448	CALL netcdf4_write_variable( file_id, var_id, &
3449	bounds_start_internal, value_counts, bounds_origin, is_global, &
3450	var_real64_1d=var_real64_1d_pointer, return_value=output_return_value )
3451	ELSEIF ( PRESENT( var_real64_2d ) ) THEN
3452	CALL netcdf4_write_variable( file_id, var_id, &
3453	bounds_start_internal, value_counts, bounds_origin, is_global, &
3454	var_real64_2d=var_real64_2d_pointer, return_value=output_return_value )
3455	ELSEIF ( PRESENT( var_real64_3d ) ) THEN
3456	CALL netcdf4_write_variable( file_id, var_id, &
3457	bounds_start_internal, value_counts, bounds_origin, is_global, &
3458	var_real64_3d=var_real64_3d_pointer, return_value=output_return_value )
3459	!-- working-precision real output
3460	ELSEIF ( PRESENT( var_realwp_0d ) ) THEN
3461	CALL netcdf4_write_variable( file_id, var_id, &
3462	bounds_start_internal, value_counts, bounds_origin, is_global, &
3463	var_realwp_0d=var_realwp_0d_pointer, return_value=output_return_value )
3464	ELSEIF ( PRESENT( var_realwp_1d ) ) THEN
3465	CALL netcdf4_write_variable( file_id, var_id, &
3466	bounds_start_internal, value_counts, bounds_origin, is_global, &
3467	var_realwp_1d=var_realwp_1d_pointer, return_value=output_return_value )
3468	ELSEIF ( PRESENT( var_realwp_2d ) ) THEN
3469	CALL netcdf4_write_variable( file_id, var_id, &
3470	bounds_start_internal, value_counts, bounds_origin, is_global, &
3471	var_realwp_2d=var_realwp_2d_pointer, return_value=output_return_value )
3472	ELSEIF ( PRESENT( var_realwp_3d ) ) THEN
3473	CALL netcdf4_write_variable( file_id, var_id, &
3474	bounds_start_internal, value_counts, bounds_origin, is_global, &
3475	var_realwp_3d=var_realwp_3d_pointer, return_value=output_return_value )
3476	ELSE
3477	return_value = 1
3478	CALL internal_message( 'error', routine_name // &
3479	': variable "' // TRIM( name ) // &
3480	'" in file "' // TRIM( filename ) // &
3481	'": output_type not supported by file format "' // &
3482	TRIM( file_format ) // '"' )
3483	ENDIF
3484
3485	CASE DEFAULT
3486	return_value = 1
3487	CALL internal_message( 'error', routine_name // &
3488	': file "' // TRIM( filename ) // &
3489	'": file format "' // TRIM( file_format ) // &
3490	'" not supported' )
3491
3492	END SELECT
3493
3494	IF ( return_value == 0 .AND. output_return_value /= 0 ) THEN
3495	return_value = 1
3496	CALL internal_message( 'error', routine_name // &
3497	': error while writing variable "' // TRIM( name ) // &
3498	'" in file "' // TRIM( filename ) // '"' )
3499	ENDIF
3500
3501	ENDIF
3502
3503	END FUNCTION dom_write_var
3504
3505	!--------------------------------------------------------------------------------------------------!
3506	! Description:
3507	! ------------
3508	!> Find a requested variable 'var_name' and its used dimensions in requested file 'filename'.
3509	!--------------------------------------------------------------------------------------------------!
3510	SUBROUTINE find_var_in_file( filename, var_name, file_format, file_id, var_id, &
3511	is_global, dimensions, return_value )
3512
3513	CHARACTER(LEN=charlen), INTENT(OUT) :: file_format !< file format chosen for file
3514	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
3515	CHARACTER(LEN=*), INTENT(IN) :: var_name !< name of variable
3516
3517	CHARACTER(LEN=*), PARAMETER :: routine_name = 'find_var_in_file' !< name of routine
3518
3519	INTEGER(iwp) :: d !< loop index
3520	INTEGER(iwp) :: dd !< loop index
3521	INTEGER(iwp) :: f !< loop index
3522	INTEGER(iwp), INTENT(OUT) :: file_id !< file ID
3523	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
3524	INTEGER(iwp), INTENT(OUT) :: var_id !< variable ID
3525
3526	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: dim_ids !< list of dimension IDs used by variable
3527
3528	LOGICAL :: found !< true if requested variable found in requested file
3529	LOGICAL, INTENT(OUT) :: is_global !< true if variable is global
3530
3531	TYPE(dimension_type), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dimensions !< list of dimensions used by variable
3532
3533
3534	return_value = 0
3535	found = .FALSE.
3536
3537	DO f = 1, nf
3538	IF ( TRIM( filename ) == TRIM( files(f)%name ) ) THEN
3539
3540	IF ( .NOT. files(f)%is_init ) THEN
3541	return_value = 1
3542	CALL internal_message( 'error', routine_name // &
3543	': file "' // TRIM( filename ) // &
3544	'" is not initialized. ' // &
3545	'Writing variable "' // TRIM( var_name ) // &
3546	'" to file is impossible.' )
3547	EXIT
3548	ENDIF
3549
3550	file_id = files(f)%id
3551	file_format = files(f)%format
3552
3553	!-- Search for variable in file
3554	DO d = 1, SIZE( files(f)%variables )
3555	IF ( TRIM( var_name ) == TRIM( files(f)%variables(d)%name ) ) THEN
3556
3557	var_id = files(f)%variables(d)%id
3558	is_global = files(f)%variables(d)%is_global
3559
3560	ALLOCATE( dim_ids(SIZE( files(f)%variables(d)%dimension_ids )) )
3561	ALLOCATE( dimensions(SIZE( files(f)%variables(d)%dimension_ids )) )
3562
3563	dim_ids = files(f)%variables(d)%dimension_ids
3564
3565	found = .TRUE.
3566	EXIT
3567
3568	ENDIF
3569	ENDDO
3570
3571	IF ( found ) THEN
3572
3573	!-- Get list of dimensions used by variable
3574	DO d = 1, SIZE( files(f)%dimensions )
3575	DO dd = 1, SIZE( dim_ids )
3576	IF ( dim_ids(dd) == files(f)%dimensions(d)%id ) THEN
3577	dimensions(dd) = files(f)%dimensions(d)
3578	EXIT
3579	ENDIF
3580	ENDDO
3581	ENDDO
3582
3583	ELSE
3584
3585	!-- If variable was not found, search for a dimension instead
3586	DO d = 1, SIZE( files(f)%dimensions )
3587	IF ( TRIM( var_name ) == TRIM( files(f)%dimensions(d)%name ) ) THEN
3588
3589	var_id = files(f)%dimensions(d)%var_id
3590	is_global = .TRUE.
3591
3592	ALLOCATE( dimensions(1) )
3593
3594	dimensions(1) = files(f)%dimensions(d)
3595
3596	found = .TRUE.
3597	EXIT
3598
3599	ENDIF
3600	ENDDO
3601
3602	ENDIF
3603
3604	!-- If variable was not found in requested file, return an error
3605	IF ( .NOT. found ) THEN
3606	return_value = 1
3607	CALL internal_message( 'error', routine_name // &
3608	': variable "' // TRIM( var_name ) // &
3609	'" not found in file "' // TRIM( filename ) // '"' )
3610	ENDIF
3611
3612	EXIT
3613
3614	ENDIF ! file found
3615	ENDDO ! loop over files
3616
3617	IF ( .NOT. found .AND. return_value == 0 ) THEN
3618	return_value = 1
3619	CALL internal_message( 'error', routine_name // &
3620	': file "' // TRIM( filename ) // &
3621	'" for variable "' // TRIM( var_name ) // &
3622	'" not found' )
3623	ENDIF
3624
3625	END SUBROUTINE find_var_in_file
3626
3627	!--------------------------------------------------------------------------------------------------!
3628	! Description:
3629	! ------------
3630	!> Search for masked indices of dimensions within the given bounds ('bounds_start' and
3631	!> 'bounds_end'). Return the masked indices ('masked_indices') of the dimensions, the first index
3632	!> of the masked dimensions containing these indices ('bounds_masked_start'), the count of masked
3633	!> indices within given bounds ('value_counts') and the origin index of each dimension
3634	!> ('bounds_origin'). If, for any dimension, no masked index lies within the given bounds, counts,
3635	!> starts and origins are set to zero for all dimensions.
3636	!--------------------------------------------------------------------------------------------------!
3637	SUBROUTINE get_masked_indices_and_masked_dimension_bounds( &
3638	dimensions, bounds_start, bounds_end, bounds_masked_start, value_counts, &
3639	bounds_origin, masked_indices )
3640
3641	! CHARACTER(LEN=*), PARAMETER :: routine_name = 'get_masked_indices_and_masked_dimension_bounds' !< name of routine
3642
3643	INTEGER(iwp) :: d !< loop index
3644	INTEGER(iwp) :: i !< loop index
3645
3646	INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_end !< upper bonuds to be searched in
3647	INTEGER(iwp), DIMENSION(:), INTENT(OUT) :: bounds_masked_start !< lower bounds of masked dimensions within given bounds
3648	INTEGER(iwp), DIMENSION(:), INTENT(OUT) :: bounds_origin !< first index of each dimension, 0 if dimension is masked
3649	INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_start !< lower bounds to be searched in
3650	INTEGER(iwp), DIMENSION(:), INTENT(OUT) :: value_counts !< count of indices per dimension to be output
3651
3652	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: masked_indices !< masked indices within given bounds
3653
3654	TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< dimensions to be searched for masked indices
3655
3656
3657	ALLOCATE( masked_indices(SIZE( dimensions ),0:MAXVAL( bounds_end - bounds_start + 1 )) )
3658	masked_indices = -HUGE( 0_iwp )
3659
3660	!-- Check for masking and update lower and upper bounds if masked
3661	DO d = 1, SIZE( dimensions )
3662
3663	IF ( dimensions(d)%is_masked ) THEN
3664
3665	bounds_origin(d) = 0
3666
3667	bounds_masked_start(d) = -HUGE( 0_iwp )
3668
3669	!-- Find number of masked values within given variable bounds
3670	value_counts(d) = 0
3671	DO i = LBOUND( dimensions(d)%masked_indices, DIM=1 ), &
3672	UBOUND( dimensions(d)%masked_indices, DIM=1 )
3673
3674	!-- Is masked index within given bounds?
3675	IF ( dimensions(d)%masked_indices(i) >= bounds_start(d) .AND. &
3676	dimensions(d)%masked_indices(i) <= bounds_end(d) ) THEN
3677
3678	!-- Save masked index
3679	masked_indices(d,value_counts(d)) = dimensions(d)%masked_indices(i)
3680	value_counts(d) = value_counts(d) + 1
3681
3682	!-- Save bounds of mask within given bounds
3683	IF ( bounds_masked_start(d) == -HUGE( 0_iwp ) ) bounds_masked_start(d) = i
3684
3685	ENDIF
3686
3687	ENDDO
3688
3689	!-- Set masked bounds to zero if no masked index lies within bounds
3690	IF ( value_counts(d) == 0 ) THEN
3691	bounds_origin(:) = 0
3692	bounds_masked_start(:) = 0_iwp
3693	value_counts(:) = 0_iwp
3694	EXIT
3695	ENDIF
3696
3697	ELSE
3698
3699	!-- If dimension is not masked, save all indices within bounds for output
3700	bounds_origin(d) = dimensions(d)%bounds(1)
3701	bounds_masked_start(d) = bounds_start(d)
3702	value_counts(d) = bounds_end(d) - bounds_start(d) + 1
3703
3704	DO i = 0, value_counts(d) - 1
3705	masked_indices(d,i) = bounds_start(d) + i
3706	ENDDO
3707
3708	ENDIF
3709
3710	ENDDO
3711
3712	END SUBROUTINE get_masked_indices_and_masked_dimension_bounds
3713
3714	!--------------------------------------------------------------------------------------------------!
3715	! Description:
3716	! ------------
3717	!> Finalize output.
3718	!--------------------------------------------------------------------------------------------------!
3719	FUNCTION dom_finalize_output() RESULT( return_value )
3720
3721	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_finalize_output' !< name of routine
3722
3723	INTEGER(iwp) :: return_value !< return value
3724	INTEGER(iwp) :: return_value_internal !< error code after closing a single file
3725	INTEGER(iwp) :: output_return_value !< return value from called routines
3726	INTEGER(iwp) :: f !< loop index
3727
3728
3729	return_value = 0
3730
3731	DO f = 1, nf
3732
3733	IF ( files(f)%is_init ) THEN
3734
3735	output_return_value = 0
3736	return_value_internal = 0
3737
3738	SELECT CASE ( TRIM( files(f)%format ) )
3739
3740	CASE ( 'binary' )
3741	CALL binary_finalize( files(f)%id, output_return_value )
3742
3743	CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
3744	CALL netcdf4_finalize( files(f)%id, output_return_value )
3745
3746	CASE DEFAULT
3747	return_value_internal = 1
3748
3749	END SELECT
3750
3751	IF ( output_return_value /= 0 ) THEN
3752	return_value = output_return_value
3753	CALL internal_message( 'error', routine_name // &
3754	': error while finalizing file "' // &
3755	TRIM( files(f)%name ) // '"' )
3756	ELSEIF ( return_value_internal /= 0 ) THEN
3757	return_value = return_value_internal
3758	CALL internal_message( 'error', routine_name // &
3759	': unsupported file format "' // &
3760	TRIM( files(f)%format ) // '"' )
3761	ENDIF
3762
3763	ENDIF
3764
3765	ENDDO
3766
3767	END FUNCTION dom_finalize_output
3768
3769	!--------------------------------------------------------------------------------------------------!
3770	! Description:
3771	! ------------
3772	!> Message routine writing debug information into the debug file
3773	!> or creating the error message string.
3774	!--------------------------------------------------------------------------------------------------!
3775	SUBROUTINE internal_message( level, string )
3776
3777	CHARACTER(LEN=*), INTENT(IN) :: level !< message importance level
3778	CHARACTER(LEN=*), INTENT(IN) :: string !< message string
3779
3780
3781	IF ( TRIM( level ) == 'error' ) THEN
3782
3783	WRITE( internal_error_message, '(A,A)' ) 'DOM ERROR: ', string
3784
3785	ELSEIF ( TRIM( level ) == 'debug' .AND. print_debug_output ) THEN
3786
3787	WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
3788	FLUSH( debug_output_unit )
3789
3790	ENDIF
3791
3792	END SUBROUTINE internal_message
3793
3794	!--------------------------------------------------------------------------------------------------!
3795	! Description:
3796	! ------------
3797	!> Return the last created error message.
3798	!--------------------------------------------------------------------------------------------------!
3799	SUBROUTINE dom_get_error_message( error_message )
3800
3801	CHARACTER(LEN=800), INTENT(OUT) :: error_message !< return error message to main program
3802	CHARACTER(LEN=800) :: output_error_message !< error message created by other module
3803
3804
3805	CALL binary_get_error_message( output_error_message )
3806	internal_error_message = TRIM( internal_error_message ) // output_error_message
3807
3808	CALL netcdf4_get_error_message( output_error_message )
3809	internal_error_message = TRIM( internal_error_message ) // output_error_message
3810
3811	error_message = internal_error_message
3812
3813	END SUBROUTINE dom_get_error_message
3814
3815	END MODULE data_output_module

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |