Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |