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

Last change on this file since 4581 was 4579, checked in by gronemeier, 4 years ago

corrected formatting to follow PALM coding standard (data_output_module, data_output_binary_module, data_output_netcdf4_module)

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