Home

Context Navigation

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

Last change on this file since 4116 was 4116, checked in by gronemeier, 5 years ago
bugfix: check for empty file list in data_ouput_module when starting output
Property svn:keywords set to `Id`
File size: 174.9 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 4116 2019-07-24 15:17:16Z 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 = 0 !< 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 = 0 !< 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 = 0 !< 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 = 0 !< 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 = 0, dimension%length-1
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	!--------------------------------------------------------------------------------------------------!
1088	FUNCTION dom_def_var( filename, name, dimension_names, output_type, is_global ) &
1089	RESULT( return_value )
1090
1091	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1092	CHARACTER(LEN=*), INTENT(IN) :: name !< name of variable
1093	CHARACTER(LEN=*), INTENT(IN) :: output_type !< data type of variable
1094
1095	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_var' !< name of this routine
1096
1097	CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: dimension_names !< list of dimension names
1098
1099	INTEGER(iwp) :: d !< loop index
1100	INTEGER(iwp) :: f !< loop index
1101	INTEGER(iwp) :: i !< loop index
1102	INTEGER(iwp) :: nvar !< number of variables in file
1103	INTEGER(iwp) :: return_value !< return value
1104
1105	LOGICAL :: found = .FALSE. !< true if requested dimension is defined in file
1106	LOGICAL, INTENT(IN), OPTIONAL :: is_global !< true if variable is global (same on all PE)
1107
1108	TYPE(variable_type) :: variable !< new variable
1109
1110	TYPE(variable_type), DIMENSION(:), ALLOCATABLE :: vars_tmp !< temporary variable list
1111
1112
1113	return_value = 0
1114
1115	CALL internal_message( 'debug', routine_name // &
1116	': define variable "' // TRIM( name ) // &
1117	'" in file "' // TRIM( filename ) // '"' )
1118
1119	variable%name = TRIM( name )
1120
1121	ALLOCATE( variable%dimension_names(SIZE( dimension_names )) )
1122	ALLOCATE( variable%dimension_ids(SIZE( dimension_names )) )
1123
1124	variable%dimension_names = dimension_names
1125	variable%data_type = TRIM( output_type )
1126
1127	IF ( PRESENT( is_global ) ) THEN
1128	variable%is_global = is_global
1129	ELSE
1130	variable%is_global = .FALSE.
1131	ENDIF
1132
1133	!-- Add variable to database
1134	DO f = 1, nf
1135
1136	IF ( TRIM( filename ) == files(f)%name ) THEN
1137
1138	IF ( files(f)%is_init ) THEN
1139
1140	return_value = 1
1141	CALL internal_message( 'error', routine_name // ': file "' // TRIM( filename ) // &
1142	'" is already initialized. No further variable definition allowed!' )
1143	EXIT
1144
1145	ELSEIF ( ALLOCATED( files(f)%dimensions ) ) THEN
1146
1147	!-- Check if any dimension of the same name as the new variable is already defined
1148	DO d = 1, SIZE( files(f)%dimensions )
1149	IF ( files(f)%dimensions(d)%name == variable%name ) THEN
1150	return_value = 1
1151	CALL internal_message( 'error', routine_name // &
1152	': file "' // TRIM( filename ) // &
1153	'" already has a dimension of name "' // &
1154	TRIM( variable%name ) // '" defined. ' // &
1155	'Defining a variable of the same name is not allowed.' )
1156	EXIT
1157	ENDIF
1158	ENDDO
1159
1160	!-- Check if dimensions assigned to variable are defined within file
1161	IF ( return_value == 0 ) THEN
1162	DO i = 1, SIZE( variable%dimension_names )
1163	found = .FALSE.
1164	DO d = 1, SIZE( files(f)%dimensions )
1165	IF ( files(f)%dimensions(d)%name == variable%dimension_names(i) ) THEN
1166	found = .TRUE.
1167	EXIT
1168	ENDIF
1169	ENDDO
1170	IF ( .NOT. found ) THEN
1171	return_value = 1
1172	CALL internal_message( 'error', &
1173	routine_name // &
1174	': required dimension "' // &
1175	TRIM( variable%dimension_names(i) ) // &
1176	'" for variable "' // TRIM( name ) // &
1177	'" is not defined in file "' // TRIM( filename ) // &
1178	'"!' )
1179	EXIT
1180	ENDIF
1181	ENDDO
1182	ENDIF
1183
1184	ELSE
1185
1186	return_value = 1
1187	CALL internal_message( 'error', routine_name // &
1188	': cannot define variable "' // TRIM( name ) // &
1189	'" in file "' // TRIM( filename ) // &
1190	'" because no dimensions defined in file.' )
1191
1192	ENDIF
1193
1194	IF ( return_value == 0 ) THEN
1195
1196	!-- Check if variable already exists
1197	IF ( .NOT. ALLOCATED( files(f)%variables ) ) THEN
1198
1199	nvar = 1
1200	ALLOCATE( files(f)%variables(nvar) )
1201
1202	ELSE
1203
1204	nvar = SIZE( files(f)%variables )
1205	DO i = 1, nvar
1206	IF ( files(f)%variables(i)%name == variable%name ) THEN
1207	return_value = 1
1208	CALL internal_message( 'error', routine_name // &
1209	': variable "' // TRIM( name ) // &
1210	'" already exists in file "' // &
1211	TRIM( filename ) // '"!' )
1212	EXIT
1213	ENDIF
1214	ENDDO
1215
1216	IF ( return_value == 0 ) THEN
1217	!-- Extend variable list
1218	ALLOCATE( vars_tmp(nvar) )
1219	vars_tmp = files(f)%variables
1220	DEALLOCATE( files(f)%variables )
1221	nvar = nvar + 1
1222	ALLOCATE( files(f)%variables(nvar) )
1223	files(f)%variables(:nvar-1) = vars_tmp
1224	DEALLOCATE( vars_tmp )
1225	ENDIF
1226
1227	ENDIF
1228
1229	!-- Add new variable to database
1230	IF ( return_value == 0 ) files(f)%variables(nvar) = variable
1231
1232	ENDIF
1233
1234	EXIT
1235
1236	ENDIF
1237
1238	ENDDO
1239
1240	IF ( f > nf ) THEN
1241	return_value = 1
1242	CALL internal_message( 'error', routine_name // &
1243	': file not found (variable "' // TRIM( name ) // &
1244	'", file "' // TRIM( filename ) // '")!' )
1245	ENDIF
1246
1247	END FUNCTION dom_def_var
1248
1249	!--------------------------------------------------------------------------------------------------!
1250	! Description:
1251	! ------------
1252	!> Create attribute with value of type character.
1253	!--------------------------------------------------------------------------------------------------!
1254	FUNCTION dom_def_att_char( filename, variable, name, value, append ) RESULT( return_value )
1255
1256	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1257	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1258	CHARACTER(LEN=*), INTENT(IN) :: value !< attribute value
1259	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1260
1261	! CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_char' !< name of routine
1262
1263	INTEGER(iwp) :: return_value !< return value
1264
1265	LOGICAL :: append_internal !< same as 'append'
1266	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1267
1268	TYPE(attribute_type) :: attribute !< new attribute
1269
1270
1271	return_value = 0
1272
1273	IF ( PRESENT( append ) ) THEN
1274	append_internal = append
1275	ELSE
1276	append_internal = .FALSE.
1277	ENDIF
1278
1279	attribute%name = TRIM( name )
1280	attribute%data_type = 'char'
1281	attribute%value_char = TRIM( value )
1282
1283	IF ( PRESENT( variable ) ) THEN
1284	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1285	attribute=attribute, append=append_internal )
1286	ELSE
1287	return_value = dom_def_att_save( TRIM( filename ), &
1288	attribute=attribute, append=append_internal )
1289	ENDIF
1290
1291	END FUNCTION dom_def_att_char
1292
1293	!--------------------------------------------------------------------------------------------------!
1294	! Description:
1295	! ------------
1296	!> Create attribute with value of type int8.
1297	!--------------------------------------------------------------------------------------------------!
1298	FUNCTION dom_def_att_int8( filename, variable, name, value, append ) RESULT( return_value )
1299
1300	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1301	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1302	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1303
1304	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int8' !< name of routine
1305
1306	INTEGER(KIND=1), INTENT(IN) :: value !< attribute value
1307
1308	INTEGER(iwp) :: return_value !< return value
1309
1310	LOGICAL :: append_internal !< same as 'append'
1311	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1312
1313	TYPE(attribute_type) :: attribute !< new attribute
1314
1315
1316	return_value = 0
1317
1318	IF ( PRESENT( append ) ) THEN
1319	IF ( append ) THEN
1320	return_value = 1
1321	CALL internal_message( 'error', &
1322	routine_name // &
1323	': attribute "' // TRIM( name ) // &
1324	'": append of numeric attribute not possible.' )
1325	ENDIF
1326	ENDIF
1327
1328	IF ( return_value == 0 ) THEN
1329	append_internal = .FALSE.
1330
1331	attribute%name = TRIM( name )
1332	attribute%data_type = 'int8'
1333	attribute%value_int8 = value
1334
1335	IF ( PRESENT( variable ) ) THEN
1336	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1337	attribute=attribute, append=append_internal )
1338	ELSE
1339	return_value = dom_def_att_save( TRIM( filename ), &
1340	attribute=attribute, append=append_internal )
1341	ENDIF
1342	ENDIF
1343
1344	END FUNCTION dom_def_att_int8
1345
1346	!--------------------------------------------------------------------------------------------------!
1347	! Description:
1348	! ------------
1349	!> Create attribute with value of type int16.
1350	!--------------------------------------------------------------------------------------------------!
1351	FUNCTION dom_def_att_int16( filename, variable, name, value, append ) RESULT( return_value )
1352
1353	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1354	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1355	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1356
1357	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int16' !< name of routine
1358
1359	INTEGER(KIND=2), INTENT(IN) :: value !< attribute value
1360
1361	INTEGER(iwp) :: return_value !< return value
1362
1363	LOGICAL :: append_internal !< same as 'append'
1364	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1365
1366	TYPE(attribute_type) :: attribute !< new attribute
1367
1368
1369	return_value = 0
1370
1371	IF ( PRESENT( append ) ) THEN
1372	IF ( append ) THEN
1373	return_value = 1
1374	CALL internal_message( 'error', &
1375	routine_name // &
1376	': attribute "' // TRIM( name ) // &
1377	'": append of numeric attribute not possible.' )
1378	ENDIF
1379	ENDIF
1380
1381	IF ( return_value == 0 ) THEN
1382	append_internal = .FALSE.
1383
1384	attribute%name = TRIM( name )
1385	attribute%data_type = 'int16'
1386	attribute%value_int16 = value
1387
1388	IF ( PRESENT( variable ) ) THEN
1389	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1390	attribute=attribute, append=append_internal )
1391	ELSE
1392	return_value = dom_def_att_save( TRIM( filename ), &
1393	attribute=attribute, append=append_internal )
1394	ENDIF
1395	ENDIF
1396
1397	END FUNCTION dom_def_att_int16
1398
1399	!--------------------------------------------------------------------------------------------------!
1400	! Description:
1401	! ------------
1402	!> Create attribute with value of type int32.
1403	!--------------------------------------------------------------------------------------------------!
1404	FUNCTION dom_def_att_int32( filename, variable, name, value, append ) RESULT( return_value )
1405
1406	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1407	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1408	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1409
1410	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int32' !< name of routine
1411
1412	INTEGER(KIND=4), INTENT(IN) :: value !< attribute value
1413
1414	INTEGER(iwp) :: return_value !< return value
1415
1416	LOGICAL :: append_internal !< same as 'append'
1417	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1418
1419	TYPE(attribute_type) :: attribute !< new attribute
1420
1421
1422	return_value = 0
1423
1424	IF ( PRESENT( append ) ) THEN
1425	IF ( append ) THEN
1426	return_value = 1
1427	CALL internal_message( 'error', &
1428	routine_name // &
1429	': attribute "' // TRIM( name ) // &
1430	'": append of numeric attribute not possible.' )
1431	ENDIF
1432	ENDIF
1433
1434	IF ( return_value == 0 ) THEN
1435	append_internal = .FALSE.
1436
1437	attribute%name = TRIM( name )
1438	attribute%data_type = 'int32'
1439	attribute%value_int32 = value
1440
1441	IF ( PRESENT( variable ) ) THEN
1442	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1443	attribute=attribute, append=append_internal )
1444	ELSE
1445	return_value = dom_def_att_save( TRIM( filename ), &
1446	attribute=attribute, append=append_internal )
1447	ENDIF
1448	ENDIF
1449
1450	END FUNCTION dom_def_att_int32
1451
1452	!--------------------------------------------------------------------------------------------------!
1453	! Description:
1454	! ------------
1455	!> Create attribute with value of type real32.
1456	!--------------------------------------------------------------------------------------------------!
1457	FUNCTION dom_def_att_real32( filename, variable, name, value, append ) RESULT( return_value )
1458
1459	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1460	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1461	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1462
1463	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real32' !< name of routine
1464
1465	INTEGER(iwp) :: return_value !< return value
1466
1467	LOGICAL :: append_internal !< same as 'append'
1468	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1469
1470	REAL(KIND=4), INTENT(IN) :: value !< attribute value
1471
1472	TYPE(attribute_type) :: attribute !< new attribute
1473
1474
1475	return_value = 0
1476
1477	IF ( PRESENT( append ) ) THEN
1478	IF ( append ) THEN
1479	return_value = 1
1480	CALL internal_message( 'error', &
1481	routine_name // &
1482	': attribute "' // TRIM( name ) // &
1483	'": append of numeric attribute not possible.' )
1484	ENDIF
1485	ENDIF
1486
1487	IF ( return_value == 0 ) THEN
1488	append_internal = .FALSE.
1489
1490	attribute%name = TRIM( name )
1491	attribute%data_type = 'real32'
1492	attribute%value_real32 = value
1493
1494	IF ( PRESENT( variable ) ) THEN
1495	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1496	attribute=attribute, append=append_internal )
1497	ELSE
1498	return_value = dom_def_att_save( TRIM( filename ), &
1499	attribute=attribute, append=append_internal )
1500	ENDIF
1501	ENDIF
1502
1503	END FUNCTION dom_def_att_real32
1504
1505	!--------------------------------------------------------------------------------------------------!
1506	! Description:
1507	! ------------
1508	!> Create attribute with value of type real64.
1509	!--------------------------------------------------------------------------------------------------!
1510	FUNCTION dom_def_att_real64( filename, variable, name, value, append ) RESULT( return_value )
1511
1512	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1513	CHARACTER(LEN=*), INTENT(IN) :: name !< name of attribute
1514	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable !< name of variable
1515
1516	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real64' !< name of routine
1517
1518	INTEGER(iwp) :: return_value !< return value
1519
1520	LOGICAL :: append_internal !< same as 'append'
1521	LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value
1522
1523	REAL(KIND=8), INTENT(IN) :: value !< attribute value
1524
1525	TYPE(attribute_type) :: attribute !< new attribute
1526
1527
1528	return_value = 0
1529
1530	IF ( PRESENT( append ) ) THEN
1531	IF ( append ) THEN
1532	return_value = 1
1533	CALL internal_message( 'error', &
1534	routine_name // &
1535	': attribute "' // TRIM( name ) // &
1536	'": append of numeric attribute not possible.' )
1537	ENDIF
1538	ENDIF
1539
1540	IF ( return_value == 0 ) THEN
1541	append_internal = .FALSE.
1542
1543	attribute%name = TRIM( name )
1544	attribute%data_type = 'real64'
1545	attribute%value_real64 = value
1546
1547	IF ( PRESENT( variable ) ) THEN
1548	return_value = dom_def_att_save( TRIM( filename ), TRIM( variable ), &
1549	attribute=attribute, append=append_internal )
1550	ELSE
1551	return_value = dom_def_att_save( TRIM( filename ), &
1552	attribute=attribute, append=append_internal )
1553	ENDIF
1554	ENDIF
1555
1556	END FUNCTION dom_def_att_real64
1557
1558	!--------------------------------------------------------------------------------------------------!
1559	! Description:
1560	! ------------
1561	!> Add attribute to database.
1562	!>
1563	!> @todo Try to combine similar code parts and shorten routine.
1564	!--------------------------------------------------------------------------------------------------!
1565	FUNCTION dom_def_att_save( filename, variable_name, attribute, append ) RESULT( return_value )
1566
1567	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
1568	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable
1569
1570	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_save' !< name of routine
1571
1572	INTEGER(iwp) :: a !< loop index
1573	INTEGER(iwp) :: d !< loop index
1574	INTEGER(iwp) :: f !< loop index
1575	INTEGER(iwp) :: natt !< number of attributes
1576	INTEGER(iwp) :: return_value !< return value
1577
1578	LOGICAL :: found !< true if variable or dimension of name 'variable_name' found
1579	LOGICAL, INTENT(IN) :: append !< if true, append value to existing value
1580
1581	TYPE(attribute_type), INTENT(IN) :: attribute !< new attribute
1582
1583	TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: atts_tmp !< temporary attribute list
1584
1585
1586	return_value = 0
1587	found = .FALSE.
1588
1589	IF ( PRESENT( variable_name ) ) THEN
1590	CALL internal_message( 'debug', routine_name // &
1591	': define attribute "' // TRIM( attribute%name ) // &
1592	'" of variable "' // TRIM( variable_name ) // &
1593	'" in file "' // TRIM( filename ) // '"' )
1594	ELSE
1595	CALL internal_message( 'debug', routine_name // &
1596	': define attribute "' // TRIM( attribute%name ) // &
1597	'" in file "' // TRIM( filename ) // '"' )
1598	ENDIF
1599
1600	DO f = 1, nf
1601
1602	IF ( TRIM( filename ) == files(f)%name ) THEN
1603
1604	IF ( files(f)%is_init ) THEN
1605	return_value = 1
1606	CALL internal_message( 'error', routine_name // ': file "' // TRIM( filename ) // &
1607	'" is already initialized. No further attribute definition allowed!' )
1608	EXIT
1609	ENDIF
1610
1611	!-- Add attribute to file
1612	IF ( .NOT. PRESENT( variable_name ) ) THEN
1613
1614	!-- Initialize first file attribute
1615	IF ( .NOT. ALLOCATED( files(f)%attributes ) ) THEN
1616	natt = 1
1617	ALLOCATE( files(f)%attributes(natt) )
1618	ELSE
1619	natt = SIZE( files(f)%attributes )
1620
1621	!-- Check if attribute already exists
1622	DO a = 1, natt
1623	IF ( files(f)%attributes(a)%name == attribute%name ) THEN
1624	IF ( append ) THEN
1625	!-- Append existing string attribute
1626	files(f)%attributes(a)%value_char = &
1627	TRIM( files(f)%attributes(a)%value_char ) // &
1628	TRIM( attribute%value_char )
1629	ELSE
1630	files(f)%attributes(a) = attribute
1631	ENDIF
1632	found = .TRUE.
1633	EXIT
1634	ENDIF
1635	ENDDO
1636
1637	!-- Extend attribute list by 1
1638	IF ( .NOT. found ) THEN
1639	ALLOCATE( atts_tmp(natt) )
1640	atts_tmp = files(f)%attributes
1641	DEALLOCATE( files(f)%attributes )
1642	natt = natt + 1
1643	ALLOCATE( files(f)%attributes(natt) )
1644	files(f)%attributes(:natt-1) = atts_tmp
1645	DEALLOCATE( atts_tmp )
1646	ENDIF
1647	ENDIF
1648
1649	!-- Save new attribute to the end of the attribute list
1650	IF ( .NOT. found ) THEN
1651	files(f)%attributes(natt) = attribute
1652	found = .TRUE.
1653	ENDIF
1654
1655	EXIT
1656
1657	ELSE
1658
1659	!-- Add attribute to dimension
1660	IF ( ALLOCATED( files(f)%dimensions ) ) THEN
1661
1662	DO d = 1, SIZE( files(f)%dimensions )
1663
1664	IF ( files(f)%dimensions(d)%name == TRIM( variable_name ) ) THEN
1665
1666	IF ( .NOT. ALLOCATED( files(f)%dimensions(d)%attributes ) ) THEN
1667	!-- Initialize first attribute
1668	natt = 1
1669	ALLOCATE( files(f)%dimensions(d)%attributes(natt) )
1670	ELSE
1671	natt = SIZE( files(f)%dimensions(d)%attributes )
1672
1673	!-- Check if attribute already exists
1674	DO a = 1, natt
1675	IF ( files(f)%dimensions(d)%attributes(a)%name == attribute%name ) &
1676	THEN
1677	IF ( append ) THEN
1678	!-- Append existing character attribute
1679	files(f)%dimensions(d)%attributes(a)%value_char = &
1680	TRIM( files(f)%dimensions(d)%attributes(a)%value_char ) // &
1681	TRIM( attribute%value_char )
1682	ELSE
1683	!-- Update existing attribute
1684	files(f)%dimensions(d)%attributes(a) = attribute
1685	ENDIF
1686	found = .TRUE.
1687	EXIT
1688	ENDIF
1689	ENDDO
1690
1691	!-- Extend attribute list
1692	IF ( .NOT. found ) THEN
1693	ALLOCATE( atts_tmp(natt) )
1694	atts_tmp = files(f)%dimensions(d)%attributes
1695	DEALLOCATE( files(f)%dimensions(d)%attributes )
1696	natt = natt + 1
1697	ALLOCATE( files(f)%dimensions(d)%attributes(natt) )
1698	files(f)%dimensions(d)%attributes(:natt-1) = atts_tmp
1699	DEALLOCATE( atts_tmp )
1700	ENDIF
1701	ENDIF
1702
1703	!-- Add new attribute to database
1704	IF ( .NOT. found ) THEN
1705	files(f)%dimensions(d)%attributes(natt) = attribute
1706	found = .TRUE.
1707	ENDIF
1708
1709	EXIT
1710
1711	ENDIF ! dimension found
1712
1713	ENDDO ! loop over dimensions
1714
1715	ENDIF ! dimensions exist in file
1716
1717	!-- Add attribute to variable
1718	IF ( .NOT. found .AND. ALLOCATED( files(f)%variables) ) THEN
1719
1720	DO d = 1, SIZE( files(f)%variables )
1721
1722	IF ( files(f)%variables(d)%name == TRIM( variable_name ) ) THEN
1723
1724	IF ( .NOT. ALLOCATED( files(f)%variables(d)%attributes ) ) THEN
1725	!-- Initialize first attribute
1726	natt = 1
1727	ALLOCATE( files(f)%variables(d)%attributes(natt) )
1728	ELSE
1729	natt = SIZE( files(f)%variables(d)%attributes )
1730
1731	!-- Check if attribute already exists
1732	DO a = 1, natt
1733	IF ( files(f)%variables(d)%attributes(a)%name == attribute%name ) &
1734	THEN
1735	IF ( append ) THEN
1736	!-- Append existing character attribute
1737	files(f)%variables(d)%attributes(a)%value_char = &
1738	TRIM( files(f)%variables(d)%attributes(a)%value_char ) // &
1739	TRIM( attribute%value_char )
1740	ELSE
1741	!-- Update existing attribute
1742	files(f)%variables(d)%attributes(a) = attribute
1743	ENDIF
1744	found = .TRUE.
1745	EXIT
1746	ENDIF
1747	ENDDO
1748
1749	!-- Extend attribute list
1750	IF ( .NOT. found ) THEN
1751	ALLOCATE( atts_tmp(natt) )
1752	atts_tmp = files(f)%variables(d)%attributes
1753	DEALLOCATE( files(f)%variables(d)%attributes )
1754	natt = natt + 1
1755	ALLOCATE( files(f)%variables(d)%attributes(natt) )
1756	files(f)%variables(d)%attributes(:natt-1) = atts_tmp
1757	DEALLOCATE( atts_tmp )
1758	ENDIF
1759
1760	ENDIF
1761
1762	!-- Add new attribute to database
1763	IF ( .NOT. found ) THEN
1764	files(f)%variables(d)%attributes(natt) = attribute
1765	found = .TRUE.
1766	ENDIF
1767
1768	EXIT
1769
1770	ENDIF ! variable found
1771
1772	ENDDO ! loop over variables
1773
1774	ENDIF ! variables exist in file
1775
1776	IF ( .NOT. found ) THEN
1777	return_value = 1
1778	CALL internal_message( 'error', &
1779	routine_name // &
1780	': requested dimension/variable "' // TRIM( variable_name ) // &
1781	'" for attribute "' // TRIM( attribute%name ) // &
1782	'" does not exist in file "' // TRIM( filename ) // '"' )
1783	ENDIF
1784
1785	EXIT
1786
1787	ENDIF ! variable_name present
1788
1789	ENDIF ! check filename
1790
1791	ENDDO ! loop over files
1792
1793	IF ( .NOT. found .AND. return_value == 0 ) THEN
1794	return_value = 1
1795	CALL internal_message( 'error', &
1796	routine_name // &
1797	': requested file "' // TRIM( filename ) // &
1798	'" for attribute "' // TRIM( attribute%name ) // &
1799	'" does not exist' )
1800	ENDIF
1801
1802	END FUNCTION dom_def_att_save
1803
1804	!--------------------------------------------------------------------------------------------------!
1805	! Description:
1806	! ------------
1807	!> Start with output: clear database from unused files/dimensions, initialize
1808	!> files and write dimension values to files.
1809	!--------------------------------------------------------------------------------------------------!
1810	FUNCTION dom_start_output() RESULT( return_value )
1811
1812	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_start_output' !< name of routine
1813
1814	INTEGER(iwp) :: d !< loop index
1815	INTEGER(iwp) :: f !< loop index
1816	INTEGER(iwp) :: return_value !< return value
1817
1818	INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE, TARGET :: values_int8 !< target array for dimension values
1819	INTEGER(KIND=1), DIMENSION(:), POINTER, CONTIGUOUS :: values_int8_pointer !< pointer to target array
1820
1821	INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE, TARGET :: values_int16 !< target array for dimension values
1822	INTEGER(KIND=2), DIMENSION(:), POINTER, CONTIGUOUS :: values_int16_pointer !< pointer to target array
1823
1824	INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET :: values_int32 !< target array for dimension values
1825	INTEGER(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS :: values_int32_pointer !< pointer to target array
1826
1827	INTEGER(iwp), DIMENSION(:), ALLOCATABLE, TARGET :: values_intwp !< target array for dimension values
1828	INTEGER(iwp), DIMENSION(:), POINTER, CONTIGUOUS :: values_intwp_pointer !< pointer to target array
1829
1830	REAL(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET :: values_real32 !< target array for dimension values
1831	REAL(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS :: values_real32_pointer !< pointer to target array
1832
1833	REAL(KIND=8), DIMENSION(:), ALLOCATABLE, TARGET :: values_real64 !< target array for dimension values
1834	REAL(KIND=8), DIMENSION(:), POINTER, CONTIGUOUS :: values_real64_pointer !< pointer to target array
1835
1836	REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET :: values_realwp !< target array for dimension values
1837	REAL(wp), DIMENSION(:), POINTER, CONTIGUOUS :: values_realwp_pointer !< pointer to target array
1838
1839
1840	return_value = 0
1841	CALL internal_message( 'debug', routine_name // ': start' )
1842
1843	!-- Clear database from empty files and unused dimensions
1844	IF ( nf > 0 ) return_value = cleanup_database()
1845
1846	IF ( return_value == 0 ) THEN
1847	DO f = 1, nf
1848
1849	!-- Skip initialization if file is already initialized
1850	IF ( files(f)%is_init ) CYCLE
1851
1852	CALL internal_message( 'debug', routine_name // ': initialize file "' // &
1853	TRIM( files(f)%name ) // '"' )
1854
1855	!-- Open file
1856	CALL open_output_file( files(f)%format, files(f)%name, files(f)%id, &
1857	return_value=return_value )
1858
1859	!-- Initialize file header:
1860	!-- define dimensions and variables and write attributes
1861	IF ( return_value == 0 ) &
1862	CALL dom_init_file_header( files(f), return_value=return_value )
1863
1864	!-- End file definition
1865	IF ( return_value == 0 ) &
1866	CALL dom_init_end( files(f)%format, files(f)%id, files(f)%name, return_value )
1867
1868	IF ( return_value == 0 ) THEN
1869
1870	!-- Flag file as initialized
1871	files(f)%is_init = .TRUE.
1872
1873	!-- Write dimension values into file
1874	DO d = 1, SIZE( files(f)%dimensions )
1875	IF ( ALLOCATED( files(f)%dimensions(d)%values_int8 ) ) THEN
1876	ALLOCATE( values_int8(files(f)%dimensions(d)%bounds(1): &
1877	files(f)%dimensions(d)%bounds(2)) )
1878	values_int8 = files(f)%dimensions(d)%values_int8
1879	values_int8_pointer => values_int8
1880	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1881	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1882	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1883	var_int8_1d=values_int8_pointer )
1884	DEALLOCATE( values_int8 )
1885	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int16 ) ) THEN
1886	ALLOCATE( values_int16(files(f)%dimensions(d)%bounds(1): &
1887	files(f)%dimensions(d)%bounds(2)) )
1888	values_int16 = files(f)%dimensions(d)%values_int16
1889	values_int16_pointer => values_int16
1890	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1891	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1892	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1893	var_int16_1d=values_int16_pointer )
1894	DEALLOCATE( values_int16 )
1895	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int32 ) ) THEN
1896	ALLOCATE( values_int32(files(f)%dimensions(d)%bounds(1): &
1897	files(f)%dimensions(d)%bounds(2)) )
1898	values_int32 = files(f)%dimensions(d)%values_int32
1899	values_int32_pointer => values_int32
1900	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1901	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1902	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1903	var_int32_1d=values_int32_pointer )
1904	DEALLOCATE( values_int32 )
1905	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_intwp ) ) THEN
1906	ALLOCATE( values_intwp(files(f)%dimensions(d)%bounds(1): &
1907	files(f)%dimensions(d)%bounds(2)) )
1908	values_intwp = files(f)%dimensions(d)%values_intwp
1909	values_intwp_pointer => values_intwp
1910	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1911	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1912	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1913	var_intwp_1d=values_intwp_pointer )
1914	DEALLOCATE( values_intwp )
1915	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real32 ) ) THEN
1916	ALLOCATE( values_real32(files(f)%dimensions(d)%bounds(1): &
1917	files(f)%dimensions(d)%bounds(2)) )
1918	values_real32 = files(f)%dimensions(d)%values_real32
1919	values_real32_pointer => values_real32
1920	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1921	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1922	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1923	var_real32_1d=values_real32_pointer )
1924	DEALLOCATE( values_real32 )
1925	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real64 ) ) THEN
1926	ALLOCATE( values_real64(files(f)%dimensions(d)%bounds(1): &
1927	files(f)%dimensions(d)%bounds(2)) )
1928	values_real64 = files(f)%dimensions(d)%values_real64
1929	values_real64_pointer => values_real64
1930	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1931	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1932	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1933	var_real64_1d=values_real64_pointer )
1934	DEALLOCATE( values_real64 )
1935	ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_realwp ) ) THEN
1936	ALLOCATE( values_realwp(files(f)%dimensions(d)%bounds(1): &
1937	files(f)%dimensions(d)%bounds(2)) )
1938	values_realwp = files(f)%dimensions(d)%values_realwp
1939	values_realwp_pointer => values_realwp
1940	return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1941	bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &
1942	bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &
1943	var_realwp_1d=values_realwp_pointer )
1944	DEALLOCATE( values_realwp )
1945	ENDIF
1946	IF ( return_value /= 0 ) EXIT
1947	ENDDO
1948
1949	ENDIF
1950
1951	IF ( return_value /= 0 ) EXIT
1952
1953	ENDDO
1954	ENDIF
1955
1956	CALL internal_message( 'debug', routine_name // ': finished' )
1957
1958	END FUNCTION dom_start_output
1959
1960	!--------------------------------------------------------------------------------------------------!
1961	! Description:
1962	! ------------
1963	!> Check database and delete any unused dimensions and empty files (i.e. files
1964	!> without variables).
1965	!--------------------------------------------------------------------------------------------------!
1966	FUNCTION cleanup_database() RESULT( return_value )
1967
1968	! CHARACTER(LEN=*), PARAMETER :: routine_name = 'cleanup_database' !< name of routine
1969
1970	INTEGER(iwp) :: d !< loop index
1971	INTEGER(iwp) :: f !< loop index
1972	INTEGER(iwp) :: i !< loop index
1973	INTEGER(iwp) :: ndim !< number of dimensions in a file
1974	INTEGER(iwp) :: ndim_used !< number of used dimensions in a file
1975	INTEGER(iwp) :: nf_used !< number of used files
1976	INTEGER(iwp) :: nvar !< number of variables in a file
1977	INTEGER(iwp) :: return_value !< return value
1978
1979	LOGICAL, DIMENSION(1:nf) :: file_is_used !< true if file contains variables
1980	LOGICAL, DIMENSION(:), ALLOCATABLE :: dimension_is_used !< true if dimension is used by any variable
1981
1982	TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: used_dimensions !< list of used dimensions
1983
1984	TYPE(file_type), DIMENSION(:), ALLOCATABLE :: used_files !< list of used files
1985
1986
1987	return_value = 0
1988
1989	!-- Flag files which contain output variables as used
1990	file_is_used(:) = .FALSE.
1991	DO f = 1, nf
1992	IF ( ALLOCATED( files(f)%variables ) ) THEN
1993	file_is_used(f) = .TRUE.
1994	ENDIF
1995	ENDDO
1996
1997	!-- Copy flagged files into temporary list
1998	nf_used = COUNT( file_is_used )
1999	ALLOCATE( used_files(nf_used) )
2000	i = 0
2001	DO f = 1, nf
2002	IF ( file_is_used(f) ) THEN
2003	i = i + 1
2004	used_files(i) = files(f)
2005	ENDIF
2006	ENDDO
2007
2008	!-- Replace file list with list of used files
2009	DEALLOCATE( files )
2010	nf = nf_used
2011	ALLOCATE( files(nf) )
2012	files = used_files
2013	DEALLOCATE( used_files )
2014
2015	!-- Check every file for unused dimensions
2016	DO f = 1, nf
2017
2018	!-- If a file is already initialized, it was already checked previously
2019	IF ( files(f)%is_init ) CYCLE
2020
2021	!-- Get number of defined dimensions
2022	ndim = SIZE( files(f)%dimensions )
2023	ALLOCATE( dimension_is_used(ndim) )
2024
2025	!-- Go through all variables and flag all used dimensions
2026	nvar = SIZE( files(f)%variables )
2027	DO d = 1, ndim
2028	DO i = 1, nvar
2029	dimension_is_used(d) = &
2030	ANY( files(f)%dimensions(d)%name == files(f)%variables(i)%dimension_names )
2031	IF ( dimension_is_used(d) ) EXIT
2032	ENDDO
2033	ENDDO
2034
2035	!-- Copy used dimensions to temporary list
2036	ndim_used = COUNT( dimension_is_used )
2037	ALLOCATE( used_dimensions(ndim_used) )
2038	i = 0
2039	DO d = 1, ndim
2040	IF ( dimension_is_used(d) ) THEN
2041	i = i + 1
2042	used_dimensions(i) = files(f)%dimensions(d)
2043	ENDIF
2044	ENDDO
2045
2046	!-- Replace dimension list with list of used dimensions
2047	DEALLOCATE( files(f)%dimensions )
2048	ndim = ndim_used
2049	ALLOCATE( files(f)%dimensions(ndim) )
2050	files(f)%dimensions = used_dimensions
2051	DEALLOCATE( used_dimensions )
2052	DEALLOCATE( dimension_is_used )
2053
2054	ENDDO
2055
2056	END FUNCTION cleanup_database
2057
2058	!--------------------------------------------------------------------------------------------------!
2059	! Description:
2060	! ------------
2061	!> Open requested output file.
2062	!--------------------------------------------------------------------------------------------------!
2063	SUBROUTINE open_output_file( file_format, filename, file_id, return_value )
2064
2065	CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file
2066	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file to be checked
2067
2068	CHARACTER(LEN=*), PARAMETER :: routine_name = 'open_output_file' !< name of routine
2069
2070	INTEGER(iwp), INTENT(OUT) :: file_id !< file ID
2071	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2072	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
2073
2074
2075	return_value = 0
2076	output_return_value = 0
2077
2078	SELECT CASE ( TRIM( file_format ) )
2079
2080	CASE ( 'binary' )
2081	CALL binary_open_file( 'binary', filename, file_id, output_return_value )
2082
2083	CASE ( 'netcdf4-serial' )
2084	CALL netcdf4_open_file( 'serial', filename, file_id, output_return_value )
2085
2086	CASE ( 'netcdf4-parallel' )
2087	CALL netcdf4_open_file( 'parallel', filename, file_id, output_return_value )
2088
2089	CASE DEFAULT
2090	return_value = 1
2091
2092	END SELECT
2093
2094	IF ( output_return_value /= 0 ) THEN
2095	return_value = output_return_value
2096	CALL internal_message( 'error', routine_name // &
2097	': error while opening file "' // TRIM( filename ) // '"' )
2098	ELSEIF ( return_value /= 0 ) THEN
2099	CALL internal_message( 'error', routine_name // &
2100	': file "' // TRIM( filename ) // &
2101	'": file format "' // TRIM( file_format ) // &
2102	'" not supported' )
2103	ENDIF
2104
2105	END SUBROUTINE open_output_file
2106
2107	!--------------------------------------------------------------------------------------------------!
2108	! Description:
2109	! ------------
2110	!> Define attributes, dimensions and variables.
2111	!--------------------------------------------------------------------------------------------------!
2112	SUBROUTINE dom_init_file_header( file, return_value )
2113
2114	! CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_init_file_header' !< name of routine
2115
2116	INTEGER(iwp) :: a !< loop index
2117	INTEGER(iwp) :: d !< loop index
2118	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
2119
2120	TYPE(file_type), INTENT(INOUT) :: file !< initialize header of this file
2121
2122
2123	return_value = 0
2124
2125	!-- Write file attributes
2126	IF ( ALLOCATED( file%attributes ) ) THEN
2127	DO a = 1, SIZE( file%attributes )
2128	return_value = write_attribute( file%format, file%id, file%name, var_id=no_var_id, &
2129	attribute=file%attributes(a) )
2130	IF ( return_value /= 0 ) EXIT
2131	ENDDO
2132	ENDIF
2133
2134	IF ( return_value == 0 ) THEN
2135
2136	!-- Initialize file dimensions
2137	DO d = 1, SIZE( file%dimensions )
2138
2139	IF ( .NOT. file%dimensions(d)%is_masked ) THEN
2140
2141	!-- Initialize non-masked dimension
2142	CALL init_file_dimension( file%format, file%id, file%name, &
2143	file%dimensions(d)%id, file%dimensions(d)%var_id, &
2144	file%dimensions(d)%name, file%dimensions(d)%data_type, &
2145	file%dimensions(d)%length, return_value )
2146
2147	ELSE
2148
2149	!-- Initialize masked dimension
2150	CALL init_file_dimension( file%format, file%id, file%name, &
2151	file%dimensions(d)%id, file%dimensions(d)%var_id, &
2152	file%dimensions(d)%name, file%dimensions(d)%data_type, &
2153	file%dimensions(d)%length_mask, return_value )
2154
2155	ENDIF
2156
2157	IF ( return_value == 0 .AND. ALLOCATED( file%dimensions(d)%attributes ) ) THEN
2158	!-- Write dimension attributes
2159	DO a = 1, SIZE( file%dimensions(d)%attributes )
2160	return_value = write_attribute( file%format, file%id, file%name, &
2161	var_id=file%dimensions(d)%var_id, &
2162	var_name=file%dimensions(d)%name, &
2163	attribute=file%dimensions(d)%attributes(a) )
2164	IF ( return_value /= 0 ) EXIT
2165	ENDDO
2166	ENDIF
2167
2168	IF ( return_value /= 0 ) EXIT
2169
2170	ENDDO
2171
2172	!-- Save dimension IDs for variables wihtin database
2173	IF ( return_value == 0 ) &
2174	CALL collect_dimesion_ids_for_variables( file%variables, file%dimensions, return_value )
2175
2176	!-- Initialize file variables
2177	IF ( return_value == 0 ) THEN
2178	DO d = 1, SIZE( file%variables )
2179
2180	CALL init_file_variable( file%format, file%id, file%name, &
2181	file%variables(d)%id, file%variables(d)%name, file%variables(d)%data_type, &
2182	file%variables(d)%dimension_ids, &
2183	file%variables(d)%is_global, return_value )
2184
2185	IF ( return_value == 0 .AND. ALLOCATED( file%variables(d)%attributes ) ) THEN
2186	!-- Write variable attributes
2187	DO a = 1, SIZE( file%variables(d)%attributes )
2188	return_value = write_attribute( file%format, file%id, file%name, &
2189	var_id=file%variables(d)%id, &
2190	var_name=file%variables(d)%name, &
2191	attribute=file%variables(d)%attributes(a) )
2192	IF ( return_value /= 0 ) EXIT
2193	ENDDO
2194	ENDIF
2195
2196	IF ( return_value /= 0 ) EXIT
2197
2198	ENDDO
2199	ENDIF
2200
2201	ENDIF
2202
2203	END SUBROUTINE dom_init_file_header
2204
2205	!--------------------------------------------------------------------------------------------------!
2206	! Description:
2207	! ------------
2208	!> Write attribute to file.
2209	!--------------------------------------------------------------------------------------------------!
2210	FUNCTION write_attribute( file_format, file_id, file_name, var_id, var_name, attribute ) RESULT( return_value )
2211
2212	CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file
2213	CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name
2214	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: var_name !< variable name
2215
2216	CHARACTER(LEN=*), PARAMETER :: routine_name = 'write_attribute' !< file format chosen for file
2217
2218	INTEGER(iwp), INTENT(IN) :: file_id !< file ID
2219	INTEGER(iwp) :: return_value !< return value
2220	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2221	INTEGER(iwp), INTENT(IN) :: var_id !< variable ID
2222
2223	TYPE(attribute_type), INTENT(IN) :: attribute !< attribute to be written
2224
2225
2226	return_value = 0
2227	output_return_value = 0
2228
2229	!-- Prepare for possible error message
2230	IF ( PRESENT( var_name ) ) THEN
2231	temp_string = '(file "' // TRIM( file_name ) // &
2232	'", variable "' // TRIM( var_name ) // &
2233	'", attribute "' // TRIM( attribute%name ) // '")'
2234	ELSE
2235	temp_string = '(file "' // TRIM( file_name ) // &
2236	'", attribute "' // TRIM( attribute%name ) // '")'
2237	ENDIF
2238
2239	!-- Write attribute to file
2240	SELECT CASE ( TRIM( file_format ) )
2241
2242	CASE ( 'binary' )
2243
2244	SELECT CASE ( TRIM( attribute%data_type ) )
2245
2246	CASE( 'char' )
2247	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2248	att_name=attribute%name, att_value_char=attribute%value_char, &
2249	return_value=output_return_value )
2250
2251	CASE( 'int8' )
2252	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2253	att_name=attribute%name, att_value_int8=attribute%value_int8, &
2254	return_value=output_return_value )
2255
2256	CASE( 'int16' )
2257	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2258	att_name=attribute%name, att_value_int16=attribute%value_int16, &
2259	return_value=output_return_value )
2260
2261	CASE( 'int32' )
2262	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2263	att_name=attribute%name, att_value_int32=attribute%value_int32, &
2264	return_value=output_return_value )
2265
2266	CASE( 'real32' )
2267	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2268	att_name=attribute%name, att_value_real32=attribute%value_real32, &
2269	return_value=output_return_value )
2270
2271	CASE( 'real64' )
2272	CALL binary_write_attribute( file_id=file_id, var_id=var_id, &
2273	att_name=attribute%name, att_value_real64=attribute%value_real64, &
2274	return_value=output_return_value )
2275
2276	CASE DEFAULT
2277	return_value = 1
2278	CALL internal_message( 'error', routine_name // &
2279	': file format "' // TRIM( file_format ) // &
2280	'" does not support attribute data type "'// &
2281	TRIM( attribute%data_type ) // &
2282	'" ' // TRIM( temp_string ) )
2283
2284	END SELECT
2285
2286	CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
2287
2288	SELECT CASE ( TRIM( attribute%data_type ) )
2289
2290	CASE( 'char' )
2291	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2292	att_name=attribute%name, att_value_char=attribute%value_char, &
2293	return_value=output_return_value )
2294
2295	CASE( 'int8' )
2296	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2297	att_name=attribute%name, att_value_int8=attribute%value_int8, &
2298	return_value=output_return_value )
2299
2300	CASE( 'int16' )
2301	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2302	att_name=attribute%name, att_value_int16=attribute%value_int16, &
2303	return_value=output_return_value )
2304
2305	CASE( 'int32' )
2306	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2307	att_name=attribute%name, att_value_int32=attribute%value_int32, &
2308	return_value=output_return_value )
2309
2310	CASE( 'real32' )
2311	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2312	att_name=attribute%name, att_value_real32=attribute%value_real32, &
2313	return_value=output_return_value )
2314
2315	CASE( 'real64' )
2316	CALL netcdf4_write_attribute( file_id=file_id, var_id=var_id, &
2317	att_name=attribute%name, att_value_real64=attribute%value_real64, &
2318	return_value=output_return_value )
2319
2320	CASE DEFAULT
2321	return_value = 1
2322	CALL internal_message( 'error', routine_name // &
2323	': file format "' // TRIM( file_format ) // &
2324	'" does not support attribute data type "'// &
2325	TRIM( attribute%data_type ) // &
2326	'" ' // TRIM( temp_string ) )
2327
2328	END SELECT
2329
2330	CASE DEFAULT
2331	return_value = 1
2332	CALL internal_message( 'error', &
2333	routine_name // &
2334	': unsupported file format "' // TRIM( file_format ) // &
2335	'" ' // TRIM( temp_string ) )
2336
2337	END SELECT
2338
2339	IF ( output_return_value /= 0 ) THEN
2340	return_value = output_return_value
2341	CALL internal_message( 'error', &
2342	routine_name // &
2343	': error while writing attribute ' // TRIM( temp_string ) )
2344	ENDIF
2345
2346	END FUNCTION write_attribute
2347
2348	!--------------------------------------------------------------------------------------------------!
2349	! Description:
2350	! ------------
2351	!> Initialize dimension in file.
2352	!--------------------------------------------------------------------------------------------------!
2353	SUBROUTINE init_file_dimension( file_format, file_id, file_name, dim_id, var_id, &
2354	dim_name, dim_type, dim_length, return_value )
2355
2356	CHARACTER(LEN=*), INTENT(IN) :: dim_name !< name of dimension
2357	CHARACTER(LEN=*), INTENT(IN) :: dim_type !< data type of dimension
2358	CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file
2359	CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file
2360
2361	CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_dimension' !< file format chosen for file
2362
2363	INTEGER(iwp), INTENT(OUT) :: dim_id !< dimension ID
2364	INTEGER(iwp), INTENT(IN) :: dim_length !< length of dimension
2365	INTEGER(iwp), INTENT(IN) :: file_id !< file ID
2366	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2367	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
2368	INTEGER(iwp), INTENT(OUT) :: var_id !< associated variable ID
2369
2370
2371	return_value = 0
2372	output_return_value = 0
2373
2374	temp_string = '(file "' // TRIM( file_name ) // &
2375	'", dimension "' // TRIM( dim_name ) // '")'
2376
2377	SELECT CASE ( TRIM( file_format ) )
2378
2379	CASE ( 'binary' )
2380	CALL binary_init_dimension( 'binary', file_id, dim_id, var_id, &
2381	dim_name, dim_type, dim_length, return_value=output_return_value )
2382
2383	CASE ( 'netcdf4-serial' )
2384	CALL netcdf4_init_dimension( 'serial', file_id, dim_id, var_id, &
2385	dim_name, dim_type, dim_length, return_value=output_return_value )
2386
2387	CASE ( 'netcdf4-parallel' )
2388	CALL netcdf4_init_dimension( 'parallel', file_id, dim_id, var_id, &
2389	dim_name, dim_type, dim_length, return_value=output_return_value )
2390
2391	CASE DEFAULT
2392	return_value = 1
2393	CALL internal_message( 'error', routine_name // &
2394	': file format "' // TRIM( file_format ) // &
2395	'" not supported ' // TRIM( temp_string ) )
2396
2397	END SELECT
2398
2399	IF ( output_return_value /= 0 ) THEN
2400	return_value = output_return_value
2401	CALL internal_message( 'error', routine_name // &
2402	': error while defining dimension ' // TRIM( temp_string ) )
2403	ENDIF
2404
2405	END SUBROUTINE init_file_dimension
2406
2407	!--------------------------------------------------------------------------------------------------!
2408	! Description:
2409	! ------------
2410	!> Get dimension IDs and save them to variables.
2411	!--------------------------------------------------------------------------------------------------!
2412	SUBROUTINE collect_dimesion_ids_for_variables( variables, dimensions, return_value )
2413
2414	CHARACTER(LEN=*), PARAMETER :: routine_name = 'collect_dimesion_ids_for_variables' !< file format chosen for file
2415
2416	INTEGER(iwp) :: d !< loop index
2417	INTEGER(iwp) :: i !< loop index
2418	INTEGER(iwp) :: j !< loop index
2419	INTEGER(iwp) :: ndim !< number of dimensions
2420	INTEGER(iwp) :: nvar !< number of variables
2421	INTEGER(iwp) :: return_value !< return value
2422
2423	LOGICAL :: found !< true if dimension required by variable was found in dimension list
2424
2425	TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< list of dimensions in file
2426
2427	TYPE(variable_type), DIMENSION(:), INTENT(INOUT) :: variables !< list of variables in file
2428
2429
2430	return_value = 0
2431	ndim = SIZE( dimensions )
2432	nvar = SIZE( variables )
2433
2434	DO i = 1, nvar
2435	DO j = 1, SIZE( variables(i)%dimension_names )
2436	found = .FALSE.
2437	DO d = 1, ndim
2438	IF ( variables(i)%dimension_names(j) == dimensions(d)%name ) THEN
2439	variables(i)%dimension_ids(j) = dimensions(d)%id
2440	found = .TRUE.
2441	EXIT
2442	ENDIF
2443	ENDDO
2444	IF ( .NOT. found ) THEN
2445	return_value = 1
2446	CALL internal_message( 'error', &
2447	routine_name // ': variable "' // TRIM( variables(i)%name ) // &
2448	'": required dimension "' // TRIM( variables(i)%dimension_names(j) ) // &
2449	'" is undefined' )
2450	EXIT
2451	ENDIF
2452	ENDDO
2453	IF ( .NOT. found ) EXIT
2454	ENDDO
2455
2456	END SUBROUTINE collect_dimesion_ids_for_variables
2457
2458	!--------------------------------------------------------------------------------------------------!
2459	! Description:
2460	! ------------
2461	!> Initialize variable.
2462	!--------------------------------------------------------------------------------------------------!
2463	SUBROUTINE init_file_variable( file_format, file_id, file_name, &
2464	var_id, var_name, var_type, var_dim_id, &
2465	is_global, return_value )
2466
2467	CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file
2468	CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name
2469	CHARACTER(LEN=*), INTENT(IN) :: var_name !< name of variable
2470	CHARACTER(LEN=*), INTENT(IN) :: var_type !< data type of variable
2471
2472	CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_variable' !< file format chosen for file
2473
2474	INTEGER(iwp), INTENT(IN) :: file_id !< file ID
2475	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2476	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
2477	INTEGER(iwp), INTENT(OUT) :: var_id !< variable ID
2478
2479	INTEGER(iwp), DIMENSION(:), INTENT(IN) :: var_dim_id !< list of dimension IDs used by variable
2480
2481	LOGICAL, INTENT(IN) :: is_global !< true if variable is global
2482
2483
2484	return_value = 0
2485	output_return_value = 0
2486
2487	temp_string = '(file "' // TRIM( file_name ) // &
2488	'", variable "' // TRIM( var_name ) // '")'
2489
2490	SELECT CASE ( TRIM( file_format ) )
2491
2492	CASE ( 'binary' )
2493	CALL binary_init_variable( 'binary', file_id, var_id, var_name, var_type, &
2494	var_dim_id, is_global, return_value=output_return_value )
2495
2496	CASE ( 'netcdf4-serial' )
2497	CALL netcdf4_init_variable( 'serial', file_id, var_id, var_name, var_type, &
2498	var_dim_id, is_global, return_value=output_return_value )
2499
2500	CASE ( 'netcdf4-parallel' )
2501	CALL netcdf4_init_variable( 'parallel', file_id, var_id, var_name, var_type, &
2502	var_dim_id, is_global, return_value=output_return_value )
2503
2504	CASE DEFAULT
2505	return_value = 1
2506	CALL internal_message( 'error', routine_name // &
2507	': file format "' // TRIM( file_format ) // &
2508	'" not supported ' // TRIM( temp_string ) )
2509
2510	END SELECT
2511
2512	IF ( output_return_value /= 0 ) THEN
2513	return_value = output_return_value
2514	CALL internal_message( 'error', routine_name // &
2515	': error while defining variable ' // TRIM( temp_string ) )
2516	ENDIF
2517
2518	END SUBROUTINE init_file_variable
2519
2520	!--------------------------------------------------------------------------------------------------!
2521	! Description:
2522	! ------------
2523	!> Finalize file definition/initialization.
2524	!>
2525	!> @todo Do we need an MPI barrier at the end?
2526	!--------------------------------------------------------------------------------------------------!
2527	SUBROUTINE dom_init_end( file_format, file_id, file_name, return_value )
2528
2529	CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format
2530	CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name
2531
2532	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_init_end' !< name of routine
2533
2534	INTEGER(iwp), INTENT(IN) :: file_id !< file id
2535	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2536	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
2537
2538
2539	return_value = 0
2540	output_return_value = 0
2541
2542	temp_string = '(file "' // TRIM( file_name ) // '")'
2543
2544	SELECT CASE ( TRIM( file_format ) )
2545
2546	CASE ( 'binary' )
2547	CALL binary_init_end( file_id, output_return_value )
2548
2549	CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
2550	CALL netcdf4_init_end( file_id, output_return_value )
2551
2552	CASE DEFAULT
2553	return_value = 1
2554	CALL internal_message( 'error', routine_name // &
2555	': file format "' // TRIM( file_format ) // &
2556	'" not supported ' // TRIM( temp_string ) )
2557
2558	END SELECT
2559
2560	IF ( output_return_value /= 0 ) THEN
2561	return_value = output_return_value
2562	CALL internal_message( 'error', routine_name // &
2563	': error while leaving file-definition state ' // &
2564	TRIM( temp_string ) )
2565	ENDIF
2566
2567	! CALL MPI_Barrier( MPI_COMM_WORLD, return_value )
2568
2569	END SUBROUTINE dom_init_end
2570
2571	!--------------------------------------------------------------------------------------------------!
2572	! Description:
2573	! ------------
2574	!> Write variable to file.
2575	!> Example call:
2576	!> dom_write_var( file_format = 'binary', &
2577	!> filename = 'DATA_OUTPUT_3D', &
2578	!> name = 'u', &
2579	!> var_real64_3d = u, &
2580	!> bounds_start = (/nzb, nys, nxl/), &
2581	!> bounds_end = (/nzt, nyn, nxr/) )
2582	!--------------------------------------------------------------------------------------------------!
2583	FUNCTION dom_write_var( filename, name, bounds_start, bounds_end, &
2584	var_int8_0d, var_int8_1d, var_int8_2d, var_int8_3d, &
2585	var_int16_0d, var_int16_1d, var_int16_2d, var_int16_3d, &
2586	var_int32_0d, var_int32_1d, var_int32_2d, var_int32_3d, &
2587	var_intwp_0d, var_intwp_1d, var_intwp_2d, var_intwp_3d, &
2588	var_real32_0d, var_real32_1d, var_real32_2d, var_real32_3d, &
2589	var_real64_0d, var_real64_1d, var_real64_2d, var_real64_3d, &
2590	var_realwp_0d, var_realwp_1d, var_realwp_2d, var_realwp_3d &
2591	) RESULT( return_value )
2592
2593	CHARACTER(LEN=charlen) :: file_format !< file format chosen for file
2594	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
2595	CHARACTER(LEN=*), INTENT(IN) :: name !< name of variable
2596
2597	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_write_var' !< name of routine
2598
2599	INTEGER(iwp) :: d !< loop index
2600	INTEGER(iwp) :: file_id !< file ID
2601	INTEGER(iwp) :: i !< loop index
2602	INTEGER(iwp) :: j !< loop index
2603	INTEGER(iwp) :: k !< loop index
2604	INTEGER(iwp) :: output_return_value !< return value of a called output routine
2605	INTEGER(iwp) :: return_value !< return value
2606	INTEGER(iwp) :: var_id !< variable ID
2607
2608	INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_end !< end index (upper bound) of variable at each dimension
2609	INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_start !< start index (lower bound) of variable at each dimension
2610	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: bounds_dim_start !< start index (lower bound) of each dimension of variable
2611	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: bounds_end_new !< start index (upper bound) of msked var at each dim
2612	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: bounds_start_new !< start index (lower bound) of msked var at each dim
2613	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: masked_indices !< dummy list holding all masked indices along a dimension
2614
2615	LOGICAL :: do_output !< true if any data lies within given range of masked dimension
2616	LOGICAL :: is_global !< true if variable is global
2617
2618	INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL :: var_int8_0d !< output variable
2619	INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int8_1d !< output variable
2620	INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int8_2d !< output variable
2621	INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int8_3d !< output variable
2622
2623	INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:) :: var_int8_1d_resorted !< resorted output variable
2624	INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_int8_2d_resorted !< resorted output variable
2625	INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_int8_3d_resorted !< resorted output variable
2626
2627	INTEGER(KIND=1), POINTER :: var_int8_0d_pointer !< output variable
2628	INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:) :: var_int8_1d_pointer !< output variable
2629	INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_int8_2d_pointer !< output variable
2630	INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_int8_3d_pointer !< output variable
2631
2632	INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL :: var_int16_0d !< output variable
2633	INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int16_1d !< output variable
2634	INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int16_2d !< output variable
2635	INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int16_3d !< output variable
2636
2637	INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:) :: var_int16_1d_resorted !< resorted output variable
2638	INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_int16_2d_resorted !< resorted output variable
2639	INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_int16_3d_resorted !< resorted output variable
2640
2641	INTEGER(KIND=2), POINTER :: var_int16_0d_pointer !< output variable
2642	INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:) :: var_int16_1d_pointer !< output variable
2643	INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_int16_2d_pointer !< output variable
2644	INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_int16_3d_pointer !< output variable
2645
2646	INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL :: var_int32_0d !< output variable
2647	INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int32_1d !< output variable
2648	INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int32_2d !< output variable
2649	INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int32_3d !< output variable
2650
2651	INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: var_int32_1d_resorted !< resorted output variable
2652	INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_int32_2d_resorted !< resorted output variable
2653	INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_int32_3d_resorted !< resorted output variable
2654
2655	INTEGER(KIND=4), POINTER :: var_int32_0d_pointer !< output variable
2656	INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:) :: var_int32_1d_pointer !< output variable
2657	INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_int32_2d_pointer !< output variable
2658	INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_int32_3d_pointer !< output variable
2659
2660	INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL :: var_intwp_0d !< output variable
2661	INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_intwp_1d !< output variable
2662	INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_intwp_2d !< output variable
2663	INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_intwp_3d !< output variable
2664
2665	INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:) :: var_intwp_1d_resorted !< resorted output variable
2666	INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_intwp_2d_resorted !< resorted output variable
2667	INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_intwp_3d_resorted !< resorted output variable
2668
2669	INTEGER(iwp), POINTER :: var_intwp_0d_pointer !< output variable
2670	INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:) :: var_intwp_1d_pointer !< output variable
2671	INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_intwp_2d_pointer !< output variable
2672	INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_intwp_3d_pointer !< output variable
2673
2674	REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: var_real32_0d !< output variable
2675	REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_real32_1d !< output variable
2676	REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_real32_2d !< output variable
2677	REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_real32_3d !< output variable
2678
2679	REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: var_real32_1d_resorted !< resorted output variable
2680	REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_real32_2d_resorted !< resorted output variable
2681	REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_real32_3d_resorted !< resorted output variable
2682
2683	REAL(KIND=4), POINTER :: var_real32_0d_pointer !< output variable
2684	REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:) :: var_real32_1d_pointer !< output variable
2685	REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_real32_2d_pointer !< output variable
2686	REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_real32_3d_pointer !< output variable
2687
2688	REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL :: var_real64_0d !< output variable
2689	REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_real64_1d !< output variable
2690	REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_real64_2d !< output variable
2691	REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_real64_3d !< output variable
2692
2693	REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:) :: var_real64_1d_resorted !< resorted output variable
2694	REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_real64_2d_resorted !< resorted output variable
2695	REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_real64_3d_resorted !< resorted output variable
2696
2697	REAL(KIND=8), POINTER :: var_real64_0d_pointer !< output variable
2698	REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:) :: var_real64_1d_pointer !< output variable
2699	REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_real64_2d_pointer !< output variable
2700	REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_real64_3d_pointer !< output variable
2701
2702	REAL(wp), POINTER, INTENT(IN), OPTIONAL :: var_realwp_0d !< output variable
2703	REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_realwp_1d !< output variable
2704	REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_realwp_2d !< output variable
2705	REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_realwp_3d !< output variable
2706
2707	REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:) :: var_realwp_1d_resorted !< resorted output variable
2708	REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: var_realwp_2d_resorted !< resorted output variable
2709	REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: var_realwp_3d_resorted !< resorted output variable
2710
2711	REAL(wp), POINTER :: var_realwp_0d_pointer !< output variable
2712	REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:) :: var_realwp_1d_pointer !< output variable
2713	REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:,:) :: var_realwp_2d_pointer !< output variable
2714	REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: var_realwp_3d_pointer !< output variable
2715
2716	TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dimension_list !< list of used dimensions of variable
2717
2718
2719	return_value = 0
2720	output_return_value = 0
2721
2722	CALL internal_message( 'debug', routine_name // ': write ' // TRIM( name ) // &
2723	' into file ' // TRIM( filename ) )
2724
2725	!-- Search for variable within file
2726	CALL find_var_in_file( filename, name, file_format, file_id, var_id, &
2727	is_global, dimension_list, return_value=return_value )
2728
2729	IF ( return_value == 0 ) THEN
2730
2731	!-- Check if the correct amount of variable bounds were given
2732	IF ( SIZE( bounds_start ) /= SIZE( dimension_list ) .OR. &
2733	SIZE( bounds_end ) /= SIZE( dimension_list ) ) THEN
2734	return_value = 1
2735	CALL internal_message( 'error', routine_name // &
2736	': variable "' // TRIM( name ) // &
2737	'" in file "' // TRIM( filename ) // &
2738	'": given bounds do not match with number of dimensions' )
2739	ENDIF
2740
2741	ENDIF
2742
2743
2744	IF ( return_value == 0 ) THEN
2745
2746	!-- Save starting index (lower bounds) of each dimension
2747	ALLOCATE( bounds_dim_start(SIZE( dimension_list )) )
2748	DO d = 1, SIZE( dimension_list )
2749	bounds_dim_start(d) = dimension_list(d)%bounds(1)
2750	ENDDO
2751
2752	ALLOCATE( bounds_start_new(SIZE( dimension_list )) )
2753	ALLOCATE( bounds_end_new(SIZE( dimension_list )) )
2754
2755	WRITE( temp_string, * ) bounds_start
2756	CALL internal_message( 'debug', routine_name // &
2757	': file "' // TRIM( filename ) // &
2758	'": variable "' // TRIM( name ) // &
2759	'": bounds_start =' // TRIM( temp_string ) )
2760	WRITE( temp_string, * ) bounds_end
2761	CALL internal_message( 'debug', routine_name // &
2762	': file "' // TRIM( filename ) // &
2763	'": variable "' // TRIM( name ) // &
2764	'": bounds_end =' // TRIM( temp_string ) )
2765
2766	!-- Get bounds for masking
2767	CALL get_masked_indices_and_masked_dimension_bounds( dimension_list, &
2768	bounds_start, bounds_end, bounds_start_new, bounds_end_new, &
2769	masked_indices, do_output )
2770
2771	WRITE( temp_string, * ) bounds_start_new
2772	CALL internal_message( 'debug', routine_name // &
2773	': file "' // TRIM( filename ) // &
2774	'": variable "' // TRIM( name ) // &
2775	'": bounds_start_new =' // TRIM( temp_string ) )
2776	WRITE( temp_string, * ) bounds_end_new
2777	CALL internal_message( 'debug', routine_name // &
2778	': file "' // TRIM( filename ) // &
2779	'": variable "' // TRIM( name ) // &
2780	'": bounds_end_new =' // TRIM( temp_string ) )
2781
2782	!-- Mask and resort variable
2783	!-- 8bit integer output
2784	IF ( PRESENT( var_int8_0d ) ) THEN
2785	var_int8_0d_pointer => var_int8_0d
2786	ELSEIF ( PRESENT( var_int8_1d ) ) THEN
2787	IF ( do_output ) THEN
2788	ALLOCATE( var_int8_1d_resorted(bounds_start_new(1):bounds_end_new(1)) )
2789	!$OMP PARALLEL PRIVATE (i)
2790	!$OMP DO
2791	DO i = bounds_start_new(1), bounds_end_new(1)
2792	var_int8_1d_resorted(i) = var_int8_1d(masked_indices(1,i))
2793	ENDDO
2794	!$OMP END PARALLEL
2795	ELSE
2796	ALLOCATE( var_int8_1d_resorted(1) )
2797	var_int8_1d_resorted = 0_1
2798	ENDIF
2799	var_int8_1d_pointer => var_int8_1d_resorted
2800	ELSEIF ( PRESENT( var_int8_2d ) ) THEN
2801	IF ( do_output ) THEN
2802	ALLOCATE( var_int8_2d_resorted(bounds_start_new(1):bounds_end_new(1), &
2803	bounds_start_new(2):bounds_end_new(2)) )
2804	!$OMP PARALLEL PRIVATE (i,j)
2805	!$OMP DO
2806	DO i = bounds_start_new(1), bounds_end_new(1)
2807	DO j = bounds_start_new(2), bounds_end_new(2)
2808	var_int8_2d_resorted(i,j) = var_int8_2d(masked_indices(2,j), &
2809	masked_indices(1,i) )
2810	ENDDO
2811	ENDDO
2812	!$OMP END PARALLEL
2813	ELSE
2814	ALLOCATE( var_int8_2d_resorted(1,1) )
2815	var_int8_2d_resorted = 0_1
2816	ENDIF
2817	var_int8_2d_pointer => var_int8_2d_resorted
2818	ELSEIF ( PRESENT( var_int8_3d ) ) THEN
2819	IF ( do_output ) THEN
2820	ALLOCATE( var_int8_3d_resorted(bounds_start_new(1):bounds_end_new(1), &
2821	bounds_start_new(2):bounds_end_new(2), &
2822	bounds_start_new(3):bounds_end_new(3)) )
2823	!$OMP PARALLEL PRIVATE (i,j,k)
2824	!$OMP DO
2825	DO i = bounds_start_new(1), bounds_end_new(1)
2826	DO j = bounds_start_new(2), bounds_end_new(2)
2827	DO k = bounds_start_new(3), bounds_end_new(3)
2828	var_int8_3d_resorted(i,j,k) = var_int8_3d(masked_indices(3,k), &
2829	masked_indices(2,j), &
2830	masked_indices(1,i) )
2831	ENDDO
2832	ENDDO
2833	ENDDO
2834	!$OMP END PARALLEL
2835	ELSE
2836	ALLOCATE( var_int8_3d_resorted(1,1,1) )
2837	var_int8_3d_resorted = 0_1
2838	ENDIF
2839	var_int8_3d_pointer => var_int8_3d_resorted
2840
2841	!-- 16bit integer output
2842	ELSEIF ( PRESENT( var_int16_0d ) ) THEN
2843	var_int16_0d_pointer => var_int16_0d
2844	ELSEIF ( PRESENT( var_int16_1d ) ) THEN
2845	IF ( do_output ) THEN
2846	ALLOCATE( var_int16_1d_resorted(bounds_start_new(1):bounds_end_new(1)) )
2847	!$OMP PARALLEL PRIVATE (i)
2848	!$OMP DO
2849	DO i = bounds_start_new(1), bounds_end_new(1)
2850	var_int16_1d_resorted(i) = var_int16_1d(masked_indices(1,i))
2851	ENDDO
2852	!$OMP END PARALLEL
2853	ELSE
2854	ALLOCATE( var_int16_1d_resorted(1) )
2855	var_int16_1d_resorted = 0_1
2856	ENDIF
2857	var_int16_1d_pointer => var_int16_1d_resorted
2858	ELSEIF ( PRESENT( var_int16_2d ) ) THEN
2859	IF ( do_output ) THEN
2860	ALLOCATE( var_int16_2d_resorted(bounds_start_new(1):bounds_end_new(1), &
2861	bounds_start_new(2):bounds_end_new(2)) )
2862	!$OMP PARALLEL PRIVATE (i,j)
2863	!$OMP DO
2864	DO i = bounds_start_new(1), bounds_end_new(1)
2865	DO j = bounds_start_new(2), bounds_end_new(2)
2866	var_int16_2d_resorted(i,j) = var_int16_2d(masked_indices(2,j), &
2867	masked_indices(1,i))
2868	ENDDO
2869	ENDDO
2870	!$OMP END PARALLEL
2871	ELSE
2872	ALLOCATE( var_int16_2d_resorted(1,1) )
2873	var_int16_2d_resorted = 0_1
2874	ENDIF
2875	var_int16_2d_pointer => var_int16_2d_resorted
2876	ELSEIF ( PRESENT( var_int16_3d ) ) THEN
2877	IF ( do_output ) THEN
2878	ALLOCATE( var_int16_3d_resorted(bounds_start_new(1):bounds_end_new(1), &
2879	bounds_start_new(2):bounds_end_new(2), &
2880	bounds_start_new(3):bounds_end_new(3)) )
2881	!$OMP PARALLEL PRIVATE (i,j,k)
2882	!$OMP DO
2883	DO i = bounds_start_new(1), bounds_end_new(1)
2884	DO j = bounds_start_new(2), bounds_end_new(2)
2885	DO k = bounds_start_new(3), bounds_end_new(3)
2886	var_int16_3d_resorted(i,j,k) = var_int16_3d(masked_indices(3,k), &
2887	masked_indices(2,j), &
2888	masked_indices(1,i) )
2889	ENDDO
2890	ENDDO
2891	ENDDO
2892	!$OMP END PARALLEL
2893	ELSE
2894	ALLOCATE( var_int16_3d_resorted(1,1,1) )
2895	var_int16_3d_resorted = 0_1
2896	ENDIF
2897	var_int16_3d_pointer => var_int16_3d_resorted
2898
2899	!-- 32bit integer output
2900	ELSEIF ( PRESENT( var_int32_0d ) ) THEN
2901	var_int32_0d_pointer => var_int32_0d
2902	ELSEIF ( PRESENT( var_int32_1d ) ) THEN
2903	IF ( do_output ) THEN
2904	ALLOCATE( var_int32_1d_resorted(bounds_start_new(1):bounds_end_new(1)) )
2905	!$OMP PARALLEL PRIVATE (i)
2906	!$OMP DO
2907	DO i = bounds_start_new(1), bounds_end_new(1)
2908	var_int32_1d_resorted(i) = var_int32_1d(masked_indices(1,i))
2909	ENDDO
2910	!$OMP END PARALLEL
2911	ELSE
2912	ALLOCATE( var_int32_1d_resorted(1) )
2913	var_int32_1d_resorted = 0_1
2914	ENDIF
2915	var_int32_1d_pointer => var_int32_1d_resorted
2916	ELSEIF ( PRESENT( var_int32_2d ) ) THEN
2917	IF ( do_output ) THEN
2918	ALLOCATE( var_int32_2d_resorted(bounds_start_new(1):bounds_end_new(1), &
2919	bounds_start_new(2):bounds_end_new(2)) )
2920	!$OMP PARALLEL PRIVATE (i,j)
2921	!$OMP DO
2922	DO i = bounds_start_new(1), bounds_end_new(1)
2923	DO j = bounds_start_new(2), bounds_end_new(2)
2924	var_int32_2d_resorted(i,j) = var_int32_2d(masked_indices(2,j), &
2925	masked_indices(1,i) )
2926	ENDDO
2927	ENDDO
2928	!$OMP END PARALLEL
2929	ELSE
2930	ALLOCATE( var_int32_2d_resorted(1,1) )
2931	var_int32_2d_resorted = 0_1
2932	ENDIF
2933	var_int32_2d_pointer => var_int32_2d_resorted
2934	ELSEIF ( PRESENT( var_int32_3d ) ) THEN
2935	IF ( do_output ) THEN
2936	ALLOCATE( var_int32_3d_resorted(bounds_start_new(1):bounds_end_new(1), &
2937	bounds_start_new(2):bounds_end_new(2), &
2938	bounds_start_new(3):bounds_end_new(3)) )
2939	!$OMP PARALLEL PRIVATE (i,j,k)
2940	!$OMP DO
2941	DO i = bounds_start_new(1), bounds_end_new(1)
2942	DO j = bounds_start_new(2), bounds_end_new(2)
2943	DO k = bounds_start_new(3), bounds_end_new(3)
2944	var_int32_3d_resorted(i,j,k) = var_int32_3d(masked_indices(3,k), &
2945	masked_indices(2,j), &
2946	masked_indices(1,i) )
2947	ENDDO
2948	ENDDO
2949	ENDDO
2950	!$OMP END PARALLEL
2951	ELSE
2952	ALLOCATE( var_int32_3d_resorted(1,1,1) )
2953	var_int32_3d_resorted = 0_1
2954	ENDIF
2955	var_int32_3d_pointer => var_int32_3d_resorted
2956
2957	!-- working-precision integer output
2958	ELSEIF ( PRESENT( var_intwp_0d ) ) THEN
2959	var_intwp_0d_pointer => var_intwp_0d
2960	ELSEIF ( PRESENT( var_intwp_1d ) ) THEN
2961	IF ( do_output ) THEN
2962	ALLOCATE( var_intwp_1d_resorted(bounds_start_new(1):bounds_end_new(1)) )
2963	!$OMP PARALLEL PRIVATE (i)
2964	!$OMP DO
2965	DO i = bounds_start_new(1), bounds_end_new(1)
2966	var_intwp_1d_resorted(i) = var_intwp_1d(masked_indices(1,i))
2967	ENDDO
2968	!$OMP END PARALLEL
2969	ELSE
2970	ALLOCATE( var_intwp_1d_resorted(1) )
2971	var_intwp_1d_resorted = 0_1
2972	ENDIF
2973	var_intwp_1d_pointer => var_intwp_1d_resorted
2974	ELSEIF ( PRESENT( var_intwp_2d ) ) THEN
2975	IF ( do_output ) THEN
2976	ALLOCATE( var_intwp_2d_resorted(bounds_start_new(1):bounds_end_new(1), &
2977	bounds_start_new(2):bounds_end_new(2)) )
2978	!$OMP PARALLEL PRIVATE (i,j)
2979	!$OMP DO
2980	DO i = bounds_start_new(1), bounds_end_new(1)
2981	DO j = bounds_start_new(2), bounds_end_new(2)
2982	var_intwp_2d_resorted(i,j) = var_intwp_2d(masked_indices(2,j), &
2983	masked_indices(1,i) )
2984	ENDDO
2985	ENDDO
2986	!$OMP END PARALLEL
2987	ELSE
2988	ALLOCATE( var_intwp_2d_resorted(1,1) )
2989	var_intwp_2d_resorted = 0_1
2990	ENDIF
2991	var_intwp_2d_pointer => var_intwp_2d_resorted
2992	ELSEIF ( PRESENT( var_intwp_3d ) ) THEN
2993	IF ( do_output ) THEN
2994	ALLOCATE( var_intwp_3d_resorted(bounds_start_new(1):bounds_end_new(1), &
2995	bounds_start_new(2):bounds_end_new(2), &
2996	bounds_start_new(3):bounds_end_new(3)) )
2997	!$OMP PARALLEL PRIVATE (i,j,k)
2998	!$OMP DO
2999	DO i = bounds_start_new(1), bounds_end_new(1)
3000	DO j = bounds_start_new(2), bounds_end_new(2)
3001	DO k = bounds_start_new(3), bounds_end_new(3)
3002	var_intwp_3d_resorted(i,j,k) = var_intwp_3d(masked_indices(3,k), &
3003	masked_indices(2,j), &
3004	masked_indices(1,i) )
3005	ENDDO
3006	ENDDO
3007	ENDDO
3008	!$OMP END PARALLEL
3009	ELSE
3010	ALLOCATE( var_intwp_3d_resorted(1,1,1) )
3011	var_intwp_3d_resorted = 0_1
3012	ENDIF
3013	var_intwp_3d_pointer => var_intwp_3d_resorted
3014
3015	!-- 32bit real output
3016	ELSEIF ( PRESENT( var_real32_0d ) ) THEN
3017	var_real32_0d_pointer => var_real32_0d
3018	ELSEIF ( PRESENT( var_real32_1d ) ) THEN
3019	IF ( do_output ) THEN
3020	ALLOCATE( var_real32_1d_resorted(bounds_start_new(1):bounds_end_new(1)) )
3021	!$OMP PARALLEL PRIVATE (i)
3022	!$OMP DO
3023	DO i = bounds_start_new(1), bounds_end_new(1)
3024	var_real32_1d_resorted(i) = var_real32_1d(masked_indices(1,i))
3025	ENDDO
3026	!$OMP END PARALLEL
3027	ELSE
3028	ALLOCATE( var_real32_1d_resorted(1) )
3029	var_real32_1d_resorted = 0_1
3030	ENDIF
3031	var_real32_1d_pointer => var_real32_1d_resorted
3032	ELSEIF ( PRESENT( var_real32_2d ) ) THEN
3033	IF ( do_output ) THEN
3034	ALLOCATE( var_real32_2d_resorted(bounds_start_new(1):bounds_end_new(1), &
3035	bounds_start_new(2):bounds_end_new(2)) )
3036	!$OMP PARALLEL PRIVATE (i,j)
3037	!$OMP DO
3038	DO i = bounds_start_new(1), bounds_end_new(1)
3039	DO j = bounds_start_new(2), bounds_end_new(2)
3040	var_real32_2d_resorted(i,j) = var_real32_2d(masked_indices(2,j), &
3041	masked_indices(1,i) )
3042	ENDDO
3043	ENDDO
3044	!$OMP END PARALLEL
3045	ELSE
3046	ALLOCATE( var_real32_2d_resorted(1,1) )
3047	var_real32_2d_resorted = 0_1
3048	ENDIF
3049	var_real32_2d_pointer => var_real32_2d_resorted
3050	ELSEIF ( PRESENT( var_real32_3d ) ) THEN
3051	IF ( do_output ) THEN
3052	ALLOCATE( var_real32_3d_resorted(bounds_start_new(1):bounds_end_new(1), &
3053	bounds_start_new(2):bounds_end_new(2), &
3054	bounds_start_new(3):bounds_end_new(3)) )
3055	!$OMP PARALLEL PRIVATE (i,j,k)
3056	!$OMP DO
3057	DO i = bounds_start_new(1), bounds_end_new(1)
3058	DO j = bounds_start_new(2), bounds_end_new(2)
3059	DO k = bounds_start_new(3), bounds_end_new(3)
3060	var_real32_3d_resorted(i,j,k) = var_real32_3d(masked_indices(3,k), &
3061	masked_indices(2,j), &
3062	masked_indices(1,i) )
3063	ENDDO
3064	ENDDO
3065	ENDDO
3066	!$OMP END PARALLEL
3067	ELSE
3068	ALLOCATE( var_real32_3d_resorted(1,1,1) )
3069	var_real32_3d_resorted = 0_1
3070	ENDIF
3071	var_real32_3d_pointer => var_real32_3d_resorted
3072
3073	!-- 64bit real output
3074	ELSEIF ( PRESENT( var_real64_0d ) ) THEN
3075	var_real64_0d_pointer => var_real64_0d
3076	ELSEIF ( PRESENT( var_real64_1d ) ) THEN
3077	IF ( do_output ) THEN
3078	ALLOCATE( var_real64_1d_resorted(bounds_start_new(1):bounds_end_new(1)) )
3079	!$OMP PARALLEL PRIVATE (i)
3080	!$OMP DO
3081	DO i = bounds_start_new(1), bounds_end_new(1)
3082	var_real64_1d_resorted(i) = var_real64_1d(masked_indices(1,i))
3083	ENDDO
3084	!$OMP END PARALLEL
3085	ELSE
3086	ALLOCATE( var_real64_1d_resorted(1) )
3087	var_real64_1d_resorted = 0_1
3088	ENDIF
3089	var_real64_1d_pointer => var_real64_1d_resorted
3090	ELSEIF ( PRESENT( var_real64_2d ) ) THEN
3091	IF ( do_output ) THEN
3092	ALLOCATE( var_real64_2d_resorted(bounds_start_new(1):bounds_end_new(1), &
3093	bounds_start_new(2):bounds_end_new(2)) )
3094	!$OMP PARALLEL PRIVATE (i,j)
3095	!$OMP DO
3096	DO i = bounds_start_new(1), bounds_end_new(1)
3097	DO j = bounds_start_new(2), bounds_end_new(2)
3098	var_real64_2d_resorted(i,j) = var_real64_2d(masked_indices(2,j), &
3099	masked_indices(1,i) )
3100	ENDDO
3101	ENDDO
3102	!$OMP END PARALLEL
3103	ELSE
3104	ALLOCATE( var_real64_2d_resorted(1,1) )
3105	var_real64_2d_resorted = 0_1
3106	ENDIF
3107	var_real64_2d_pointer => var_real64_2d_resorted
3108	ELSEIF ( PRESENT( var_real64_3d ) ) THEN
3109	IF ( do_output ) THEN
3110	ALLOCATE( var_real64_3d_resorted(bounds_start_new(1):bounds_end_new(1), &
3111	bounds_start_new(2):bounds_end_new(2), &
3112	bounds_start_new(3):bounds_end_new(3)) )
3113	!$OMP PARALLEL PRIVATE (i,j,k)
3114	!$OMP DO
3115	DO i = bounds_start_new(1), bounds_end_new(1)
3116	DO j = bounds_start_new(2), bounds_end_new(2)
3117	DO k = bounds_start_new(3), bounds_end_new(3)
3118	var_real64_3d_resorted(i,j,k) = var_real64_3d(masked_indices(3,k), &
3119	masked_indices(2,j), &
3120	masked_indices(1,i) )
3121	ENDDO
3122	ENDDO
3123	ENDDO
3124	!$OMP END PARALLEL
3125	ELSE
3126	ALLOCATE( var_real64_3d_resorted(1,1,1) )
3127	var_real64_3d_resorted = 0_1
3128	ENDIF
3129	var_real64_3d_pointer => var_real64_3d_resorted
3130
3131	!-- working-precision real output
3132	ELSEIF ( PRESENT( var_realwp_0d ) ) THEN
3133	var_realwp_0d_pointer => var_realwp_0d
3134	ELSEIF ( PRESENT( var_realwp_1d ) ) THEN
3135	IF ( do_output ) THEN
3136	ALLOCATE( var_realwp_1d_resorted(bounds_start_new(1):bounds_end_new(1)) )
3137	!$OMP PARALLEL PRIVATE (i)
3138	!$OMP DO
3139	DO i = bounds_start_new(1), bounds_end_new(1)
3140	var_realwp_1d_resorted(i) = var_realwp_1d(masked_indices(1,i))
3141	ENDDO
3142	!$OMP END PARALLEL
3143	ELSE
3144	ALLOCATE( var_realwp_1d_resorted(1) )
3145	var_realwp_1d_resorted = 0_1
3146	ENDIF
3147	var_realwp_1d_pointer => var_realwp_1d_resorted
3148	ELSEIF ( PRESENT( var_realwp_2d ) ) THEN
3149	IF ( do_output ) THEN
3150	ALLOCATE( var_realwp_2d_resorted(bounds_start_new(1):bounds_end_new(1), &
3151	bounds_start_new(2):bounds_end_new(2)) )
3152	!$OMP PARALLEL PRIVATE (i,j)
3153	!$OMP DO
3154	DO i = bounds_start_new(1), bounds_end_new(1)
3155	DO j = bounds_start_new(2), bounds_end_new(2)
3156	var_realwp_2d_resorted(i,j) = var_realwp_2d(masked_indices(2,j), &
3157	masked_indices(1,i) )
3158	ENDDO
3159	ENDDO
3160	!$OMP END PARALLEL
3161	ELSE
3162	ALLOCATE( var_realwp_2d_resorted(1,1) )
3163	var_realwp_2d_resorted = 0_1
3164	ENDIF
3165	var_realwp_2d_pointer => var_realwp_2d_resorted
3166	ELSEIF ( PRESENT( var_realwp_3d ) ) THEN
3167	IF ( do_output ) THEN
3168	ALLOCATE( var_realwp_3d_resorted(bounds_start_new(1):bounds_end_new(1), &
3169	bounds_start_new(2):bounds_end_new(2), &
3170	bounds_start_new(3):bounds_end_new(3)) )
3171	!$OMP PARALLEL PRIVATE (i,j,k)
3172	!$OMP DO
3173	DO i = bounds_start_new(1), bounds_end_new(1)
3174	DO j = bounds_start_new(2), bounds_end_new(2)
3175	DO k = bounds_start_new(3), bounds_end_new(3)
3176	var_realwp_3d_resorted(i,j,k) = var_realwp_3d(masked_indices(3,k), &
3177	masked_indices(2,j), &
3178	masked_indices(1,i) )
3179	ENDDO
3180	ENDDO
3181	ENDDO
3182	!$OMP END PARALLEL
3183	ELSE
3184	ALLOCATE( var_realwp_3d_resorted(1,1,1) )
3185	var_realwp_3d_resorted = 0_1
3186	ENDIF
3187	var_realwp_3d_pointer => var_realwp_3d_resorted
3188
3189	ELSE
3190	return_value = 1
3191	CALL internal_message( 'error', routine_name // &
3192	': variable "' // TRIM( name ) // &
3193	'" in file "' // TRIM( filename ) // &
3194	'": no values given to output' )
3195	ENDIF
3196
3197	DEALLOCATE( masked_indices )
3198
3199	ENDIF ! Check for error
3200
3201	IF ( return_value == 0 ) THEN
3202
3203	!-- Write variable into file
3204	SELECT CASE ( TRIM( file_format ) )
3205
3206	CASE ( 'binary' )
3207	!-- 8bit integer output
3208	IF ( PRESENT( var_int8_0d ) ) THEN
3209	CALL binary_write_variable( file_id, var_id, &
3210	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3211	var_int8_0d=var_int8_0d_pointer, return_value=output_return_value )
3212	ELSEIF ( PRESENT( var_int8_1d ) ) THEN
3213	CALL binary_write_variable( file_id, var_id, &
3214	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3215	var_int8_1d=var_int8_1d_pointer, return_value=output_return_value )
3216	ELSEIF ( PRESENT( var_int8_2d ) ) THEN
3217	CALL binary_write_variable( file_id, var_id, &
3218	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3219	var_int8_2d=var_int8_2d_pointer, return_value=output_return_value )
3220	ELSEIF ( PRESENT( var_int8_3d ) ) THEN
3221	CALL binary_write_variable( file_id, var_id, &
3222	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3223	var_int8_3d=var_int8_3d_pointer, return_value=output_return_value )
3224	!-- 16bit integer output
3225	ELSEIF ( PRESENT( var_int16_0d ) ) THEN
3226	CALL binary_write_variable( file_id, var_id, &
3227	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3228	var_int16_0d=var_int16_0d_pointer, return_value=output_return_value )
3229	ELSEIF ( PRESENT( var_int16_1d ) ) THEN
3230	CALL binary_write_variable( file_id, var_id, &
3231	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3232	var_int16_1d=var_int16_1d_pointer, return_value=output_return_value )
3233	ELSEIF ( PRESENT( var_int16_2d ) ) THEN
3234	CALL binary_write_variable( file_id, var_id, &
3235	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3236	var_int16_2d=var_int16_2d_pointer, return_value=output_return_value )
3237	ELSEIF ( PRESENT( var_int16_3d ) ) THEN
3238	CALL binary_write_variable( file_id, var_id, &
3239	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3240	var_int16_3d=var_int16_3d_pointer, return_value=output_return_value )
3241	!-- 32bit integer output
3242	ELSEIF ( PRESENT( var_int32_0d ) ) THEN
3243	CALL binary_write_variable( file_id, var_id, &
3244	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3245	var_int32_0d=var_int32_0d_pointer, return_value=output_return_value )
3246	ELSEIF ( PRESENT( var_int32_1d ) ) THEN
3247	CALL binary_write_variable( file_id, var_id, &
3248	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3249	var_int32_1d=var_int32_1d_pointer, return_value=output_return_value )
3250	ELSEIF ( PRESENT( var_int32_2d ) ) THEN
3251	CALL binary_write_variable( file_id, var_id, &
3252	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3253	var_int32_2d=var_int32_2d_pointer, return_value=output_return_value )
3254	ELSEIF ( PRESENT( var_int32_3d ) ) THEN
3255	CALL binary_write_variable( file_id, var_id, &
3256	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3257	var_int32_3d=var_int32_3d_pointer, return_value=output_return_value )
3258	!-- working-precision integer output
3259	ELSEIF ( PRESENT( var_intwp_0d ) ) THEN
3260	CALL binary_write_variable( file_id, var_id, &
3261	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3262	var_intwp_0d=var_intwp_0d_pointer, return_value=output_return_value )
3263	ELSEIF ( PRESENT( var_intwp_1d ) ) THEN
3264	CALL binary_write_variable( file_id, var_id, &
3265	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3266	var_intwp_1d=var_intwp_1d_pointer, return_value=output_return_value )
3267	ELSEIF ( PRESENT( var_intwp_2d ) ) THEN
3268	CALL binary_write_variable( file_id, var_id, &
3269	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3270	var_intwp_2d=var_intwp_2d_pointer, return_value=output_return_value )
3271	ELSEIF ( PRESENT( var_intwp_3d ) ) THEN
3272	CALL binary_write_variable( file_id, var_id, &
3273	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3274	var_intwp_3d=var_intwp_3d_pointer, return_value=output_return_value )
3275	!-- 32bit real output
3276	ELSEIF ( PRESENT( var_real32_0d ) ) THEN
3277	CALL binary_write_variable( file_id, var_id, &
3278	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3279	var_real32_0d=var_real32_0d_pointer, return_value=output_return_value )
3280	ELSEIF ( PRESENT( var_real32_1d ) ) THEN
3281	CALL binary_write_variable( file_id, var_id, &
3282	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3283	var_real32_1d=var_real32_1d_pointer, return_value=output_return_value )
3284	ELSEIF ( PRESENT( var_real32_2d ) ) THEN
3285	CALL binary_write_variable( file_id, var_id, &
3286	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3287	var_real32_2d=var_real32_2d_pointer, return_value=output_return_value )
3288	ELSEIF ( PRESENT( var_real32_3d ) ) THEN
3289	CALL binary_write_variable( file_id, var_id, &
3290	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3291	var_real32_3d=var_real32_3d_pointer, return_value=output_return_value )
3292	!-- 64bit real output
3293	ELSEIF ( PRESENT( var_real64_0d ) ) THEN
3294	CALL binary_write_variable( file_id, var_id, &
3295	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3296	var_real64_0d=var_real64_0d_pointer, return_value=output_return_value )
3297	ELSEIF ( PRESENT( var_real64_1d ) ) THEN
3298	CALL binary_write_variable( file_id, var_id, &
3299	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3300	var_real64_1d=var_real64_1d_pointer, return_value=output_return_value )
3301	ELSEIF ( PRESENT( var_real64_2d ) ) THEN
3302	CALL binary_write_variable( file_id, var_id, &
3303	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3304	var_real64_2d=var_real64_2d_pointer, return_value=output_return_value )
3305	ELSEIF ( PRESENT( var_real64_3d ) ) THEN
3306	CALL binary_write_variable( file_id, var_id, &
3307	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3308	var_real64_3d=var_real64_3d_pointer, return_value=output_return_value )
3309	!-- working-precision real output
3310	ELSEIF ( PRESENT( var_realwp_0d ) ) THEN
3311	CALL binary_write_variable( file_id, var_id, &
3312	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3313	var_realwp_0d=var_realwp_0d_pointer, return_value=output_return_value )
3314	ELSEIF ( PRESENT( var_realwp_1d ) ) THEN
3315	CALL binary_write_variable( file_id, var_id, &
3316	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3317	var_realwp_1d=var_realwp_1d_pointer, return_value=output_return_value )
3318	ELSEIF ( PRESENT( var_realwp_2d ) ) THEN
3319	CALL binary_write_variable( file_id, var_id, &
3320	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3321	var_realwp_2d=var_realwp_2d_pointer, return_value=output_return_value )
3322	ELSEIF ( PRESENT( var_realwp_3d ) ) THEN
3323	CALL binary_write_variable( file_id, var_id, &
3324	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3325	var_realwp_3d=var_realwp_3d_pointer, return_value=output_return_value )
3326	ELSE
3327	return_value = 1
3328	CALL internal_message( 'error', routine_name // &
3329	': variable "' // TRIM( name ) // &
3330	'" in file "' // TRIM( filename ) // &
3331	'": output_type not supported by file format "' // &
3332	TRIM( file_format ) // '"' )
3333	ENDIF
3334
3335	CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
3336	!-- 8bit integer output
3337	IF ( PRESENT( var_int8_0d ) ) THEN
3338	CALL netcdf4_write_variable( file_id, var_id, &
3339	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3340	var_int8_0d=var_int8_0d_pointer, return_value=output_return_value )
3341	ELSEIF ( PRESENT( var_int8_1d ) ) THEN
3342	CALL netcdf4_write_variable( file_id, var_id, &
3343	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3344	var_int8_1d=var_int8_1d_pointer, return_value=output_return_value )
3345	ELSEIF ( PRESENT( var_int8_2d ) ) THEN
3346	CALL netcdf4_write_variable( file_id, var_id, &
3347	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3348	var_int8_2d=var_int8_2d_pointer, return_value=output_return_value )
3349	ELSEIF ( PRESENT( var_int8_3d ) ) THEN
3350	CALL netcdf4_write_variable( file_id, var_id, &
3351	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3352	var_int8_3d=var_int8_3d_pointer, return_value=output_return_value )
3353	!-- 16bit integer output
3354	ELSEIF ( PRESENT( var_int16_0d ) ) THEN
3355	CALL netcdf4_write_variable( file_id, var_id, &
3356	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3357	var_int16_0d=var_int16_0d_pointer, return_value=output_return_value )
3358	ELSEIF ( PRESENT( var_int16_1d ) ) THEN
3359	CALL netcdf4_write_variable( file_id, var_id, &
3360	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3361	var_int16_1d=var_int16_1d_pointer, return_value=output_return_value )
3362	ELSEIF ( PRESENT( var_int16_2d ) ) THEN
3363	CALL netcdf4_write_variable( file_id, var_id, &
3364	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3365	var_int16_2d=var_int16_2d_pointer, return_value=output_return_value )
3366	ELSEIF ( PRESENT( var_int16_3d ) ) THEN
3367	CALL netcdf4_write_variable( file_id, var_id, &
3368	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3369	var_int16_3d=var_int16_3d_pointer, return_value=output_return_value )
3370	!-- 32bit integer output
3371	ELSEIF ( PRESENT( var_int32_0d ) ) THEN
3372	CALL netcdf4_write_variable( file_id, var_id, &
3373	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3374	var_int32_0d=var_int32_0d_pointer, return_value=output_return_value )
3375	ELSEIF ( PRESENT( var_int32_1d ) ) THEN
3376	CALL netcdf4_write_variable( file_id, var_id, &
3377	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3378	var_int32_1d=var_int32_1d_pointer, return_value=output_return_value )
3379	ELSEIF ( PRESENT( var_int32_2d ) ) THEN
3380	CALL netcdf4_write_variable( file_id, var_id, &
3381	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3382	var_int32_2d=var_int32_2d_pointer, return_value=output_return_value )
3383	ELSEIF ( PRESENT( var_int32_3d ) ) THEN
3384	CALL netcdf4_write_variable( file_id, var_id, &
3385	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3386	var_int32_3d=var_int32_3d_pointer, return_value=output_return_value )
3387	!-- working-precision integer output
3388	ELSEIF ( PRESENT( var_intwp_0d ) ) THEN
3389	CALL netcdf4_write_variable( file_id, var_id, &
3390	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3391	var_intwp_0d=var_intwp_0d_pointer, return_value=output_return_value )
3392	ELSEIF ( PRESENT( var_intwp_1d ) ) THEN
3393	CALL netcdf4_write_variable( file_id, var_id, &
3394	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3395	var_intwp_1d=var_intwp_1d_pointer, return_value=output_return_value )
3396	ELSEIF ( PRESENT( var_intwp_2d ) ) THEN
3397	CALL netcdf4_write_variable( file_id, var_id, &
3398	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3399	var_intwp_2d=var_intwp_2d_pointer, return_value=output_return_value )
3400	ELSEIF ( PRESENT( var_intwp_3d ) ) THEN
3401	CALL netcdf4_write_variable( file_id, var_id, &
3402	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3403	var_intwp_3d=var_intwp_3d_pointer, return_value=output_return_value )
3404	!-- 32bit real output
3405	ELSEIF ( PRESENT( var_real32_0d ) ) THEN
3406	CALL netcdf4_write_variable( file_id, var_id, &
3407	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3408	var_real32_0d=var_real32_0d_pointer, return_value=output_return_value )
3409	ELSEIF ( PRESENT( var_real32_1d ) ) THEN
3410	CALL netcdf4_write_variable( file_id, var_id, &
3411	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3412	var_real32_1d=var_real32_1d_pointer, return_value=output_return_value )
3413	ELSEIF ( PRESENT( var_real32_2d ) ) THEN
3414	CALL netcdf4_write_variable( file_id, var_id, &
3415	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3416	var_real32_2d=var_real32_2d_pointer, return_value=output_return_value )
3417	ELSEIF ( PRESENT( var_real32_3d ) ) THEN
3418	CALL netcdf4_write_variable( file_id, var_id, &
3419	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3420	var_real32_3d=var_real32_3d_pointer, return_value=output_return_value )
3421	!-- 64bit real output
3422	ELSEIF ( PRESENT( var_real64_0d ) ) THEN
3423	CALL netcdf4_write_variable( file_id, var_id, &
3424	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3425	var_real64_0d=var_real64_0d_pointer, return_value=output_return_value )
3426	ELSEIF ( PRESENT( var_real64_1d ) ) THEN
3427	CALL netcdf4_write_variable( file_id, var_id, &
3428	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3429	var_real64_1d=var_real64_1d_pointer, return_value=output_return_value )
3430	ELSEIF ( PRESENT( var_real64_2d ) ) THEN
3431	CALL netcdf4_write_variable( file_id, var_id, &
3432	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3433	var_real64_2d=var_real64_2d_pointer, return_value=output_return_value )
3434	ELSEIF ( PRESENT( var_real64_3d ) ) THEN
3435	CALL netcdf4_write_variable( file_id, var_id, &
3436	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3437	var_real64_3d=var_real64_3d_pointer, return_value=output_return_value )
3438	!-- working-precision real output
3439	ELSEIF ( PRESENT( var_realwp_0d ) ) THEN
3440	CALL netcdf4_write_variable( file_id, var_id, &
3441	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3442	var_realwp_0d=var_realwp_0d_pointer, return_value=output_return_value )
3443	ELSEIF ( PRESENT( var_realwp_1d ) ) THEN
3444	CALL netcdf4_write_variable( file_id, var_id, &
3445	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3446	var_realwp_1d=var_realwp_1d_pointer, return_value=output_return_value )
3447	ELSEIF ( PRESENT( var_realwp_2d ) ) THEN
3448	CALL netcdf4_write_variable( file_id, var_id, &
3449	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3450	var_realwp_2d=var_realwp_2d_pointer, return_value=output_return_value )
3451	ELSEIF ( PRESENT( var_realwp_3d ) ) THEN
3452	CALL netcdf4_write_variable( file_id, var_id, &
3453	bounds_start_new, bounds_end_new, bounds_dim_start, do_output, is_global, &
3454	var_realwp_3d=var_realwp_3d_pointer, return_value=output_return_value )
3455	ELSE
3456	return_value = 1
3457	CALL internal_message( 'error', routine_name // &
3458	': variable "' // TRIM( name ) // &
3459	'" in file "' // TRIM( filename ) // &
3460	'": output_type not supported by file format "' // &
3461	TRIM( file_format ) // '"' )
3462	ENDIF
3463
3464	CASE DEFAULT
3465	return_value = 1
3466	CALL internal_message( 'error', routine_name // &
3467	': file "' // TRIM( filename ) // &
3468	'": file format "' // TRIM( file_format ) // &
3469	'" not supported' )
3470
3471	END SELECT
3472
3473	IF ( return_value == 0 .AND. output_return_value /= 0 ) THEN
3474	return_value = 1
3475	CALL internal_message( 'error', routine_name // &
3476	': error while writing variable "' // TRIM( name ) // &
3477	'" in file "' // TRIM( filename ) // '"' )
3478	ENDIF
3479
3480	ENDIF
3481
3482	END FUNCTION dom_write_var
3483
3484	!--------------------------------------------------------------------------------------------------!
3485	! Description:
3486	! ------------
3487	!> Find a requested variable 'var_name' and its used dimensions in requested file 'filename'.
3488	!--------------------------------------------------------------------------------------------------!
3489	SUBROUTINE find_var_in_file( filename, var_name, file_format, file_id, var_id, &
3490	is_global, dimensions, return_value )
3491
3492	CHARACTER(LEN=charlen), INTENT(OUT) :: file_format !< file format chosen for file
3493	CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
3494	CHARACTER(LEN=*), INTENT(IN) :: var_name !< name of variable
3495
3496	CHARACTER(LEN=*), PARAMETER :: routine_name = 'find_var_in_file' !< name of routine
3497
3498	INTEGER(iwp) :: d !< loop index
3499	INTEGER(iwp) :: dd !< loop index
3500	INTEGER(iwp) :: f !< loop index
3501	INTEGER(iwp), INTENT(OUT) :: file_id !< file ID
3502	INTEGER(iwp), INTENT(OUT) :: return_value !< return value
3503	INTEGER(iwp), INTENT(OUT) :: var_id !< variable ID
3504
3505	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: dim_ids !< list of dimension IDs used by variable
3506
3507	LOGICAL :: found !< true if requested variable found in requested file
3508	LOGICAL, INTENT(OUT) :: is_global !< true if variable is global
3509
3510	TYPE(dimension_type), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dimensions !< list of dimensions used by variable
3511
3512
3513	return_value = 0
3514	found = .FALSE.
3515
3516	DO f = 1, nf
3517	IF ( TRIM( filename ) == TRIM( files(f)%name ) ) THEN
3518
3519	IF ( .NOT. files(f)%is_init ) THEN
3520	return_value = 1
3521	CALL internal_message( 'error', routine_name // &
3522	': file "' // TRIM( filename ) // &
3523	'" is not initialized. ' // &
3524	'Writing variable "' // TRIM( var_name ) // &
3525	'" to file is impossible.' )
3526	EXIT
3527	ENDIF
3528
3529	file_id = files(f)%id
3530	file_format = files(f)%format
3531
3532	!-- Search for variable in file
3533	DO d = 1, SIZE( files(f)%variables )
3534	IF ( TRIM( var_name ) == TRIM( files(f)%variables(d)%name ) ) THEN
3535
3536	var_id = files(f)%variables(d)%id
3537	is_global = files(f)%variables(d)%is_global
3538
3539	ALLOCATE( dim_ids(SIZE( files(f)%variables(d)%dimension_ids )) )
3540	ALLOCATE( dimensions(SIZE( files(f)%variables(d)%dimension_ids )) )
3541
3542	dim_ids = files(f)%variables(d)%dimension_ids
3543
3544	found = .TRUE.
3545	EXIT
3546
3547	ENDIF
3548	ENDDO
3549
3550	IF ( found ) THEN
3551
3552	!-- Get list of dimensions used by variable
3553	DO d = 1, SIZE( files(f)%dimensions )
3554	DO dd = 1, SIZE( dim_ids )
3555	IF ( dim_ids(dd) == files(f)%dimensions(d)%id ) THEN
3556	dimensions(dd) = files(f)%dimensions(d)
3557	EXIT
3558	ENDIF
3559	ENDDO
3560	ENDDO
3561
3562	ELSE
3563
3564	!-- If variable was not found, search for a dimension instead
3565	DO d = 1, SIZE( files(f)%dimensions )
3566	IF ( TRIM( var_name ) == TRIM( files(f)%dimensions(d)%name ) ) THEN
3567
3568	var_id = files(f)%dimensions(d)%var_id
3569	is_global = .TRUE.
3570
3571	ALLOCATE( dimensions(1) )
3572
3573	dimensions(1) = files(f)%dimensions(d)
3574
3575	found = .TRUE.
3576	EXIT
3577
3578	ENDIF
3579	ENDDO
3580
3581	ENDIF
3582
3583	!-- If variable was not found in requested file, return an error
3584	IF ( .NOT. found ) THEN
3585	return_value = 1
3586	CALL internal_message( 'error', routine_name // &
3587	': variable "' // TRIM( var_name ) // &
3588	'" not found in file "' // TRIM( filename ) // '"' )
3589	ENDIF
3590
3591	EXIT
3592
3593	ENDIF ! file found
3594	ENDDO ! loop over files
3595
3596	IF ( .NOT. found .AND. return_value == 0 ) THEN
3597	return_value = 1
3598	CALL internal_message( 'error', routine_name // &
3599	': file "' // TRIM( filename ) // &
3600	'" for variable "' // TRIM( var_name ) // &
3601	'" not found' )
3602	ENDIF
3603
3604	END SUBROUTINE find_var_in_file
3605
3606	!--------------------------------------------------------------------------------------------------!
3607	! Description:
3608	! ------------
3609	!> Search for masked indices of dimensions within the given bounds ('bounds_start' and
3610	!> 'bounds_end'). Return the masked indices ('masked_indices') of the dimensions and the bounds of
3611	!> the masked dimensions containing these indices ('bounds_masked_start' and 'bounds_masked_end').
3612	!> If no masked indices lie within the given bounds, 'mask_in_bounds' is .FALSE..
3613	!--------------------------------------------------------------------------------------------------!
3614	SUBROUTINE get_masked_indices_and_masked_dimension_bounds( &
3615	dimensions, bounds_start, bounds_end, bounds_masked_start, bounds_masked_end, &
3616	masked_indices, mask_in_bounds )
3617
3618	! CHARACTER(LEN=*), PARAMETER :: routine_name = 'get_masked_indices_and_masked_dimension_bounds' !< name of routine
3619
3620	INTEGER(iwp) :: d !< loop index
3621	INTEGER(iwp) :: i !< loop index
3622	INTEGER(iwp) :: j !< count index
3623
3624	INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_end !< upper bonuds to be searched in
3625	INTEGER(iwp), DIMENSION(:), INTENT(OUT) :: bounds_masked_end !< upper bounds of masked dimensions within given bounds
3626	INTEGER(iwp), DIMENSION(:), INTENT(OUT) :: bounds_masked_start !< lower bounds of masked dimensions within given bounds
3627	INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_start !< lower bounds to be searched in
3628
3629	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: masked_indices !< masked indices within given bounds
3630
3631	LOGICAL, INTENT(OUT) :: mask_in_bounds !< true if any masked indices lie within given bounds
3632
3633	TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< dimensions to be searched for masked indices
3634
3635
3636	mask_in_bounds = .TRUE.
3637	ALLOCATE( masked_indices(SIZE( dimensions ),0:MAXVAL( dimensions(:)%length - 1 )) )
3638	masked_indices = -HUGE( 0_iwp )
3639
3640	!-- Check for masking and update lower and upper bounds if masked
3641	DO d = 1, SIZE( dimensions )
3642
3643	IF ( dimensions(d)%is_masked ) THEN
3644
3645	bounds_masked_end(d) = HUGE( 0_iwp )
3646	bounds_masked_start(d) = -HUGE( 0_iwp )
3647
3648	!-- Find number of masked values within given variable bounds
3649	j = 0
3650	DO i = LBOUND( dimensions(d)%masked_indices, DIM=1 ), &
3651	UBOUND( dimensions(d)%masked_indices, DIM=1 )
3652
3653	!-- Is masked position within given bounds?
3654	IF ( dimensions(d)%masked_indices(i) >= bounds_start(d) .AND. &
3655	dimensions(d)%masked_indices(i) <= bounds_end(d) ) THEN
3656
3657	!-- Save masked position
3658	masked_indices(d,i) = dimensions(d)%masked_indices(i)
3659	j = j + 1
3660
3661	!-- Save bounds of mask within given bounds
3662	IF ( bounds_masked_start(d) == -HUGE( 0_iwp ) ) bounds_masked_start(d) = i
3663	bounds_masked_end(d) = i
3664
3665	ENDIF
3666
3667	ENDDO
3668
3669	!-- Set masked bounds to zero if no masked data lies within bounds
3670	IF ( j == 0 ) THEN
3671	bounds_masked_start(:) = 0_iwp
3672	bounds_masked_end(:) = 0_iwp
3673	mask_in_bounds = .FALSE.
3674	EXIT
3675	ENDIF
3676
3677	ELSE
3678
3679	!-- If dimension is not masked, tread all data within bounds as masked
3680	bounds_masked_start(d) = bounds_start(d)
3681	bounds_masked_end(d) = bounds_end(d)
3682	DO i = bounds_masked_start(d), bounds_masked_end(d)
3683	masked_indices(d,i) = i
3684	ENDDO
3685
3686	ENDIF
3687
3688	ENDDO
3689
3690	END SUBROUTINE get_masked_indices_and_masked_dimension_bounds
3691
3692	!--------------------------------------------------------------------------------------------------!
3693	! Description:
3694	! ------------
3695	!> Finalize output.
3696	!--------------------------------------------------------------------------------------------------!
3697	FUNCTION dom_finalize_output() RESULT( return_value )
3698
3699	CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_finalize_output' !< name of routine
3700
3701	INTEGER(iwp) :: return_value !< return value
3702	INTEGER(iwp) :: return_value_internal !< error code after closing a single file
3703	INTEGER(iwp) :: output_return_value !< return value from called routines
3704	INTEGER(iwp) :: f !< loop index
3705
3706
3707	return_value = 0
3708
3709	DO f = 1, nf
3710
3711	IF ( files(f)%is_init ) THEN
3712
3713	output_return_value = 0
3714	return_value_internal = 0
3715
3716	SELECT CASE ( TRIM( files(f)%format ) )
3717
3718	CASE ( 'binary' )
3719	CALL binary_finalize( files(f)%id, output_return_value )
3720
3721	CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
3722	CALL netcdf4_finalize( files(f)%id, output_return_value )
3723
3724	CASE DEFAULT
3725	return_value_internal = 1
3726
3727	END SELECT
3728
3729	IF ( output_return_value /= 0 ) THEN
3730	return_value = output_return_value
3731	CALL internal_message( 'error', routine_name // &
3732	': error while finalizing file "' // &
3733	TRIM( files(f)%name ) // '"' )
3734	ELSEIF ( return_value_internal /= 0 ) THEN
3735	return_value = return_value_internal
3736	CALL internal_message( 'error', routine_name // &
3737	': unsupported file format "' // &
3738	TRIM( files(f)%format ) // '"' )
3739	ENDIF
3740
3741	ENDIF
3742
3743	ENDDO
3744
3745	END FUNCTION dom_finalize_output
3746
3747	!--------------------------------------------------------------------------------------------------!
3748	! Description:
3749	! ------------
3750	!> Message routine writing debug information into the debug file
3751	!> or creating the error message string.
3752	!--------------------------------------------------------------------------------------------------!
3753	SUBROUTINE internal_message( level, string )
3754
3755	CHARACTER(LEN=*), INTENT(IN) :: level !< message importance level
3756	CHARACTER(LEN=*), INTENT(IN) :: string !< message string
3757
3758
3759	IF ( TRIM( level ) == 'error' ) THEN
3760
3761	WRITE( internal_error_message, '(A,A)' ) 'DOM ERROR: ', string
3762
3763	ELSEIF ( TRIM( level ) == 'debug' .AND. print_debug_output ) THEN
3764
3765	WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
3766	FLUSH( debug_output_unit )
3767
3768	ENDIF
3769
3770	END SUBROUTINE internal_message
3771
3772	!--------------------------------------------------------------------------------------------------!
3773	! Description:
3774	! ------------
3775	!> Return the last created error message.
3776	!--------------------------------------------------------------------------------------------------!
3777	SUBROUTINE dom_get_error_message( error_message )
3778
3779	CHARACTER(LEN=800), INTENT(OUT) :: error_message !< return error message to main program
3780	CHARACTER(LEN=800) :: output_error_message !< error message created by other module
3781
3782
3783	CALL binary_get_error_message( output_error_message )
3784	internal_error_message = TRIM( internal_error_message ) // output_error_message
3785
3786	CALL netcdf4_get_error_message( output_error_message )
3787	internal_error_message = TRIM( internal_error_message ) // output_error_message
3788
3789	error_message = internal_error_message
3790
3791	END SUBROUTINE dom_get_error_message
3792
3793	END MODULE data_output_module

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |