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

Last change on this file since 4652 was 4597, checked in by gronemeier, 4 years ago

Summary:

bugfix: - write unlimited dimension in netcdf4-parallel mode

  • prevent unused-variable warning if preprocessor directives are not given

new : - added optional argument to dom_def_dim to allow that dimension variables can be written

by every PE

change: - set parallel access mode to independent per default (netCDF4 output files)

Details:

data_output_module.f90:

bugfix: - write unlimited dimension in netcdf4-parallel mode
new : - added optional argument to dom_def_dim to allow that dimension variables can be written

by every PE

data_output_netcdf4_module.f90:

bugfix: - allow writing of unlimited dimensions in parallel mode

  • prevent unused-variable warning if preprocessor directives are not given

change: - set parallel access mode to independent per default
new : - dimension variables can be written by every PE

data_output_binary_module.f90:

change: update argument list of routine binary_init_dimension due to changes in interface

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