Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |