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

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

corrected indentation according to coding standard

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