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

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

corrected indentation according to coding standard

  • Property svn:keywords set to Id
File size: 191.4 KB
RevLine 
[4070]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! ------------------
[4106]22!
23!
[4070]24! Former revisions:
25! -----------------
26! $Id: data_output_module.f90 4147 2019-08-07 09:42:31Z gronemeier $
[4147]27! corrected indentation according to coding standard
28!
29! 4141 2019-08-05 12:24:51Z gronemeier
[4070]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!>
[4141]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'.
[4070]61!>
62!> @todo Convert variable if type of given values do not fit specified type.
63!--------------------------------------------------------------------------------------------------!
[4147]64 MODULE data_output_module
[4070]65
[4147]66    USE kinds
[4070]67
[4147]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
[4070]78
[4147]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
[4070]89
[4147]90    IMPLICIT NONE
[4070]91
[4147]92    INTEGER, PARAMETER ::  charlen = 100  !< maximum length of character variables
93    INTEGER, PARAMETER ::  no_id = -1     !< default ID if no ID was assigned
[4070]94
[4147]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
[4070]105
[4147]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
[4070]115
[4147]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
[4070]143
[4147]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
[4070]153
154
[4147]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
[4070]158
[4147]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
[4070]163
[4147]164    LOGICAL ::  print_debug_output = .FALSE.  !< if true, debug output is printed
[4070]165
[4147]166    TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  files  !< file list
[4070]167
[4147]168    SAVE
[4070]169
[4147]170    PRIVATE
[4070]171
[4147]172    !> Initialize the data-output module
173    INTERFACE dom_init
174       MODULE PROCEDURE dom_init
175    END INTERFACE dom_init
[4070]176
[4147]177    !> Add files to database
178    INTERFACE dom_def_file
179       MODULE PROCEDURE dom_def_file
180    END INTERFACE dom_def_file
[4070]181
[4147]182    !> Add dimensions to database
183    INTERFACE dom_def_dim
184       MODULE PROCEDURE dom_def_dim
185    END INTERFACE dom_def_dim
[4070]186
[4147]187    !> Add variables to database
188    INTERFACE dom_def_var
189       MODULE PROCEDURE dom_def_var
190    END INTERFACE dom_def_var
[4070]191
[4147]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
[4070]201
[4147]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
[4070]206
[4147]207    !> Write variables to file
208    INTERFACE dom_write_var
209       MODULE PROCEDURE dom_write_var
210    END INTERFACE dom_write_var
[4070]211
[4147]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
[4070]216
[4147]217    !> Return error message
218    INTERFACE dom_get_error_message
219       MODULE PROCEDURE dom_get_error_message
220    END INTERFACE dom_get_error_message
[4070]221
[4147]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
[4141]226
[4147]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
[4070]238
[4147]239 CONTAINS
[4070]240
241
242!--------------------------------------------------------------------------------------------------!
243! Description:
244! ------------
[4141]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.
[4070]251!--------------------------------------------------------------------------------------------------!
[4147]252 SUBROUTINE dom_init( file_suffix_of_output_group, mpi_comm_of_output_group, master_output_rank, &
253                      program_debug_output_unit, debug_output )
[4070]254
[4147]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
[4070]257
[4147]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
[4107]263
[4147]264    LOGICAL, INTENT(IN)           ::  debug_output               !< if true, debug output is printed
[4070]265
266
[4147]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
[4107]269
[4147]270    output_group_comm = mpi_comm_of_output_group
[4107]271
[4147]272    debug_output_unit = program_debug_output_unit
273    print_debug_output = debug_output
[4070]274
[4147]275    CALL binary_init_module( output_file_suffix, output_group_comm, master_rank, &
276                             debug_output_unit, debug_output, no_id )
[4070]277
[4147]278    CALL netcdf4_init_module( output_file_suffix, output_group_comm, master_rank, &
279                             debug_output_unit, debug_output, no_id )
[4070]280
[4147]281 END SUBROUTINE dom_init
[4070]282
283!--------------------------------------------------------------------------------------------------!
284! Description:
285! ------------
286!> Define output file.
[4141]287!> Example call:
288!>   status = dom_def_file( 'my_output_file_name', 'binary' )
[4070]289!--------------------------------------------------------------------------------------------------!
[4147]290 FUNCTION dom_def_file( file_name, file_format ) RESULT( return_value )
[4070]291
[4147]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
[4070]294
[4147]295    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_file'  !< name of this routine
[4070]296
[4147]297    INTEGER ::  f             !< loop index
298    INTEGER ::  return_value  !< return value
[4070]299
[4147]300    TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  files_tmp  !< temporary file list
[4070]301
302
[4147]303    return_value = 0
[4070]304
[4147]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
[4116]309
[4147]310       nfiles = 1
311       ALLOCATE( files(nfiles) )
[4070]312
[4147]313    ELSE
[4070]314
[4147]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
[4070]337
[4147]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
[4070]345
[4147]346 END FUNCTION dom_def_file
[4070]347
348!--------------------------------------------------------------------------------------------------!
349! Description:
350! ------------
[4141]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/) )
[4070]373!>
374!> @todo Convert given values into selected output_type.
375!--------------------------------------------------------------------------------------------------!
[4147]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 )
[4070]380
[4147]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
[4070]384
[4147]385    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_dim'  !< name of this routine
[4070]386
[4147]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
[4070]393
[4147]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
[4070]399
[4147]400    LOGICAL,         DIMENSION(:), INTENT(IN), OPTIONAL ::  mask           !< mask of dimesion
[4070]401
[4147]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
[4070]405
[4147]406    TYPE(dimension_type)                            ::  dimension       !< new dimension
407    TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  dimensions_tmp  !< temporary dimension list
[4070]408
409
[4147]410    return_value = 0
[4070]411
[4147]412    CALL internal_message( 'debug', routine_name //                    &
413                           ': define dimension ' //                    &
414                           '(dimension "' // TRIM( dimension_name ) // &
415                           '", file "' // TRIM( file_name ) // '")' )
[4116]416
[4147]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
[4070]428
[4147]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
[4070]436
[4147]437    ELSEIF ( SIZE( bounds ) == 2 )  THEN
[4070]438
[4147]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
[4070]513
[4147]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
[4070]524
[4147]525          IF ( dimension%length == SIZE( mask ) )  THEN
[4070]526
[4147]527             IF ( ALL( mask ) )  THEN
[4070]528
[4147]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 ) // '")!' )
[4070]533
[4147]534             ELSE
[4070]535
[4147]536                dimension%is_masked = .TRUE.
537                dimension%length_mask = COUNT( mask )
[4070]538
[4147]539                ALLOCATE( dimension%mask(dimension%bounds(1):dimension%bounds(2)) )
540                ALLOCATE( dimension%masked_indices(0:dimension%length_mask-1) )
[4070]541
[4147]542                dimension%mask = mask
543!
544!--             Save masked positions and masked values
545                IF ( ALLOCATED( dimension%values_int8 ) )  THEN
[4070]546
[4147]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
[4070]556
[4147]557                ELSEIF ( ALLOCATED( dimension%values_int16 ) )  THEN
[4070]558
[4147]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
[4070]568
[4147]569                ELSEIF ( ALLOCATED( dimension%values_int32 ) )  THEN
[4070]570
[4147]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
[4070]580
[4147]581                ELSEIF ( ALLOCATED( dimension%values_intwp ) )  THEN
[4070]582
[4147]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
[4070]592
[4147]593                ELSEIF ( ALLOCATED( dimension%values_real32 ) )  THEN
[4070]594
[4147]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
[4070]604
[4147]605                ELSEIF ( ALLOCATED(dimension%values_real64) )  THEN
[4070]606
[4147]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
[4070]616
[4147]617                ELSEIF ( ALLOCATED(dimension%values_realwp) )  THEN
[4070]618
[4147]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
[4070]628
[4147]629                ENDIF
[4070]630
[4147]631             ENDIF  ! if not all mask = true
[4070]632
[4147]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
[4070]640
[4147]641       ENDIF
[4141]642
[4147]643    ELSE
[4141]644
[4147]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 ) // '")!' )
[4141]650
[4147]651    ENDIF
652!
653!-- Add dimension to database
654    IF ( return_value == 0 )  THEN
[4141]655
[4147]656       DO  f = 1, nfiles
[4070]657
[4147]658          IF ( TRIM( file_name ) == files(f)%name )  THEN
[4070]659
[4147]660             IF ( files(f)%is_init )  THEN
[4070]661
[4147]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
[4070]669
[4147]670             ELSEIF ( .NOT. ALLOCATED( files(f)%dimensions ) )  THEN
[4070]671
[4147]672                ndims = 1
673                ALLOCATE( files(f)%dimensions(ndims) )
[4070]674
[4147]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
[4070]691
[4147]692                IF ( return_value == 0 )  THEN
693!
694!--                Check if dimension already exists in file
695                   ndims = SIZE( files(f)%dimensions )
[4070]696
[4147]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
[4070]719
[4147]720             ENDIF
721!
722!--          Add new dimension to database
723             IF ( return_value == 0 )  files(f)%dimensions(ndims) = dimension
[4106]724
[4147]725             EXIT
[4106]726
[4147]727          ENDIF
728       ENDDO
[4070]729
[4147]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
[4070]736
[4147]737    ENDIF
[4070]738
[4147]739 END FUNCTION dom_def_dim
[4106]740
[4070]741!--------------------------------------------------------------------------------------------------!
742! Description:
743! ------------
744!> Add variable to database.
[4141]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.
[4123]748!> Example call:
[4141]749!>   dom_def_var( file_name =  'my_output_file_name', &
750!>                variable_name = 'u', &
[4123]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>) )
[4070]765!--------------------------------------------------------------------------------------------------!
[4147]766 FUNCTION dom_def_var( file_name, variable_name, dimension_names, output_type, is_global ) &
767             RESULT( return_value )
[4070]768
[4147]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
[4070]772
[4147]773    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_var'  !< name of this routine
[4070]774
[4147]775    CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) ::  dimension_names  !< list of dimension names
[4070]776
[4147]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
[4070]782
[4147]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)
[4070]785
[4147]786    TYPE(variable_type)                            ::  variable       !< new variable
787    TYPE(variable_type), DIMENSION(:), ALLOCATABLE ::  variables_tmp  !< temporary variable list
[4070]788
789
[4147]790    return_value = 0
791    found = .FALSE.
[4070]792
[4147]793    CALL internal_message( 'debug', routine_name //                                     &
794                           ': define variable (variable "' // TRIM( variable_name ) //  &
795                           '", file "' // TRIM( file_name ) // '")' )
[4116]796
[4147]797    variable%name = TRIM( variable_name )
[4070]798
[4147]799    ALLOCATE( variable%dimension_names(SIZE( dimension_names )) )
800    ALLOCATE( variable%dimension_ids(SIZE( dimension_names )) )
[4070]801
[4147]802    variable%dimension_names = dimension_names
803    variable%dimension_ids = -1
804    variable%data_type = TRIM( output_type )
[4070]805
[4147]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
[4070]814
[4147]815       IF ( TRIM( file_name ) == files(f)%name )  THEN
[4070]816
[4147]817          IF ( files(f)%is_init )  THEN
[4070]818
[4147]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
[4070]825
[4147]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
[4106]862
[4147]863          ELSE
[4106]864
[4147]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 ) // '")!' )
[4070]870
[4147]871          ENDIF
[4106]872
[4147]873          IF ( return_value == 0 )  THEN
874!
875!--          Check if variable already exists
876             IF ( .NOT. ALLOCATED( files(f)%variables ) )  THEN
[4070]877
[4147]878                nvars = 1
879                ALLOCATE( files(f)%variables(nvars) )
[4070]880
[4147]881             ELSE
[4070]882
[4147]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
[4070]894
[4147]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
[4070]906
[4147]907             ENDIF
908!
909!--          Add new variable to database
910             IF ( return_value == 0 )  files(f)%variables(nvars) = variable
[4070]911
[4147]912          ENDIF
[4070]913
[4147]914          EXIT
[4070]915
[4147]916       ENDIF
[4070]917
[4147]918    ENDDO
[4070]919
[4147]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
[4070]926
[4147]927 END FUNCTION dom_def_var
[4070]928
929!--------------------------------------------------------------------------------------------------!
930! Description:
931! ------------
932!> Create attribute with value of type character.
[4141]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. )
[4070]953!--------------------------------------------------------------------------------------------------!
[4147]954 FUNCTION dom_def_att_char( file_name, variable_name, attribute_name, value, append ) &
955             RESULT( return_value )
[4070]956
[4147]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
[4070]962
[4147]963    ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_char'  !< name of routine
[4070]964
[4147]965    INTEGER ::  return_value  !< return value
[4070]966
[4147]967    LOGICAL                       ::  append_internal  !< same as 'append'
968    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
[4070]969
[4147]970    TYPE(attribute_type) ::  attribute  !< new attribute
[4070]971
972
[4147]973    return_value = 0
[4070]974
[4147]975    IF ( PRESENT( append ) )  THEN
976       append_internal = append
977    ELSE
978       append_internal = .FALSE.
979    ENDIF
[4070]980
[4147]981    attribute%name       = TRIM( attribute_name )
982    attribute%data_type  = 'char'
983    attribute%value_char = TRIM( value )
[4070]984
[4147]985    IF ( PRESENT( variable_name ) )  THEN
986       variable_name_internal = TRIM( variable_name )
987    ELSE
988       variable_name_internal = ''
989    ENDIF
[4070]990
[4147]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 )
[4141]994
[4147]995 END FUNCTION dom_def_att_char
[4070]996
997!--------------------------------------------------------------------------------------------------!
998! Description:
999! ------------
1000!> Create attribute with value of type int8.
[4141]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 )
[4070]1015!--------------------------------------------------------------------------------------------------!
[4147]1016 FUNCTION dom_def_att_int8( file_name, variable_name, attribute_name, value, append ) &
1017             RESULT( return_value )
[4070]1018
[4147]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
[4070]1023
[4147]1024    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int8'  !< name of routine
[4070]1025
[4147]1026    INTEGER(KIND=1), INTENT(IN) ::  value  !< attribute value
[4070]1027
[4147]1028    INTEGER ::  return_value  !< return value
[4070]1029
[4147]1030    LOGICAL                       ::  append_internal  !< same as 'append'
1031    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
[4070]1032
[4147]1033    TYPE(attribute_type) ::  attribute  !< new attribute
[4070]1034
1035
[4147]1036    return_value = 0
[4070]1037
[4147]1038    IF ( PRESENT( variable_name ) )  THEN
1039       variable_name_internal = TRIM( variable_name )
1040    ELSE
1041       variable_name_internal = ''
1042    ENDIF
[4141]1043
[4147]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
[4070]1054
[4147]1055    IF ( return_value == 0 )  THEN
1056       append_internal = .FALSE.
[4070]1057
[4147]1058       attribute%name       = TRIM( attribute_name )
1059       attribute%data_type  = 'int8'
1060       attribute%value_int8 = value
[4070]1061
[4147]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
[4070]1066
[4147]1067 END FUNCTION dom_def_att_int8
[4070]1068
1069!--------------------------------------------------------------------------------------------------!
1070! Description:
1071! ------------
1072!> Create attribute with value of type int16.
[4141]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 )
[4070]1087!--------------------------------------------------------------------------------------------------!
[4147]1088 FUNCTION dom_def_att_int16( file_name, variable_name, attribute_name, value, append ) &
1089             RESULT( return_value )
[4070]1090
[4147]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
[4070]1095
[4147]1096    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int16'  !< name of routine
[4070]1097
[4147]1098    INTEGER(KIND=2), INTENT(IN) ::  value  !< attribute value
[4070]1099
[4147]1100    INTEGER ::  return_value  !< return value
[4070]1101
[4147]1102    LOGICAL                       ::  append_internal  !< same as 'append'
1103    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
[4070]1104
[4147]1105    TYPE(attribute_type) ::  attribute  !< new attribute
[4070]1106
1107
[4147]1108    return_value = 0
[4070]1109
[4147]1110    IF ( PRESENT( variable_name ) )  THEN
1111       variable_name_internal = TRIM( variable_name )
1112    ELSE
1113       variable_name_internal = ''
1114    ENDIF
[4141]1115
[4147]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
[4070]1126
[4147]1127    IF ( return_value == 0 )  THEN
1128       append_internal = .FALSE.
[4070]1129
[4147]1130       attribute%name        = TRIM( attribute_name )
1131       attribute%data_type   = 'int16'
1132       attribute%value_int16 = value
[4070]1133
[4147]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
[4070]1138
[4147]1139 END FUNCTION dom_def_att_int16
[4070]1140
1141!--------------------------------------------------------------------------------------------------!
1142! Description:
1143! ------------
1144!> Create attribute with value of type int32.
[4141]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 )
[4070]1159!--------------------------------------------------------------------------------------------------!
[4147]1160 FUNCTION dom_def_att_int32( file_name, variable_name, attribute_name, value, append ) &
1161             RESULT( return_value )
[4070]1162
[4147]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
[4070]1167
[4147]1168    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int32'  !< name of routine
[4070]1169
[4147]1170    INTEGER(KIND=4), INTENT(IN) ::  value  !< attribute value
[4070]1171
[4147]1172    INTEGER ::  return_value  !< return value
[4070]1173
[4147]1174    LOGICAL                       ::  append_internal  !< same as 'append'
1175    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
[4070]1176
[4147]1177    TYPE(attribute_type) ::  attribute  !< new attribute
[4070]1178
1179
[4147]1180    return_value = 0
[4070]1181
[4147]1182    IF ( PRESENT( variable_name ) )  THEN
1183       variable_name_internal = TRIM( variable_name )
1184    ELSE
1185       variable_name_internal = ''
1186    ENDIF
[4141]1187
[4147]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
[4070]1198
[4147]1199    IF ( return_value == 0 )  THEN
1200       append_internal = .FALSE.
[4070]1201
[4147]1202       attribute%name        = TRIM( attribute_name )
1203       attribute%data_type   = 'int32'
1204       attribute%value_int32 = value
[4070]1205
[4147]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
[4070]1210
[4147]1211 END FUNCTION dom_def_att_int32
[4070]1212
1213!--------------------------------------------------------------------------------------------------!
1214! Description:
1215! ------------
1216!> Create attribute with value of type real32.
[4141]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 )
[4070]1231!--------------------------------------------------------------------------------------------------!
[4147]1232 FUNCTION dom_def_att_real32( file_name, variable_name, attribute_name, value, append ) &
1233             RESULT( return_value )
[4070]1234
[4147]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
[4070]1239
[4147]1240    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_real32'  !< name of routine
[4070]1241
[4147]1242    INTEGER ::  return_value  !< return value
[4070]1243
[4147]1244    LOGICAL                       ::  append_internal  !< same as 'append'
1245    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
[4070]1246
[4147]1247    REAL(KIND=4), INTENT(IN) ::  value  !< attribute value
[4070]1248
[4147]1249    TYPE(attribute_type) ::  attribute  !< new attribute
[4070]1250
1251
[4147]1252    return_value = 0
[4070]1253
[4147]1254    IF ( PRESENT( variable_name ) )  THEN
1255       variable_name_internal = TRIM( variable_name )
1256    ELSE
1257       variable_name_internal = ''
1258    ENDIF
[4141]1259
[4147]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
[4070]1270
[4147]1271    IF ( return_value == 0 )  THEN
1272       append_internal = .FALSE.
[4070]1273
[4147]1274       attribute%name         = TRIM( attribute_name )
1275       attribute%data_type    = 'real32'
1276       attribute%value_real32 = value
[4070]1277
[4147]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
[4070]1282
[4147]1283 END FUNCTION dom_def_att_real32
[4070]1284
1285!--------------------------------------------------------------------------------------------------!
1286! Description:
1287! ------------
1288!> Create attribute with value of type real64.
[4141]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 )
[4070]1303!--------------------------------------------------------------------------------------------------!
[4147]1304 FUNCTION dom_def_att_real64( file_name, variable_name, attribute_name, value, append ) &
1305             RESULT( return_value )
[4070]1306
[4147]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
[4070]1311
[4147]1312    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_real64'  !< name of routine
[4070]1313
[4147]1314    INTEGER ::  return_value  !< return value
[4070]1315
[4147]1316    LOGICAL                       ::  append_internal  !< same as 'append'
1317    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
[4070]1318
[4147]1319    REAL(KIND=8), INTENT(IN) ::  value  !< attribute value
[4070]1320
[4147]1321    TYPE(attribute_type) ::  attribute  !< new attribute
[4070]1322
1323
[4147]1324    return_value = 0
[4070]1325
[4147]1326    IF ( PRESENT( variable_name ) )  THEN
1327       variable_name_internal = TRIM( variable_name )
1328    ELSE
1329       variable_name_internal = ''
1330    ENDIF
[4141]1331
[4147]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
[4070]1342
[4147]1343    IF ( return_value == 0 )  THEN
1344       append_internal = .FALSE.
[4070]1345
[4147]1346       attribute%name         = TRIM( attribute_name )
1347       attribute%data_type    = 'real64'
1348       attribute%value_real64 = value
[4070]1349
[4147]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
[4141]1354
[4147]1355 END FUNCTION dom_def_att_real64
[4141]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!--------------------------------------------------------------------------------------------------!
[4147]1365 FUNCTION dom_def_end() RESULT( return_value )
[4141]1366
[4147]1367    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_end'  !< name of routine
[4141]1368
[4147]1369    INTEGER ::  d             !< loop index
1370    INTEGER ::  f             !< loop index
1371    INTEGER ::  return_value  !< return value
[4141]1372
[4147]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
[4141]1377
[4147]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
[4141]1382
[4147]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
[4141]1386
[4147]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
[4141]1390
1391
[4147]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()
[4141]1397
[4147]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
[4141]1403
[4147]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 )
[4141]1420
[4147]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): &
[4141]1430                                         files(f)%dimensions(d)%bounds(2)) )
[4147]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): &
[4141]1440                                          files(f)%dimensions(d)%bounds(2)) )
[4147]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): &
[4141]1450                                          files(f)%dimensions(d)%bounds(2)) )
[4147]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): &
[4141]1460                                          files(f)%dimensions(d)%bounds(2)) )
[4147]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
[4141]1501
[4147]1502          ENDIF
[4141]1503
[4147]1504          IF ( return_value /= 0 )  EXIT
[4141]1505
[4147]1506       ENDDO
1507    ENDIF
[4141]1508
[4147]1509    CALL internal_message( 'debug', routine_name // ': finished' )
[4141]1510
[4147]1511 END FUNCTION dom_def_end
[4141]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!--------------------------------------------------------------------------------------------------!
[4147]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 )
[4141]1543
[4147]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
[4141]1547
[4147]1548    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_write_var'  !< name of routine
[4141]1549
[4147]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
[4141]1557
[4147]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
[4141]1564
[4147]1565    LOGICAL ::  do_output  !< true if any data lies within given range of masked dimension
1566    LOGICAL ::  is_global  !< true if variable is global
[4141]1567
[4147]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
[4141]1584
[4147]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
[4141]1597
[4147]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
[4141]1614
[4147]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
[4141]1627
[4147]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
[4141]1637
[4147]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
[4141]1650
[4147]1651    TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  dimension_list  !< list of used dimensions of variable
[4141]1652
1653
[4147]1654    return_value = 0
1655    output_return_value = 0
[4141]1656
[4147]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  )
[4141]1663
[4147]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
[4141]1676
[4147]1677    ENDIF
[4141]1678
[4147]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 )) )
[4141]1685
[4147]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 )
[4141]1701
[4147]1702       do_output = .NOT. ANY( value_counts == 0 )
[4141]1703
[4147]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, &
[4141]1736                                               0:value_counts(2)-1) )
[4147]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, &
[4141]1754                                               0:value_counts(2)-1, &
1755                                               0:value_counts(3)-1) )
[4147]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, &
[4141]1794                                                0:value_counts(2)-1) )
[4147]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, &
[4141]1812                                                0:value_counts(2)-1, &
1813                                                0:value_counts(3)-1) )
[4147]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, &
[4141]1852                                                0:value_counts(2)-1) )
[4147]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, &
[4141]1870                                                0:value_counts(2)-1, &
1871                                                0:value_counts(3)-1) )
[4147]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, &
[4141]1910                                                0:value_counts(2)-1) )
[4147]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, &
[4141]1928                                                0:value_counts(2)-1, &
1929                                                0:value_counts(3)-1) )
[4147]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
[4141]2121
[4147]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
[4141]2129
[4147]2130       DEALLOCATE( masked_indices )
[4141]2131
[4147]2132    ENDIF  ! Check for error
[4141]2133
[4147]2134    IF ( return_value == 0 )  THEN
2135!
2136!--    Write variable into file
2137       SELECT CASE ( TRIM( file_format ) )
[4141]2138
[4147]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
[4141]2274
[4147]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
[4141]2410
[4147]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 ) // '")!' )
[4141]2418
[4147]2419       END SELECT
[4141]2420
[4147]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
[4141]2428
[4147]2429    ENDIF
[4141]2430
[4147]2431 END FUNCTION dom_write_var
[4070]2432
2433!--------------------------------------------------------------------------------------------------!
2434! Description:
2435! ------------
[4141]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!--------------------------------------------------------------------------------------------------!
[4147]2442 FUNCTION dom_finalize_output() RESULT( return_value )
[4141]2443
[4147]2444    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_finalize_output'  !< name of routine
[4141]2445
[4147]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
[4141]2450
2451
[4147]2452    return_value = 0
[4141]2453
[4147]2454    DO  f = 1, nfiles
[4141]2455
[4147]2456       IF ( files(f)%is_init )  THEN
[4141]2457
[4147]2458          output_return_value = 0
2459          return_value_internal = 0
[4141]2460
[4147]2461          SELECT CASE ( TRIM( files(f)%format ) )
[4141]2462
[4147]2463             CASE ( 'binary' )
2464                CALL binary_finalize( files(f)%id, output_return_value )
[4141]2465
[4147]2466             CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
2467                CALL netcdf4_finalize( files(f)%id, output_return_value )
[4141]2468
[4147]2469             CASE DEFAULT
2470                return_value_internal = 1
[4141]2471
[4147]2472          END SELECT
[4141]2473
[4147]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
[4141]2486
[4147]2487       ENDIF
[4141]2488
[4147]2489    ENDDO
[4141]2490
[4147]2491 END FUNCTION dom_finalize_output
[4141]2492
2493!--------------------------------------------------------------------------------------------------!
2494! Description:
2495! ------------
2496!> Return the last created error message.
2497!--------------------------------------------------------------------------------------------------!
[4147]2498 FUNCTION dom_get_error_message() RESULT( error_message )
[4141]2499
[4147]2500    CHARACTER(LEN=800) ::  error_message  !< return error message to main program
[4141]2501
2502
[4147]2503    error_message = TRIM( internal_error_message )
[4141]2504
[4147]2505    error_message = TRIM( error_message ) // TRIM( binary_get_error_message() )
[4141]2506
[4147]2507    error_message = TRIM( error_message ) // TRIM( netcdf4_get_error_message() )
[4141]2508
[4147]2509    internal_error_message = ''
2510
2511 END FUNCTION dom_get_error_message
2512
[4141]2513!--------------------------------------------------------------------------------------------------!
2514! Description:
2515! ------------
[4070]2516!> Add attribute to database.
2517!>
2518!> @todo Try to combine similar code parts and shorten routine.
2519!--------------------------------------------------------------------------------------------------!
[4147]2520 FUNCTION save_attribute_in_database( file_name, variable_name, attribute, append ) &
2521             RESULT( return_value )
[4070]2522
[4147]2523    CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< name of file
2524    CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
[4070]2525
[4147]2526    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'save_attribute_in_database'  !< name of routine
[4070]2527
[4147]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
[4070]2533
[4147]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
[4070]2536
[4147]2537    TYPE(attribute_type), INTENT(IN) ::  attribute  !< new attribute
[4070]2538
[4147]2539    TYPE(attribute_type), DIMENSION(:), ALLOCATABLE ::  atts_tmp  !< temporary attribute list
[4070]2540
2541
[4147]2542    return_value = 0
2543    found = .FALSE.
[4070]2544
[4147]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 ) // '"' )
[4116]2549
[4147]2550    DO  f = 1, nfiles
[4070]2551
[4147]2552       IF ( TRIM( file_name ) == files(f)%name )  THEN
[4070]2553
[4147]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
[4106]2605
[4147]2606             EXIT
[4070]2607
[4147]2608          ELSE
2609!
2610!--          Add attribute to dimension
2611             IF ( ALLOCATED( files(f)%dimensions ) )  THEN
[4070]2612
[4147]2613                DO  d = 1, SIZE( files(f)%dimensions )
[4070]2614
[4147]2615                   IF ( files(f)%dimensions(d)%name == TRIM( variable_name ) )  THEN
[4070]2616
[4147]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
[4070]2662
[4147]2663                      EXIT
[4070]2664
[4147]2665                   ENDIF  ! dimension found
[4070]2666
[4147]2667                ENDDO  ! loop over dimensions
[4070]2668
[4147]2669             ENDIF  ! dimensions exist in file
2670!
2671!--          Add attribute to variable
2672             IF ( .NOT. found  .AND.  ALLOCATED( files(f)%variables) )  THEN
[4070]2673
[4147]2674                DO  d = 1, SIZE( files(f)%variables )
[4070]2675
[4147]2676                   IF ( files(f)%variables(d)%name == TRIM( variable_name ) )  THEN
[4070]2677
[4147]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
[4070]2716
[4147]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
[4070]2724
[4147]2725                      EXIT
[4070]2726
[4147]2727                   ENDIF  ! variable found
[4070]2728
[4147]2729                ENDDO  ! loop over variables
[4070]2730
[4147]2731             ENDIF  ! variables exist in file
[4070]2732
[4147]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
[4070]2741
[4147]2742             EXIT
[4070]2743
[4147]2744          ENDIF  ! variable_name not empty
[4070]2745
[4147]2746       ENDIF  ! check file_name
[4070]2747
[4147]2748    ENDDO  ! loop over files
[4070]2749
[4147]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
[4070]2758
[4147]2759 END FUNCTION save_attribute_in_database
[4070]2760
2761!--------------------------------------------------------------------------------------------------!
2762! Description:
2763! ------------
2764!> Check database and delete any unused dimensions and empty files (i.e. files
2765!> without variables).
2766!--------------------------------------------------------------------------------------------------!
[4147]2767 FUNCTION cleanup_database() RESULT( return_value )
[4070]2768
[4147]2769    ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'cleanup_database'  !< name of routine
[4070]2770
[4147]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
[4070]2779
[4147]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
[4070]2782
[4147]2783    TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  used_dimensions  !< list of used dimensions
[4070]2784
[4147]2785    TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  used_files  !< list of used files
[4070]2786
2787
[4147]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 )
[4070]2854
[4147]2855    ENDDO
[4070]2856
[4147]2857 END FUNCTION cleanup_database
[4070]2858
2859!--------------------------------------------------------------------------------------------------!
2860! Description:
2861! ------------
2862!> Open requested output file.
2863!--------------------------------------------------------------------------------------------------!
[4147]2864 SUBROUTINE open_output_file( file_format, file_name, file_id, return_value )
[4070]2865
[4147]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
[4070]2868
[4147]2869    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'open_output_file'  !< name of routine
[4070]2870
[4147]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
[4070]2874
2875
[4147]2876    return_value = 0
2877    output_return_value = 0
[4070]2878
[4147]2879    SELECT CASE ( TRIM( file_format ) )
[4070]2880
[4147]2881       CASE ( 'binary' )
2882          CALL binary_open_file( 'binary', file_name, file_id, output_return_value )
[4070]2883
[4147]2884       CASE ( 'netcdf4-serial' )
2885          CALL netcdf4_open_file( 'serial', file_name, file_id, output_return_value )
[4070]2886
[4147]2887       CASE ( 'netcdf4-parallel' )
2888          CALL netcdf4_open_file( 'parallel', file_name, file_id, output_return_value )
[4070]2889
[4147]2890       CASE DEFAULT
2891          return_value = 1
[4070]2892
[4147]2893    END SELECT
[4070]2894
[4147]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
[4070]2905
[4147]2906 END SUBROUTINE open_output_file
[4070]2907
2908!--------------------------------------------------------------------------------------------------!
2909! Description:
2910! ------------
[4141]2911!> Initialize attributes, dimensions and variables in a file.
[4070]2912!--------------------------------------------------------------------------------------------------!
[4147]2913 SUBROUTINE init_file_header( file, return_value )
[4070]2914
[4147]2915    ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'init_file_header'  !< name of routine
[4070]2916
[4147]2917    INTEGER              ::  a             !< loop index
2918    INTEGER              ::  d             !< loop index
2919    INTEGER, INTENT(OUT) ::  return_value  !< return value
[4070]2920
[4147]2921    TYPE(file_type), INTENT(INOUT) ::  file  !< initialize header of this file
[4070]2922
2923
[4147]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
[4070]2935
[4147]2936    IF ( return_value == 0 )  THEN
2937!
2938!--    Initialize file dimensions
2939       DO  d = 1, SIZE( file%dimensions )
[4070]2940
[4147]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 )
[4070]2948
[4147]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 )
[4070]2956
[4147]2957          ENDIF
[4070]2958
[4147]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
[4070]2970
[4147]2971          IF ( return_value /= 0 )  EXIT
[4070]2972
[4147]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 )
[4070]2983
[4147]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 )
[4070]2988
[4147]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
[4070]3000