Home

Context Navigation

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

Last change on this file since 4595 was 4579, checked in by gronemeier, 4 years ago
corrected formatting to follow PALM coding standard (data_output_module, data_output_binary_module, data_output_netcdf4_module)
Property svn:keywords set to `Id`
File size: 209.4 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |