Home

Context Navigation

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

Last change on this file since 4141 was 4141, checked in by gronemeier, 5 years ago

changes in data-output module (data_output_binary_module, data_output_module, data_output_netcdf4_module, binary_to_netcdf):

renaming of variables
changes to formatting and layout
update routine descriptions

Property svn:keywords set to Id

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |