Home

Context Navigation

data_output_module.f90 @ 4851

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

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

Context Navigation

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

Download in other formats: