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

Last change on this file since 4116 was 4116, checked in by gronemeier, 23 months ago

bugfix: check for empty file list in data_ouput_module when starting output

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