Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |