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

Last change on this file since 4577 was 4577, checked in by raasch, 4 years ago

further re-formatting to follow the PALM coding standard

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