Home

Context Navigation

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

Last change on this file since 4218 was 4147, checked in by gronemeier, 5 years ago
corrected indentation according to coding standard
Property svn:keywords set to `Id`
File size: 191.4 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |