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

Last change on this file since 4141 was 4141, checked in by gronemeier, 5 years ago

changes in data-output module (data_output_binary_module, data_output_module, data_output_netcdf4_module, binary_to_netcdf):

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