Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |