Home

Context Navigation

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

Last change on this file since 4495 was 4481, checked in by maronga, 5 years ago
Bugfix for copyright updates in document_changes; copyright update applied to all files
Property svn:keywords set to `Id`
File size: 198.1 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |