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

Last change on this file since 4420 was 4408, checked in by gronemeier, 4 years ago

write fill_value attribute in virtual-measurements module; enable character-array output in data-output module

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