Home

Context Navigation

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

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

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

add support for different output groups of MPI ranks (required for, e.g., nesting runs)
revise output messages

Property svn:keywords set to Id

File size: 158.6 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |