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

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

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

  • renaming of variables
  • changes to formatting and layout
  • update routine descriptions
  • Property svn:keywords set to Id
File size: 189.6 KB
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 4141 2019-08-05 12:24:51Z gronemeier $
27! Initial revision
28!
29!
30! Authors:
31! --------
32!> @author Tobias Gronemeier
33!> @author Helge Knoop
34!
35!--------------------------------------------------------------------------------------------------!
36! Description:
37! ------------
38!> Data-output module to handle output of variables into output files.
39!>
[4141]40!> The module first creates an interal database containing all meta data of all output quantities.
41!> After defining all meta data, the output files are initialized and prepared for writing. When
42!> writing is finished, files can be finalized and closed.
43!> The order of calls are as follows:
44!>   1. Initialize the module via
45!>      'dom_init'
46!>   2. Define output files via (multiple calls of)
47!>      'dom_def_file', 'dom_def_att', 'dom_def_dim', 'dom_def_var'
48!>   3. Leave definition stage via
49!>      'dom_def_end'
50!>   4. Write output data into file via
51!>      'dom_write_var'
52!>   5. Finalize the output via
53!>      'dom_finalize_output'
54!> If any routine exits with a non-zero return value, the error message of the last encountered
55!> error can be fetched via 'dom_get_error_message'.
56!> For debugging purposes, the content of the database can be written to the debug output via
57!> 'dom_database_debug_output'.
[4070]58!>
59!> @todo Convert variable if type of given values do not fit specified type.
60!--------------------------------------------------------------------------------------------------!
61MODULE data_output_module
62
63   USE kinds
64
[4106]65   USE data_output_netcdf4_module, &
66      ONLY: netcdf4_init_dimension, &
67            netcdf4_get_error_message, &
[4141]68            netcdf4_stop_file_header_definition, &
[4106]69            netcdf4_init_module, &
70            netcdf4_init_variable, &
71            netcdf4_finalize, &
72            netcdf4_open_file, &
73            netcdf4_write_attribute, &
74            netcdf4_write_variable
[4070]75
76   USE data_output_binary_module, &
77      ONLY: binary_finalize, &
78            binary_get_error_message, &
79            binary_init_dimension, &
[4141]80            binary_stop_file_header_definition, &
[4070]81            binary_init_module, &
82            binary_init_variable, &
83            binary_open_file, &
84            binary_write_attribute, &
85            binary_write_variable
86
87   IMPLICIT NONE
88
[4141]89   INTEGER, PARAMETER ::  charlen = 100  !< maximum length of character variables
90   INTEGER, PARAMETER ::  no_id = -1     !< default ID if no ID was assigned
[4070]91
92   TYPE attribute_type
93      CHARACTER(LEN=charlen) ::  data_type = ''  !< data type
94      CHARACTER(LEN=charlen) ::  name            !< attribute name
95      CHARACTER(LEN=charlen) ::  value_char      !< attribute value if character
96      INTEGER(KIND=1)        ::  value_int8      !< attribute value if 8bit integer
97      INTEGER(KIND=2)        ::  value_int16     !< attribute value if 16bit integer
98      INTEGER(KIND=4)        ::  value_int32     !< attribute value if 32bit integer
99      REAL(KIND=4)           ::  value_real32    !< attribute value if 32bit real
100      REAL(KIND=8)           ::  value_real64    !< attribute value if 64bit real
101   END TYPE attribute_type
102
103   TYPE variable_type
[4141]104      CHARACTER(LEN=charlen)                            ::  data_type = ''       !< data type
105      CHARACTER(LEN=charlen)                            ::  name                 !< variable name
106      INTEGER                                           ::  id = no_id           !< id within file
107      LOGICAL                                           ::  is_global = .FALSE.  !< true if global variable
108      CHARACTER(LEN=charlen), DIMENSION(:), ALLOCATABLE ::  dimension_names      !< list of dimension names used by variable
109      INTEGER,                DIMENSION(:), ALLOCATABLE ::  dimension_ids        !< list of dimension ids used by variable
110      TYPE(attribute_type),   DIMENSION(:), ALLOCATABLE ::  attributes           !< list of attributes
[4070]111   END TYPE variable_type
112
113   TYPE dimension_type
[4141]114      CHARACTER(LEN=charlen)                     ::  data_type = ''        !< data type
115      CHARACTER(LEN=charlen)                     ::  name                  !< dimension name
116      INTEGER                                    ::  id = no_id            !< dimension id within file
117      INTEGER                                    ::  length                !< length of dimension
118      INTEGER                                    ::  length_mask           !< length of masked dimension
119      INTEGER                                    ::  variable_id = no_id   !< associated variable id within file
120      LOGICAL                                    ::  is_masked = .FALSE.   !< true if masked
121      INTEGER,         DIMENSION(2)              ::  bounds                !< lower and upper bound of dimension
122      INTEGER,         DIMENSION(:), ALLOCATABLE ::  masked_indices        !< list of masked indices of dimension
[4070]123      INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE ::  masked_values_int8    !< masked dimension values if 16bit integer
124      INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE ::  masked_values_int16   !< masked dimension values if 16bit integer
125      INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE ::  masked_values_int32   !< masked dimension values if 32bit integer
[4106]126      INTEGER(iwp),    DIMENSION(:), ALLOCATABLE ::  masked_values_intwp   !< masked dimension values if working-precision int
[4070]127      INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE ::  values_int8           !< dimension values if 16bit integer
128      INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE ::  values_int16          !< dimension values if 16bit integer
129      INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE ::  values_int32          !< dimension values if 32bit integer
130      INTEGER(iwp),    DIMENSION(:), ALLOCATABLE ::  values_intwp          !< dimension values if working-precision integer
131      LOGICAL,         DIMENSION(:), ALLOCATABLE ::  mask                  !< mask
132      REAL(KIND=4),    DIMENSION(:), ALLOCATABLE ::  masked_values_real32  !< masked dimension values if 32bit real
133      REAL(KIND=8),    DIMENSION(:), ALLOCATABLE ::  masked_values_real64  !< masked dimension values if 64bit real
134      REAL(wp),        DIMENSION(:), ALLOCATABLE ::  masked_values_realwp  !< masked dimension values if working-precision real
135      REAL(KIND=4),    DIMENSION(:), ALLOCATABLE ::  values_real32         !< dimension values if 32bit real
136      REAL(KIND=8),    DIMENSION(:), ALLOCATABLE ::  values_real64         !< dimension values if 64bit real
137      REAL(wp),        DIMENSION(:), ALLOCATABLE ::  values_realwp         !< dimension values if working-precision real
138      TYPE(attribute_type), DIMENSION(:), ALLOCATABLE ::  attributes       !< list of attributes
139   END TYPE dimension_type
140
141   TYPE file_type
[4141]142      CHARACTER(LEN=charlen)                          ::  format = ''        !< file format
143      CHARACTER(LEN=charlen)                          ::  name = ''          !< file name
144      INTEGER                                         ::  id = no_id         !< id of file
145      LOGICAL                                         ::  is_init = .FALSE.  !< true if initialized
146      TYPE(attribute_type), DIMENSION(:), ALLOCATABLE ::  attributes         !< list of attributes
147      TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  dimensions         !< list of dimensions
148      TYPE(variable_type),  DIMENSION(:), ALLOCATABLE ::  variables          !< list of variables
[4070]149   END TYPE file_type
150
151
[4141]152   CHARACTER(LEN=charlen) ::  output_file_suffix = ''      !< file suffix added to each file name
153   CHARACTER(LEN=800)     ::  internal_error_message = ''  !< string containing the last error message
154   CHARACTER(LEN=800)     ::  temp_string                  !< dummy string
[4070]155
[4141]156   INTEGER ::  debug_output_unit  !< Fortran Unit Number of the debug-output file
157   INTEGER ::  nfiles = 0         !< number of files
158   INTEGER ::  master_rank = 0    !< master rank for tasks to be executed by single PE only
159   INTEGER ::  output_group_comm  !< MPI communicator addressing all MPI ranks which participate in output
[4070]160
161   LOGICAL ::  print_debug_output = .FALSE.  !< if true, debug output is printed
162
163   TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  files  !< file list
164
165   SAVE
166
167   PRIVATE
168
169   !> Initialize the data-output module
170   INTERFACE dom_init
171      MODULE PROCEDURE dom_init
172   END INTERFACE dom_init
173
174   !> Add files to database
175   INTERFACE dom_def_file
176      MODULE PROCEDURE dom_def_file
177   END INTERFACE dom_def_file
178
179   !> Add dimensions to database
180   INTERFACE dom_def_dim
181      MODULE PROCEDURE dom_def_dim
182   END INTERFACE dom_def_dim
183
184   !> Add variables to database
185   INTERFACE dom_def_var
186      MODULE PROCEDURE dom_def_var
187   END INTERFACE dom_def_var
188
189   !> Add attributes to database
190   INTERFACE dom_def_att
191      MODULE PROCEDURE dom_def_att_char
192      MODULE PROCEDURE dom_def_att_int8
193      MODULE PROCEDURE dom_def_att_int16
194      MODULE PROCEDURE dom_def_att_int32
195      MODULE PROCEDURE dom_def_att_real32
196      MODULE PROCEDURE dom_def_att_real64
197   END INTERFACE dom_def_att
198
199   !> Prepare for output: evaluate database and create files
[4141]200   INTERFACE dom_def_end
201      MODULE PROCEDURE dom_def_end
202   END INTERFACE dom_def_end
[4070]203
204   !> Write variables to file
205   INTERFACE dom_write_var
206      MODULE PROCEDURE dom_write_var
207   END INTERFACE dom_write_var
208
209   !> Last actions required for output befor termination
210   INTERFACE dom_finalize_output
211      MODULE PROCEDURE dom_finalize_output
212   END INTERFACE dom_finalize_output
213
214   !> Return error message
215   INTERFACE dom_get_error_message
216      MODULE PROCEDURE dom_get_error_message
217   END INTERFACE dom_get_error_message
218
[4141]219   !> Write database to debug output
220   INTERFACE dom_database_debug_output
221      MODULE PROCEDURE dom_database_debug_output
222   END INTERFACE dom_database_debug_output
223
[4070]224   PUBLIC &
[4141]225      dom_init, &
226      dom_def_file, &
[4070]227      dom_def_dim, &
228      dom_def_var, &
[4141]229      dom_def_att, &
230      dom_def_end, &
231      dom_write_var, &
[4070]232      dom_finalize_output, &
233      dom_get_error_message, &
[4141]234      dom_database_debug_output
[4070]235
236CONTAINS
237
238
239!--------------------------------------------------------------------------------------------------!
240! Description:
241! ------------
[4141]242!> Initialize data-output module.
243!> Provide some general information of the main program.
244!> The optional argument 'file_suffix_of_output_group' defines a file suffix which is added to all
245!> output files. If multiple output groups (groups of MPI ranks, defined by
246!> 'mpi_comm_of_output_group') exist, a unique file suffix must be given for each group. This
247!> prevents that multiple groups try to open and write to the same output file.
[4070]248!--------------------------------------------------------------------------------------------------!
[4107]249SUBROUTINE dom_init( file_suffix_of_output_group, mpi_comm_of_output_group, master_output_rank, &
250                     program_debug_output_unit, debug_output )
[4070]251
[4107]252   CHARACTER(LEN=*), INTENT(IN), OPTIONAL ::  file_suffix_of_output_group  !< file-name suffix added to each file;
253                                                                           !> must be unique for each output group
[4070]254
[4107]255   INTEGER, INTENT(IN), OPTIONAL ::  master_output_rank         !< MPI rank executing tasks which must
256                                                                !> be executed by a single PE only
257   INTEGER, INTENT(IN)           ::  mpi_comm_of_output_group   !< MPI communicator specifying the MPI group
258                                                                !> which participate in the output
259   INTEGER, INTENT(IN)           ::  program_debug_output_unit  !< file unit number for debug output
260
[4141]261   LOGICAL, INTENT(IN)           ::  debug_output               !< if true, debug output is printed
[4070]262
263
[4107]264   IF ( PRESENT( file_suffix_of_output_group ) )  output_file_suffix = file_suffix_of_output_group
265   IF ( PRESENT( master_output_rank ) )  master_rank = master_output_rank
266
267   output_group_comm = mpi_comm_of_output_group
268
[4070]269   debug_output_unit = program_debug_output_unit
270   print_debug_output = debug_output
271
[4107]272   CALL binary_init_module( output_file_suffix, output_group_comm, master_rank, &
[4141]273                            debug_output_unit, debug_output, no_id )
[4070]274
[4107]275   CALL netcdf4_init_module( output_file_suffix, output_group_comm, master_rank, &
[4141]276                            debug_output_unit, debug_output, no_id )
[4070]277
278END SUBROUTINE dom_init
279
280!--------------------------------------------------------------------------------------------------!
281! Description:
282! ------------
283!> Define output file.
[4141]284!> Example call:
285!>   status = dom_def_file( 'my_output_file_name', 'binary' )
[4070]286!--------------------------------------------------------------------------------------------------!
[4141]287FUNCTION dom_def_file( file_name, file_format ) RESULT( return_value )
[4070]288
[4141]289   CHARACTER(LEN=*), INTENT(IN) ::  file_name    !< name of file to be created
290   CHARACTER(LEN=*), INTENT(IN) ::  file_format  !< format of file to be created
[4070]291
292   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_file'  !< name of this routine
293
[4141]294   INTEGER ::  f             !< loop index
295   INTEGER ::  return_value  !< return value
[4070]296
297   TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  files_tmp  !< temporary file list
298
299
300   return_value = 0
301
[4141]302   CALL internal_message( 'debug', routine_name // ': define file "' // TRIM( file_name ) // '"' )
[4116]303
[4070]304   !-- Allocate file list or extend it by 1
305   IF ( .NOT. ALLOCATED( files ) ) THEN
306
[4141]307      nfiles = 1
308      ALLOCATE( files(nfiles) )
[4070]309
310   ELSE
311
[4141]312      nfiles = SIZE( files )
[4070]313      !-- Check if file already exists
[4141]314      DO  f = 1, nfiles
315         IF ( files(f)%name == TRIM( file_name ) )  THEN
[4070]316            return_value = 1
[4141]317            CALL internal_message( 'error', routine_name // &
318                    ': file "' // TRIM( file_name ) // '" already exists' )
[4070]319            EXIT
320         ENDIF
321      ENDDO
322
323      !-- Extend file list
324      IF ( return_value == 0 )  THEN
[4141]325         ALLOCATE( files_tmp(nfiles) )
[4070]326         files_tmp = files
327         DEALLOCATE( files )
[4141]328         nfiles = nfiles + 1
329         ALLOCATE( files(nfiles) )
330         files(:nfiles-1) = files_tmp
[4070]331         DEALLOCATE( files_tmp )
332      ENDIF
333
334   ENDIF
335
336   !-- Add new file to database
337   IF ( return_value == 0 )  THEN
[4141]338      files(nfiles)%name = TRIM( file_name )
339      files(nfiles)%format = TRIM( file_format )
[4070]340   ENDIF
341
342END FUNCTION dom_def_file
343
344!--------------------------------------------------------------------------------------------------!
345! Description:
346! ------------
[4141]347!> Define dimension.
348!> Dimensions can either be limited (a lower and upper bound is given) or unlimited (only a lower
349!> bound is given). Also, instead of providing all values of the dimension, a single value can be
350!> given which is then used to fill the entire dimension.
351!> An optional mask can be given to mask limited dimensions.
352!> Example call:
353!>   - fixed dimension with 100 entries (values known):
354!>       status = dom_def_dim( file_name='my_output_file_name', dimension_name='my_dimension', &
355!>                             output_type='real32', bounds=(/1,100/), &
356!>                             values_real32=my_dim(1:100), mask=my_dim_mask(1:100) )
357!>   - fixed dimension with 50 entries (values not yet known):
358!>       status = dom_def_dim( file_name='my_output_file_name', dimension_name='my_dimension', &
359!>                             output_type='int32', bounds=(/0,49/), &
360!>                             values_int32=(/fill_value/) )
361!>   - masked dimension with 75 entries:
362!>       status = dom_def_dim( file_name='my_output_file_name', dimension_name='my_dimension', &
363!>                             output_type='real64', bounds=(/101,175/), &
364!>                             values_real64=my_dim(1:75), mask=my_dim_mask(1:75) )
365!>   - unlimited dimension:
366!>       status = dom_def_dim( file_name='my_output_file_name', dimension_name='my_dimension', &
367!>                             output_type='real32', bounds=(/1/), &
368!>                             values_real32=(/fill_value/) )
[4070]369!>
370!> @todo Convert given values into selected output_type.
371!--------------------------------------------------------------------------------------------------!
[4141]372FUNCTION dom_def_dim( file_name, dimension_name, output_type, bounds,        &
[4070]373                      values_int8, values_int16, values_int32, values_intwp, &
374                      values_real32, values_real64, values_realwp,           &
375                      mask ) RESULT( return_value )
376
[4141]377   CHARACTER(LEN=*), INTENT(IN) ::  file_name       !< name of file
378   CHARACTER(LEN=*), INTENT(IN) ::  dimension_name  !< name of dimension
379   CHARACTER(LEN=*), INTENT(IN) ::  output_type     !< data type of dimension variable in output file
[4070]380
381   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_dim'  !< name of this routine
382
[4141]383   INTEGER ::  d             !< loop index
384   INTEGER ::  f             !< loop index
385   INTEGER ::  i             !< loop index
386   INTEGER ::  j             !< loop index
387   INTEGER ::  ndims         !< number of dimensions in file
388   INTEGER ::  return_value  !< return value
[4070]389
[4141]390   INTEGER,         DIMENSION(:), INTENT(IN)           ::  bounds         !< lower and upper bound of dimension variable
391   INTEGER(KIND=1), DIMENSION(:), INTENT(IN), OPTIONAL ::  values_int8    !< values of dimension
392   INTEGER(KIND=2), DIMENSION(:), INTENT(IN), OPTIONAL ::  values_int16   !< values of dimension
393   INTEGER(KIND=4), DIMENSION(:), INTENT(IN), OPTIONAL ::  values_int32   !< values of dimension
394   INTEGER(iwp),    DIMENSION(:), INTENT(IN), OPTIONAL ::  values_intwp   !< values of dimension
[4070]395
[4141]396   LOGICAL,         DIMENSION(:), INTENT(IN), OPTIONAL ::  mask           !< mask of dimesion
[4070]397
[4141]398   REAL(KIND=4),    DIMENSION(:), INTENT(IN), OPTIONAL ::  values_real32  !< values of dimension
399   REAL(KIND=8),    DIMENSION(:), INTENT(IN), OPTIONAL ::  values_real64  !< values of dimension
400   REAL(wp),        DIMENSION(:), INTENT(IN), OPTIONAL ::  values_realwp  !< values of dimension
[4070]401
[4141]402   TYPE(dimension_type)                            ::  dimension       !< new dimension
403   TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  dimensions_tmp  !< temporary dimension list
[4070]404
405
406   return_value = 0
407
[4141]408   CALL internal_message( 'debug', routine_name //                    &
409                          ': define dimension ' //                    &
410                          '(dimension "' // TRIM( dimension_name ) // &
411                          '", file "' // TRIM( file_name ) // '")' )
[4116]412
[4141]413   dimension%name      = TRIM( dimension_name )
[4070]414   dimension%data_type = TRIM( output_type )
415
416   !-- Check dimension bounds and allocate dimension according to bounds
417   IF ( SIZE( bounds ) == 1 )  THEN
418
419      !-- Dimension has only lower bound, which means it changes its size
420      !-- during simulation.
421      !-- Set length to -1 as indicator.
422      dimension%bounds(:) = bounds(1)
[4141]423      dimension%length    = -1
[4070]424
425      IF ( PRESENT( mask ) )  THEN
426         return_value = 1
[4141]427         CALL internal_message( 'error', routine_name //                      &
428                                ': unlimited dimensions cannot be masked ' // &
429                                '(dimension "' // TRIM( dimension_name ) //   &
430                                '", file "' // TRIM( file_name ) // '")!' )
[4070]431      ENDIF
432
433   ELSEIF ( SIZE( bounds ) == 2 )  THEN
434
435      dimension%bounds = bounds
436      dimension%length = bounds(2) - bounds(1) + 1
437
438      !-- Save dimension values
439      IF ( PRESENT( values_int8 ) )  THEN
440         ALLOCATE( dimension%values_int8(dimension%bounds(1):dimension%bounds(2)) )
441         IF ( SIZE( values_int8 ) == dimension%length )  THEN
442            dimension%values_int8 = values_int8
443         ELSEIF ( SIZE( values_int8 ) == 1 )  THEN
[4141]444            dimension%values_int8(:) = values_int8(1)
[4070]445         ELSE
446            return_value = 2
447         ENDIF
448      ELSEIF( PRESENT( values_int16 ) )  THEN
449         ALLOCATE( dimension%values_int16(dimension%bounds(1):dimension%bounds(2)) )
450         IF ( SIZE( values_int16 ) == dimension%length )  THEN
451            dimension%values_int16 = values_int16
452         ELSEIF ( SIZE( values_int16 ) == 1 )  THEN
[4141]453            dimension%values_int16(:) = values_int16(1)
[4070]454         ELSE
455            return_value = 2
456         ENDIF
457      ELSEIF( PRESENT( values_int32 ) )  THEN
458         ALLOCATE( dimension%values_int32(dimension%bounds(1):dimension%bounds(2)) )
459         IF ( SIZE( values_int32 ) == dimension%length )  THEN
460            dimension%values_int32 = values_int32
461         ELSEIF ( SIZE( values_int32 ) == 1 )  THEN
[4141]462            dimension%values_int32(:) = values_int32(1)
[4070]463         ELSE
464            return_value = 2
465         ENDIF
466      ELSEIF( PRESENT( values_intwp ) )  THEN
467         ALLOCATE( dimension%values_intwp(dimension%bounds(1):dimension%bounds(2)) )
468         IF ( SIZE( values_intwp ) == dimension%length )  THEN
469            dimension%values_intwp = values_intwp
470         ELSEIF ( SIZE( values_intwp ) == 1 )  THEN
[4141]471            dimension%values_intwp(:) = values_intwp(1)
[4070]472         ELSE
473            return_value = 2
474         ENDIF
475      ELSEIF( PRESENT( values_real32 ) )  THEN
476         ALLOCATE( dimension%values_real32(dimension%bounds(1):dimension%bounds(2)) )
477         IF ( SIZE( values_real32 ) == dimension%length )  THEN
478            dimension%values_real32 = values_real32
479         ELSEIF ( SIZE( values_real32 ) == 1 )  THEN
[4141]480            dimension%values_real32(:) = values_real32(1)
[4070]481         ELSE
482            return_value = 2
483         ENDIF
484      ELSEIF( PRESENT( values_real64 ) )  THEN
485         ALLOCATE( dimension%values_real64(dimension%bounds(1):dimension%bounds(2)) )
486         IF ( SIZE( values_real64 ) == dimension%length )  THEN
487            dimension%values_real64 = values_real64
488         ELSEIF ( SIZE( values_real64 ) == 1 )  THEN
[4141]489            dimension%values_real64(:) = values_real64(1)
[4070]490         ELSE
491            return_value = 2
492         ENDIF
493      ELSEIF( PRESENT( values_realwp ) )  THEN
494         ALLOCATE( dimension%values_realwp(dimension%bounds(1):dimension%bounds(2)) )
495         IF ( SIZE( values_realwp ) == dimension%length )  THEN
496            dimension%values_realwp = values_realwp
497         ELSEIF ( SIZE( values_realwp ) == 1 )  THEN
[4141]498            dimension%values_realwp(:) = values_realwp(1)
[4070]499         ELSE
500            return_value = 2
501         ENDIF
502      ELSE
503         return_value = 1
[4141]504         CALL internal_message( 'error', routine_name //                    &
505                                ': no values given ' //                     &
506                                '(dimension "' // TRIM( dimension_name ) // &
507                                '", file "' // TRIM( file_name ) // '")!' )
[4070]508      ENDIF
509
510      IF ( return_value == 2 )  THEN
511         return_value = 1
[4141]512         CALL internal_message( 'error', routine_name //                               &
513                                ': number of values and given bounds do not match ' // &
514                                '(dimension "' // TRIM( dimension_name ) //            &
515                                '", file "' // TRIM( file_name ) // '")!' )
[4070]516      ENDIF
517
518      !-- Initialize mask
519      IF ( PRESENT( mask )  .AND.  return_value == 0 )  THEN
520
521         IF ( dimension%length == SIZE( mask ) )  THEN
522
[4141]523            IF ( ALL( mask ) )  THEN
[4070]524
[4141]525               CALL internal_message( 'debug', routine_name //                              &
526                                      ': mask contains only TRUE values. Ignoring mask ' // &
527                                      '(dimension "' // TRIM( dimension_name ) //           &
528                                      '", file "' // TRIM( file_name ) // '")!' )
[4070]529
[4141]530            ELSE
[4070]531
[4141]532               dimension%is_masked = .TRUE.
533               dimension%length_mask = COUNT( mask )
[4070]534
[4141]535               ALLOCATE( dimension%mask(dimension%bounds(1):dimension%bounds(2)) )
536               ALLOCATE( dimension%masked_indices(0:dimension%length_mask-1) )
[4070]537
[4141]538               dimension%mask = mask
[4070]539
[4141]540               !-- Save masked positions and masked values
541               IF ( ALLOCATED( dimension%values_int8 ) )  THEN
[4070]542
[4141]543                  ALLOCATE( dimension%masked_values_int8(0:dimension%length_mask-1) )
544                  j = 0
545                  DO  i = dimension%bounds(1), dimension%bounds(2)
546                     IF ( dimension%mask(i) )  THEN
547                        dimension%masked_values_int8(j) = dimension%values_int8(i)
548                        dimension%masked_indices(j) = i
549                        j = j + 1
550                     ENDIF
551                  ENDDO
[4070]552
[4141]553               ELSEIF ( ALLOCATED( dimension%values_int16 ) )  THEN
[4070]554
[4141]555                  ALLOCATE( dimension%masked_values_int16(0:dimension%length_mask-1) )
556                  j = 0
557                  DO  i = dimension%bounds(1), dimension%bounds(2)
558                     IF ( dimension%mask(i) )  THEN
559                        dimension%masked_values_int16(j) = dimension%values_int16(i)
560                        dimension%masked_indices(j) = i
561                        j = j + 1
562                     ENDIF
563                  ENDDO
[4070]564
[4141]565               ELSEIF ( ALLOCATED( dimension%values_int32 ) )  THEN
[4070]566
[4141]567                  ALLOCATE( dimension%masked_values_int32(0:dimension%length_mask-1) )
568                  j = 0
569                  DO  i =dimension%bounds(1), dimension%bounds(2)
570                     IF ( dimension%mask(i) )  THEN
571                        dimension%masked_values_int32(j) = dimension%values_int32(i)
572                        dimension%masked_indices(j) = i
573                        j = j + 1
574                     ENDIF
575                  ENDDO
[4070]576
[4141]577               ELSEIF ( ALLOCATED( dimension%values_intwp ) )  THEN
[4070]578
[4141]579                  ALLOCATE( dimension%masked_values_intwp(0:dimension%length_mask-1) )
580                  j = 0
581                  DO  i = dimension%bounds(1), dimension%bounds(2)
582                     IF ( dimension%mask(i) )  THEN
583                        dimension%masked_values_intwp(j) = dimension%values_intwp(i)
584                        dimension%masked_indices(j) = i
585                        j = j + 1
586                     ENDIF
587                  ENDDO
[4070]588
[4141]589               ELSEIF ( ALLOCATED( dimension%values_real32 ) )  THEN
[4070]590
[4141]591                  ALLOCATE( dimension%masked_values_real32(0:dimension%length_mask-1) )
592                  j = 0
593                  DO  i = dimension%bounds(1), dimension%bounds(2)
594                     IF ( dimension%mask(i) )  THEN
595                        dimension%masked_values_real32(j) = dimension%values_real32(i)
596                        dimension%masked_indices(j) = i
597                        j = j + 1
598                     ENDIF
599                  ENDDO
[4070]600
[4141]601               ELSEIF ( ALLOCATED(dimension%values_real64) )  THEN
[4070]602
[4141]603                  ALLOCATE( dimension%masked_values_real64(0:dimension%length_mask-1) )
604                  j = 0
605                  DO  i = dimension%bounds(1), dimension%bounds(2)
606                     IF ( dimension%mask(i) )  THEN
607                        dimension%masked_values_real64(j) = dimension%values_real64(i)
608                        dimension%masked_indices(j) = i
609                        j = j + 1
610                     ENDIF
611                  ENDDO
[4070]612
[4141]613               ELSEIF ( ALLOCATED(dimension%values_realwp) )  THEN
614
615                  ALLOCATE( dimension%masked_values_realwp(0:dimension%length_mask-1) )
616                  j = 0
617                  DO  i = dimension%bounds(1), dimension%bounds(2)
618                     IF ( dimension%mask(i) )  THEN
619                        dimension%masked_values_realwp(j) = dimension%values_realwp(i)
620                        dimension%masked_indices(j) = i
621                        j = j + 1
622                     ENDIF
623                  ENDDO
624
625               ENDIF
626
627            ENDIF  ! if not all mask = true
628
[4070]629         ELSE
630            return_value = 1
[4141]631            CALL internal_message( 'error', routine_name //                           &
632                                   ': size of mask and given bounds do not match ' // &
633                                   '(dimension "' // TRIM( dimension_name ) //        &
634                                   '", file "' // TRIM( file_name ) // '")!' )
[4070]635         ENDIF
636
637      ENDIF
638
639   ELSE
640
641      return_value = 1
[4116]642      CALL internal_message( 'error', routine_name //                                       &
643                             ': at least one but no more than two bounds must be given ' // &
[4141]644                             '(dimension "' // TRIM( dimension_name ) //                    &
645                             '", file "' // TRIM( file_name ) // '")!' )
[4070]646
647   ENDIF
648
649   !-- Add dimension to database
650   IF ( return_value == 0 )  THEN
651
[4141]652      DO  f = 1, nfiles
[4070]653
[4141]654         IF ( TRIM( file_name ) == files(f)%name )  THEN
[4070]655
[4106]656            IF ( files(f)%is_init )  THEN
[4070]657
[4106]658               return_value = 1
[4141]659               CALL internal_message( 'error', routine_name //                      &
660                                      ': file already initialized. ' //             &
661                                      'No further dimension definition allowed ' // &
662                                      '(dimension "' // TRIM( dimension_name ) //   &
663                                      '", file "' // TRIM( file_name ) // '")!' )
[4106]664               EXIT
665
666            ELSEIF ( .NOT. ALLOCATED( files(f)%dimensions ) )  THEN
667
[4141]668               ndims = 1
669               ALLOCATE( files(f)%dimensions(ndims) )
[4070]670
671            ELSE
672
[4106]673               !-- Check if any variable of the same name as the new dimension is already defined
674               IF ( ALLOCATED( files(f)%variables ) )  THEN
675                  DO  i = 1, SIZE( files(f)%variables )
676                     IF ( files(f)%variables(i)%name == dimension%name )  THEN
677                        return_value = 1
[4141]678                        CALL internal_message( 'error', routine_name //                    &
679                                ': file already has a variable of this name defined. ' //  &
680                                'Defining a dimension of the same name is not allowed ' // &
681                                '(dimension "' // TRIM( dimension_name ) //                &
682                                '", file "' // TRIM( file_name ) // '")!' )
[4106]683                        EXIT
684                     ENDIF
685                  ENDDO
686               ENDIF
[4070]687
[4106]688               IF ( return_value == 0 )  THEN
689                  !-- Check if dimension already exists in file
[4141]690                  ndims = SIZE( files(f)%dimensions )
[4106]691
[4141]692                  DO  d = 1, ndims
[4106]693                     IF ( files(f)%dimensions(d)%name == dimension%name )  THEN
694                        return_value = 1
[4141]695                        CALL internal_message( 'error', routine_name //     &
696                                ': dimension already exists in file ' //    &
697                                '(dimension "' // TRIM( dimension_name ) // &
698                                '", file "' // TRIM( file_name ) // '")!' )
[4106]699                        EXIT
700                     ENDIF
701                  ENDDO
702
703                  !-- Extend dimension list
704                  IF ( return_value == 0 )  THEN
[4141]705                     ALLOCATE( dimensions_tmp(ndims) )
706                     dimensions_tmp = files(f)%dimensions
[4106]707                     DEALLOCATE( files(f)%dimensions )
[4141]708                     ndims = ndims + 1
709                     ALLOCATE( files(f)%dimensions(ndims) )
710                     files(f)%dimensions(:ndims-1) = dimensions_tmp
711                     DEALLOCATE( dimensions_tmp )
[4070]712                  ENDIF
713               ENDIF
714
715            ENDIF
716
717            !-- Add new dimension to database
[4141]718            IF ( return_value == 0 )  files(f)%dimensions(ndims) = dimension
[4070]719
720            EXIT
721
722         ENDIF
723      ENDDO
724
[4141]725      IF ( f > nfiles )  THEN
[4070]726         return_value = 1
[4141]727         CALL internal_message( 'error', routine_name //                                     &
728                                ': file not found (dimension "' // TRIM( dimension_name ) // &
729                                '", file "' // TRIM( file_name ) // '")!' )
[4070]730      ENDIF
731
732   ENDIF
733
734END FUNCTION dom_def_dim
735
736!--------------------------------------------------------------------------------------------------!
737! Description:
738! ------------
739!> Add variable to database.
[4141]740!> If a variable is identical for each MPI rank, the optional argument 'is_global' should be set to
741!> TRUE. This flags the variable to be a global variable and is later only written once by the
742!> master output rank.
[4123]743!> Example call:
[4141]744!>   dom_def_var( file_name =  'my_output_file_name', &
745!>                variable_name = 'u', &
[4123]746!>                dimension_names = (/'x   ', 'y   ', 'z   ', 'time'/), &
747!>                output_type = 'real32' )
748!> @note The order of dimensions must match in reversed order to the dimensions of the
749!>       corresponding variable array. The last given dimension can also be non-existent within the
750!>       variable array if at any given call of 'dom_write_var' for this variable, the last
751!>       dimension has only a single index.
752!>       Hence, the array 'u' must be allocated with dimension 'x' as its last dimension, preceded
753!>       by 'y', then 'z', and 'time' being the first dimension. If at any given write statement,
754!>       only a single index of dimension 'time' is to be written, the dimension can be non-present
755!>       in the variable array leaving dimension 'z' as the first dimension.
756!>       So, the variable array needs to be allocated like either:
757!>          ALLOCATE( u(<time>,<z>,<y>,<x>) )
758!>       or
759!>          ALLOCATE( u(<z>,<y>,<x>) )
[4070]760!--------------------------------------------------------------------------------------------------!
[4141]761FUNCTION dom_def_var( file_name, variable_name, dimension_names, output_type, is_global ) &
[4070]762            RESULT( return_value )
763
[4141]764   CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< name of file
765   CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
766   CHARACTER(LEN=*), INTENT(IN) ::  output_type    !< data type of variable
[4070]767
768   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_var'  !< name of this routine
769
770   CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) ::  dimension_names  !< list of dimension names
771
[4141]772   INTEGER ::  d             !< loop index
773   INTEGER ::  f             !< loop index
774   INTEGER ::  i             !< loop index
775   INTEGER ::  nvars         !< number of variables in file
776   INTEGER ::  return_value  !< return value
[4070]777
[4141]778   LOGICAL                       ::  found      !< true if requested dimension is defined in file
779   LOGICAL, INTENT(IN), OPTIONAL ::  is_global  !< true if variable is global (same on all PE)
[4070]780
[4141]781   TYPE(variable_type)                            ::  variable       !< new variable
782   TYPE(variable_type), DIMENSION(:), ALLOCATABLE ::  variables_tmp  !< temporary variable list
[4070]783
784
785   return_value = 0
[4141]786   found = .FALSE.
[4070]787
[4141]788   CALL internal_message( 'debug', routine_name //                                     &
789                          ': define variable (variable "' // TRIM( variable_name ) //  &
790                          '", file "' // TRIM( file_name ) // '")' )
[4116]791
[4141]792   variable%name = TRIM( variable_name )
[4070]793
794   ALLOCATE( variable%dimension_names(SIZE( dimension_names )) )
795   ALLOCATE( variable%dimension_ids(SIZE( dimension_names )) )
796
797   variable%dimension_names = dimension_names
[4123]798   variable%dimension_ids = -1
[4070]799   variable%data_type = TRIM( output_type )
800
801   IF ( PRESENT( is_global ) )  THEN
802      variable%is_global = is_global
803   ELSE
804      variable%is_global = .FALSE.
805   ENDIF
806
807   !-- Add variable to database
[4141]808   DO  f = 1, nfiles
[4070]809
[4141]810      IF ( TRIM( file_name ) == files(f)%name )  THEN
[4070]811
[4106]812         IF ( files(f)%is_init )  THEN
[4070]813
[4106]814            return_value = 1
[4141]815            CALL internal_message( 'error', routine_name //                                  &
816                    ': file already initialized. No further variable definition allowed ' // &
817                    '(variable "' // TRIM( variable_name ) //                                &
818                    '", file "' // TRIM( file_name ) // '")!' )
[4106]819            EXIT
820
821         ELSEIF ( ALLOCATED( files(f)%dimensions ) )  THEN
822
823            !-- Check if any dimension of the same name as the new variable is already defined
824            DO  d = 1, SIZE( files(f)%dimensions )
825               IF ( files(f)%dimensions(d)%name == variable%name )  THEN
[4070]826                  return_value = 1
[4141]827                  CALL internal_message( 'error', routine_name //                    &
828                          ': file already has a dimension of this name defined. ' // &
829                          'Defining a variable of the same name is not allowed ' //  &
830                          '(variable "' // TRIM( variable_name ) //                  &
831                          '", file "' // TRIM( file_name ) // '")!' )
[4070]832                  EXIT
833               ENDIF
834            ENDDO
835
[4106]836            !-- Check if dimensions assigned to variable are defined within file
837            IF ( return_value == 0 )  THEN
838               DO  i = 1, SIZE( variable%dimension_names )
839                  found = .FALSE.
840                  DO  d = 1, SIZE( files(f)%dimensions )
841                     IF ( files(f)%dimensions(d)%name == variable%dimension_names(i) )  THEN
842                        found = .TRUE.
843                        EXIT
844                     ENDIF
845                  ENDDO
846                  IF ( .NOT. found )  THEN
847                     return_value = 1
[4141]848                     CALL internal_message( 'error', routine_name //                            &
849                             ': required dimension "'//  TRIM( variable%dimension_names(i) ) // &
850                             '" for variable is not defined ' //                                &
851                             '(variable "' // TRIM( variable_name ) //                          &
852                             '", file "' // TRIM( file_name ) // '")!' )
[4106]853                     EXIT
854                  ENDIF
855               ENDDO
856            ENDIF
857
[4070]858         ELSE
859
860            return_value = 1
[4141]861            CALL internal_message( 'error', routine_name //                      &
862                    ': no dimensions defined in file. Cannot define variable '// &
863                    '(variable "' // TRIM( variable_name ) //                    &
864                    '", file "' // TRIM( file_name ) // '")!' )
[4070]865
866         ENDIF
867
868         IF ( return_value == 0 )  THEN
869
870            !-- Check if variable already exists
871            IF ( .NOT. ALLOCATED( files(f)%variables ) )  THEN
872
[4141]873               nvars = 1
874               ALLOCATE( files(f)%variables(nvars) )
[4070]875
876            ELSE
877
[4141]878               nvars = SIZE( files(f)%variables )
879               DO  i = 1, nvars
[4070]880                  IF ( files(f)%variables(i)%name == variable%name )  THEN
881                     return_value = 1
[4141]882                     CALL internal_message( 'error', routine_name //   &
883                             ': variable already exists '//            &
884                             '(variable "' // TRIM( variable_name ) // &
885                             '", file "' // TRIM( file_name ) // '")!' )
[4070]886                     EXIT
887                  ENDIF
888               ENDDO
889
890               IF ( return_value == 0 )  THEN
891                  !-- Extend variable list
[4141]892                  ALLOCATE( variables_tmp(nvars) )
893                  variables_tmp = files(f)%variables
[4070]894                  DEALLOCATE( files(f)%variables )
[4141]895                  nvars = nvars + 1
896                  ALLOCATE( files(f)%variables(nvars) )
897                  files(f)%variables(:nvars-1) = variables_tmp
898                  DEALLOCATE( variables_tmp )
[4070]899               ENDIF
900
901            ENDIF
902
903            !-- Add new variable to database
[4141]904            IF ( return_value == 0 )  files(f)%variables(nvars) = variable
[4070]905
906         ENDIF
907
908         EXIT
909
910      ENDIF
911
912   ENDDO
913
[4141]914   IF ( f > nfiles )  THEN
[4070]915      return_value = 1
[4141]916      CALL internal_message( 'error', routine_name //                                   &
917                             ': file not found (variable "' // TRIM( variable_name ) // &
918                             '", file "' // TRIM( file_name ) // '")!' )
[4070]919   ENDIF
920
921END FUNCTION dom_def_var
922
923!--------------------------------------------------------------------------------------------------!
924! Description:
925! ------------
926!> Create attribute with value of type character.
[4141]927!> If the optional argument 'variable_name' is given, the attribute is added to the respective
928!> variable or dimension of that name. Otherwise, the attribute is added as a global attribute to
929!> the file itself.
930!> If an attribute of similar name already exists, it is updated (overwritten) with the new value.
931!> If the optional argument 'append' is set TRUE, the value of an already existing attribute of
932!> similar name is appended by the new value instead of overwritten.
933!> Example call:
934!>   - define a global file attribute:
935!>      dom_def_att( file_name='my_output_file_name', &
936!>                   attribute_name='my_attribute', &
937!>                   value='This is the attribute value' )
938!>   - define a variable attribute:
939!>      dom_def_att( file_name='my_output_file_name', &
940!>                   variable_name='my_variable', &
941!>                   attribute_name='my_attribute', &
942!>                   value='This is the attribute value' )
943!>   - append an attribute:
944!>      dom_def_att( file_name='my_output_file_name', &
945!>                   attribute_name='my_attribute', &
946!>                   value=' and this part was appended', append=.TRUE. )
[4070]947!--------------------------------------------------------------------------------------------------!
[4141]948FUNCTION dom_def_att_char( file_name, variable_name, attribute_name, value, append ) &
949            RESULT( return_value )
[4070]950
[4141]951   CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
952   CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
953   CHARACTER(LEN=*),      INTENT(IN)           ::  value                   !< attribute value
954   CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
955   CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
[4070]956
957   ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_char'  !< name of routine
958
[4141]959   INTEGER ::  return_value  !< return value
[4070]960
961   LOGICAL                       ::  append_internal  !< same as 'append'
962   LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
963
964   TYPE(attribute_type) ::  attribute  !< new attribute
965
966
967   return_value = 0
968
969   IF ( PRESENT( append ) )  THEN
970      append_internal = append
971   ELSE
972      append_internal = .FALSE.
973   ENDIF
974
[4141]975   attribute%name       = TRIM( attribute_name )
[4070]976   attribute%data_type  = 'char'
977   attribute%value_char = TRIM( value )
978
[4141]979   IF ( PRESENT( variable_name ) )  THEN
980      variable_name_internal = TRIM( variable_name )
[4070]981   ELSE
[4141]982      variable_name_internal = ''
[4070]983   ENDIF
984
[4141]985   return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
986                     variable_name=TRIM( variable_name_internal ),         &
987                     attribute=attribute, append=append_internal )
988
[4070]989END FUNCTION dom_def_att_char
990
991!--------------------------------------------------------------------------------------------------!
992! Description:
993! ------------
994!> Create attribute with value of type int8.
[4141]995!> If the optional argument 'variable_name' is given, the attribute is added to the respective
996!> variable or dimension of that name. Otherwise, the attribute is added as a global attribute to
997!> the file itself.
998!> Numerical attributes cannot be appended, only updated (append=.TRUE. will cause an error).
999!> Example call:
1000!>   - define a global file attribute:
1001!>      dom_def_att( file_name='my_output_file_name', &
1002!>                   attribute_name='my_attribute', &
1003!>                   value=0_1 )
1004!>   - define a variable attribute:
1005!>      dom_def_att( file_name='my_output_file_name', &
1006!>                   variable_name='my_variable', &
1007!>                   attribute_name='my_attribute', &
1008!>                   value=1_1 )
[4070]1009!--------------------------------------------------------------------------------------------------!
[4141]1010FUNCTION dom_def_att_int8( file_name, variable_name, attribute_name, value, append ) &
1011            RESULT( return_value )
[4070]1012
[4141]1013   CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
1014   CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
1015   CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
1016   CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
[4070]1017
1018   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int8'  !< name of routine
1019
1020   INTEGER(KIND=1), INTENT(IN) ::  value  !< attribute value
1021
[4141]1022   INTEGER ::  return_value  !< return value
[4070]1023
1024   LOGICAL                       ::  append_internal  !< same as 'append'
1025   LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
1026
1027   TYPE(attribute_type) ::  attribute  !< new attribute
1028
1029
1030   return_value = 0
1031
[4141]1032   IF ( PRESENT( variable_name ) )  THEN
1033      variable_name_internal = TRIM( variable_name )
1034   ELSE
1035      variable_name_internal = ''
1036   ENDIF
1037
[4070]1038   IF ( PRESENT( append ) )  THEN
1039      IF ( append )  THEN
1040         return_value = 1
[4141]1041         CALL internal_message( 'error', routine_name //                             &
1042                                ': numeric attribute cannot be appended ' //         &
1043                                '(attribute "' // TRIM( attribute_name ) //          &
1044                                '", variable "' // TRIM( variable_name_internal ) // &
1045                                '", file "' // TRIM( file_name ) // '")!' )
[4070]1046      ENDIF
1047   ENDIF
1048
1049   IF ( return_value == 0 )  THEN
1050      append_internal = .FALSE.
1051
[4141]1052      attribute%name       = TRIM( attribute_name )
[4070]1053      attribute%data_type  = 'int8'
1054      attribute%value_int8 = value
1055
[4141]1056      return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
1057                        variable_name=TRIM( variable_name_internal ),         &
1058                        attribute=attribute, append=append_internal )
[4070]1059   ENDIF
1060
1061END FUNCTION dom_def_att_int8
1062
1063!--------------------------------------------------------------------------------------------------!
1064! Description:
1065! ------------
1066!> Create attribute with value of type int16.
[4141]1067!> If the optional argument 'variable_name' is given, the attribute is added to the respective
1068!> variable or dimension of that name. Otherwise, the attribute is added as a global attribute to
1069!> the file itself.
1070!> Numerical attributes cannot be appended, only updated (append=.TRUE. will cause an error).
1071!> Example call:
1072!>   - define a global file attribute:
1073!>      dom_def_att( file_name='my_output_file_name', &
1074!>                   attribute_name='my_attribute', &
1075!>                   value=0_2 )
1076!>   - define a variable attribute:
1077!>      dom_def_att( file_name='my_output_file_name', &
1078!>                   variable_name='my_variable', &
1079!>                   attribute_name='my_attribute', &
1080!>                   value=1_2 )
[4070]1081!--------------------------------------------------------------------------------------------------!
[4141]1082FUNCTION dom_def_att_int16( file_name, variable_name, attribute_name, value, append ) &
1083            RESULT( return_value )
[4070]1084
[4141]1085   CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
1086   CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
1087   CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
1088   CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
[4070]1089
1090   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int16'  !< name of routine
1091
1092   INTEGER(KIND=2), INTENT(IN) ::  value  !< attribute value
1093
[4141]1094   INTEGER ::  return_value  !< return value
[4070]1095
1096   LOGICAL                       ::  append_internal  !< same as 'append'
1097   LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
1098
1099   TYPE(attribute_type) ::  attribute  !< new attribute
1100
1101
1102   return_value = 0
1103
[4141]1104   IF ( PRESENT( variable_name ) )  THEN
1105      variable_name_internal = TRIM( variable_name )
1106   ELSE
1107      variable_name_internal = ''
1108   ENDIF
1109
[4070]1110   IF ( PRESENT( append ) )  THEN
1111      IF ( append )  THEN
1112         return_value = 1
[4141]1113         CALL internal_message( 'error', routine_name //                             &
1114                                ': numeric attribute cannot be appended ' //         &
1115                                '(attribute "' // TRIM( attribute_name ) //          &
1116                                '", variable "' // TRIM( variable_name_internal ) // &
1117                                '", file "' // TRIM( file_name ) // '")!' )
[4070]1118      ENDIF
1119   ENDIF
1120
1121   IF ( return_value == 0 )  THEN
1122      append_internal = .FALSE.
1123
[4141]1124      attribute%name        = TRIM( attribute_name )
[4070]1125      attribute%data_type   = 'int16'
1126      attribute%value_int16 = value
1127
[4141]1128      return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
1129                        variable_name=TRIM( variable_name_internal ),         &
1130                        attribute=attribute, append=append_internal )
[4070]1131   ENDIF
1132
1133END FUNCTION dom_def_att_int16
1134
1135!--------------------------------------------------------------------------------------------------!
1136! Description:
1137! ------------
1138!> Create attribute with value of type int32.
[4141]1139!> If the optional argument 'variable_name' is given, the attribute is added to the respective
1140!> variable or dimension of that name. Otherwise, the attribute is added as a global attribute to
1141!> the file itself.
1142!> Numerical attributes cannot be appended, only updated (append=.TRUE. will cause an error).
1143!> Example call:
1144!>   - define a global file attribute:
1145!>      dom_def_att( file_name='my_output_file_name', &
1146!>                   attribute_name='my_attribute', &
1147!>                   value=0_4 )
1148!>   - define a variable attribute:
1149!>      dom_def_att( file_name='my_output_file_name', &
1150!>                   variable_name='my_variable', &
1151!>                   attribute_name='my_attribute', &
1152!>                   value=1_4 )
[4070]1153!--------------------------------------------------------------------------------------------------!
[4141]1154FUNCTION dom_def_att_int32( file_name, variable_name, attribute_name, value, append ) &
1155            RESULT( return_value )
[4070]1156
[4141]1157   CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
1158   CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
1159   CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
1160   CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
[4070]1161
1162   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int32'  !< name of routine
1163
1164   INTEGER(KIND=4), INTENT(IN) ::  value  !< attribute value
1165
[4141]1166   INTEGER ::  return_value  !< return value
[4070]1167
1168   LOGICAL                       ::  append_internal  !< same as 'append'
1169   LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
1170
1171   TYPE(attribute_type) ::  attribute  !< new attribute
1172
1173
1174   return_value = 0
1175
[4141]1176   IF ( PRESENT( variable_name ) )  THEN
1177      variable_name_internal = TRIM( variable_name )
1178   ELSE
1179      variable_name_internal = ''
1180   ENDIF
1181
[4070]1182   IF ( PRESENT( append ) )  THEN
1183      IF ( append )  THEN
1184         return_value = 1
[4141]1185         CALL internal_message( 'error', routine_name //                             &
1186                                ': numeric attribute cannot be appended ' //         &
1187                                '(attribute "' // TRIM( attribute_name ) //          &
1188                                '", variable "' // TRIM( variable_name_internal ) // &
1189                                '", file "' // TRIM( file_name ) // '")!' )
[4070]1190      ENDIF
1191   ENDIF
1192
1193   IF ( return_value == 0 )  THEN
1194      append_internal = .FALSE.
1195
[4141]1196      attribute%name        = TRIM( attribute_name )
[4070]1197      attribute%data_type   = 'int32'
1198      attribute%value_int32 = value
1199
[4141]1200      return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
1201                        variable_name=TRIM( variable_name_internal ),         &
1202                        attribute=attribute, append=append_internal )
[4070]1203   ENDIF
1204
1205END FUNCTION dom_def_att_int32
1206
1207!--------------------------------------------------------------------------------------------------!
1208! Description:
1209! ------------
1210!> Create attribute with value of type real32.
[4141]1211!> If the optional argument 'variable_name' is given, the attribute is added to the respective
1212!> variable or dimension of that name. Otherwise, the attribute is added as a global attribute to
1213!> the file itself.
1214!> Numerical attributes cannot be appended, only updated (append=.TRUE. will cause an error).
1215!> Example call:
1216!>   - define a global file attribute:
1217!>      dom_def_att( file_name='my_output_file_name', &
1218!>                   attribute_name='my_attribute', &
1219!>                   value=1.0_4 )
1220!>   - define a variable attribute:
1221!>      dom_def_att( file_name='my_output_file_name', &
1222!>                   variable_name='my_variable', &
1223!>                   attribute_name='my_attribute', &
1224!>                   value=1.0_4 )
[4070]1225!--------------------------------------------------------------------------------------------------!
[4141]1226FUNCTION dom_def_att_real32( file_name, variable_name, attribute_name, value, append ) &
1227            RESULT( return_value )
[4070]1228
[4141]1229   CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
1230   CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
1231   CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
1232   CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
[4070]1233
1234   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_real32'  !< name of routine
1235
[4141]1236   INTEGER ::  return_value  !< return value
[4070]1237
1238   LOGICAL                       ::  append_internal  !< same as 'append'
1239   LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
1240
1241   REAL(KIND=4), INTENT(IN) ::  value  !< attribute value
1242
1243   TYPE(attribute_type) ::  attribute  !< new attribute
1244
1245
1246   return_value = 0
1247
[4141]1248   IF ( PRESENT( variable_name ) )  THEN
1249      variable_name_internal = TRIM( variable_name )
1250   ELSE
1251      variable_name_internal = ''
1252   ENDIF
1253
[4070]1254   IF ( PRESENT( append ) )  THEN
1255      IF ( append )  THEN
1256         return_value = 1
[4141]1257         CALL internal_message( 'error', routine_name //                             &
1258                                ': numeric attribute cannot be appended ' //         &
1259                                '(attribute "' // TRIM( attribute_name ) //          &
1260                                '", variable "' // TRIM( variable_name_internal ) // &
1261                                '", file "' // TRIM( file_name ) // '")!' )
[4070]1262      ENDIF
1263   ENDIF
1264
1265   IF ( return_value == 0 )  THEN
1266      append_internal = .FALSE.
1267
[4141]1268      attribute%name         = TRIM( attribute_name )
[4070]1269      attribute%data_type    = 'real32'
1270      attribute%value_real32 = value
1271
[4141]1272      return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
1273                        variable_name=TRIM( variable_name_internal ),         &
1274                        attribute=attribute, append=append_internal )
[4070]1275   ENDIF
1276
1277END FUNCTION dom_def_att_real32
1278
1279!--------------------------------------------------------------------------------------------------!
1280! Description:
1281! ------------
1282!> Create attribute with value of type real64.
[4141]1283!> If the optional argument 'variable_name' is given, the attribute is added to the respective
1284!> variable or dimension of that name. Otherwise, the attribute is added as a global attribute to
1285!> the file itself.
1286!> Numerical attributes cannot be appended, only updated (append=.TRUE. will cause an error).
1287!> Example call:
1288!>   - define a global file attribute:
1289!>      dom_def_att( file_name='my_output_file_name', &
1290!>                   attribute_name='my_attribute', &
1291!>                   value=0.0_8 )
1292!>   - define a variable attribute:
1293!>      dom_def_att( file_name='my_output_file_name', &
1294!>                   variable_name='my_variable', &
1295!>                   attribute_name='my_attribute', &
1296!>                   value=1.0_8 )
[4070]1297!--------------------------------------------------------------------------------------------------!
[4141]1298FUNCTION dom_def_att_real64( file_name, variable_name, attribute_name, value, append ) &
1299            RESULT( return_value )
[4070]1300
[4141]1301   CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
1302   CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
1303   CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
1304   CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
[4070]1305
1306   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_real64'  !< name of routine
1307
[4141]1308   INTEGER ::  return_value  !< return value
[4070]1309
1310   LOGICAL                       ::  append_internal  !< same as 'append'
1311   LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
1312
1313   REAL(KIND=8), INTENT(IN) ::  value  !< attribute value
1314
1315   TYPE(attribute_type) ::  attribute  !< new attribute
1316
1317
1318   return_value = 0
1319
[4141]1320   IF ( PRESENT( variable_name ) )  THEN
1321      variable_name_internal = TRIM( variable_name )
1322   ELSE
1323      variable_name_internal = ''
1324   ENDIF
1325
[4070]1326   IF ( PRESENT( append ) )  THEN
1327      IF ( append )  THEN
1328         return_value = 1
[4141]1329         CALL internal_message( 'error', routine_name //                             &
1330                                ': numeric attribute cannot be appended ' //         &
1331                                '(attribute "' // TRIM( attribute_name ) //          &
1332                                '", variable "' // TRIM( variable_name_internal ) // &
1333                                '", file "' // TRIM( file_name ) // '")!' )
[4070]1334      ENDIF
1335   ENDIF
1336
1337   IF ( return_value == 0 )  THEN
1338      append_internal = .FALSE.
1339
[4141]1340      attribute%name         = TRIM( attribute_name )
[4070]1341      attribute%data_type    = 'real64'
1342      attribute%value_real64 = value
1343
[4141]1344      return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
1345                        variable_name=TRIM( variable_name_internal ),         &
1346                        attribute=attribute, append=append_internal )
1347   ENDIF
1348
1349END FUNCTION dom_def_att_real64
1350
1351!--------------------------------------------------------------------------------------------------!
1352! Description:
1353! ------------
1354!> End output definition.
1355!> The database is cleared from unused files and dimensions. Then, the output files are initialized
1356!> and prepared for writing output values to them. The saved values of the dimensions are written
1357!> to the files.
1358!--------------------------------------------------------------------------------------------------!
1359FUNCTION dom_def_end() RESULT( return_value )
1360
1361   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_end'  !< name of routine
1362
1363   INTEGER ::  d             !< loop index
1364   INTEGER ::  f             !< loop index
1365   INTEGER ::  return_value  !< return value
1366
1367   INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE, TARGET ::  values_int8           !< target array for dimension values
1368   INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE, TARGET ::  values_int16          !< target array for dimension values
1369   INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET ::  values_int32          !< target array for dimension values
1370   INTEGER(iwp),    DIMENSION(:), ALLOCATABLE, TARGET ::  values_intwp          !< target array for dimension values
1371   
1372   INTEGER(KIND=1), DIMENSION(:), POINTER, CONTIGUOUS ::  values_int8_pointer   !< pointer to target array
1373   INTEGER(KIND=2), DIMENSION(:), POINTER, CONTIGUOUS ::  values_int16_pointer  !< pointer to target array
1374   INTEGER(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS ::  values_int32_pointer  !< pointer to target array
1375   INTEGER(iwp),    DIMENSION(:), POINTER, CONTIGUOUS ::  values_intwp_pointer  !< pointer to target array
1376
1377   REAL(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET ::  values_real32            !< target array for dimension values
1378   REAL(KIND=8), DIMENSION(:), ALLOCATABLE, TARGET ::  values_real64            !< target array for dimension values
1379   REAL(wp),     DIMENSION(:), ALLOCATABLE, TARGET ::  values_realwp            !< target array for dimension values
1380
1381   REAL(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS ::  values_real32_pointer    !< pointer to target array
1382   REAL(KIND=8), DIMENSION(:), POINTER, CONTIGUOUS ::  values_real64_pointer    !< pointer to target array
1383   REAL(wp),     DIMENSION(:), POINTER, CONTIGUOUS ::  values_realwp_pointer    !< pointer to target array
1384
1385
1386   return_value = 0
1387   CALL internal_message( 'debug', routine_name // ': start' )
1388
1389   !-- Clear database from empty files and unused dimensions
1390   IF ( nfiles > 0 )  return_value = cleanup_database()
1391
1392   IF ( return_value == 0 )  THEN
1393      DO  f = 1, nfiles
1394
1395         !-- Skip initialization if file is already initialized
1396         IF ( files(f)%is_init )  CYCLE
1397
1398         CALL internal_message( 'debug', routine_name // ': initialize file "' // &
1399                                TRIM( files(f)%name ) // '"' )
1400
1401         !-- Open file
1402         CALL open_output_file( files(f)%format, files(f)%name, files(f)%id, &
1403                                return_value=return_value )
1404
1405         !-- Initialize file header:
1406         !-- define dimensions and variables and write attributes
1407         IF ( return_value == 0 )  &
1408            CALL init_file_header( files(f), return_value=return_value )
1409
1410         !-- End file definition
1411         IF ( return_value == 0 )  &
1412            CALL stop_file_header_definition( files(f)%format, files(f)%id, &
1413                                              files(f)%name, return_value )
1414
1415         IF ( return_value == 0 )  THEN
1416
1417            !-- Flag file as initialized
1418            files(f)%is_init = .TRUE.
1419
1420            !-- Write dimension values into file
1421            DO  d = 1, SIZE( files(f)%dimensions )
1422               IF ( ALLOCATED( files(f)%dimensions(d)%values_int8 ) )  THEN
1423                  ALLOCATE( values_int8(files(f)%dimensions(d)%bounds(1): &
1424                                        files(f)%dimensions(d)%bounds(2)) )
1425                  values_int8 = files(f)%dimensions(d)%values_int8
1426                  values_int8_pointer => values_int8
1427                  return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1428                                    bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
1429                                    bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
1430                                    values_int8_1d=values_int8_pointer )
1431                  DEALLOCATE( values_int8 )
1432               ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int16 ) )  THEN
1433                  ALLOCATE( values_int16(files(f)%dimensions(d)%bounds(1): &
1434                                         files(f)%dimensions(d)%bounds(2)) )
1435                  values_int16 = files(f)%dimensions(d)%values_int16
1436                  values_int16_pointer => values_int16
1437                  return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1438                                    bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
1439                                    bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
1440                                    values_int16_1d=values_int16_pointer )
1441                  DEALLOCATE( values_int16 )
1442               ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int32 ) )  THEN
1443                  ALLOCATE( values_int32(files(f)%dimensions(d)%bounds(1): &
1444                                         files(f)%dimensions(d)%bounds(2)) )
1445                  values_int32 = files(f)%dimensions(d)%values_int32
1446                  values_int32_pointer => values_int32
1447                  return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1448                                    bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
1449                                    bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
1450                                    values_int32_1d=values_int32_pointer )
1451                  DEALLOCATE( values_int32 )
1452               ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_intwp ) )  THEN
1453                  ALLOCATE( values_intwp(files(f)%dimensions(d)%bounds(1): &
1454                                         files(f)%dimensions(d)%bounds(2)) )
1455                  values_intwp = files(f)%dimensions(d)%values_intwp
1456                  values_intwp_pointer => values_intwp
1457                  return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1458                                    bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
1459                                    bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
1460                                    values_intwp_1d=values_intwp_pointer )
1461                  DEALLOCATE( values_intwp )
1462               ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real32 ) )  THEN
1463                  ALLOCATE( values_real32(files(f)%dimensions(d)%bounds(1): &
1464                                          files(f)%dimensions(d)%bounds(2)) )
1465                  values_real32 = files(f)%dimensions(d)%values_real32
1466                  values_real32_pointer => values_real32
1467                  return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1468                                    bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
1469                                    bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
1470                                    values_real32_1d=values_real32_pointer )
1471                  DEALLOCATE( values_real32 )
1472               ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real64 ) )  THEN
1473                  ALLOCATE( values_real64(files(f)%dimensions(d)%bounds(1): &
1474                                          files(f)%dimensions(d)%bounds(2)) )
1475                  values_real64 = files(f)%dimensions(d)%values_real64
1476                  values_real64_pointer => values_real64
1477                  return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1478                                    bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
1479                                    bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
1480                                    values_real64_1d=values_real64_pointer )
1481                  DEALLOCATE( values_real64 )
1482               ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_realwp ) )  THEN
1483                  ALLOCATE( values_realwp(files(f)%dimensions(d)%bounds(1): &
1484                                          files(f)%dimensions(d)%bounds(2)) )
1485                  values_realwp = files(f)%dimensions(d)%values_realwp
1486                  values_realwp_pointer => values_realwp
1487                  return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
1488                                    bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
1489                                    bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
1490                                    values_realwp_1d=values_realwp_pointer )
1491                  DEALLOCATE( values_realwp )
1492               ENDIF
1493               IF ( return_value /= 0 )  EXIT
1494            ENDDO
1495
1496         ENDIF
1497
1498         IF ( return_value /= 0 )  EXIT
1499
1500      ENDDO
1501   ENDIF
1502
1503   CALL internal_message( 'debug', routine_name // ': finished' )
1504
1505END FUNCTION dom_def_end
1506
1507!--------------------------------------------------------------------------------------------------!
1508! Description:
1509! ------------
1510!> Write variable to file.
1511!> Example call:
1512!>   dom_write_var( file_name = 'my_output_file_name', &
1513!>                  name = 'u', &
1514!>                  bounds_start = (/nxl, nys, nzb, time_step/), &
1515!>                  bounds_end = (/nxr, nyn, nzt, time_step/), &
1516!>                  values_real64_3d = u )
1517!> @note The order of dimension bounds must match to the order of dimensions given in call
1518!>       'dom_def_var'. I.e., the corresponding variable definition should be like:
1519!>          dom_def_var( file_name =  'my_output_file_name', &
1520!>                       name = 'u', &
1521!>                       dimension_names = (/'x   ', 'y   ', 'z   ', 'time'/), &
1522!>                       output_type = <desired-output-type> )
1523!> @note The values given do not need to be of the same data type as was defined in the
1524!>       corresponding 'dom_def_var' call. If the output format 'netcdf' was chosen, the values are
1525!>       automatically converted to the data type given during the definition. If 'binary' was
1526!>       chosen, the values are written to file as given in the 'dom_write_var' call.
1527!--------------------------------------------------------------------------------------------------!
1528FUNCTION dom_write_var( file_name, variable_name, bounds_start, bounds_end,         &
1529            values_int8_0d,   values_int8_1d,   values_int8_2d,   values_int8_3d,   &
1530            values_int16_0d,  values_int16_1d,  values_int16_2d,  values_int16_3d,  &
1531            values_int32_0d,  values_int32_1d,  values_int32_2d,  values_int32_3d,  &
1532            values_intwp_0d,  values_intwp_1d,  values_intwp_2d,  values_intwp_3d,  &
1533            values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &
1534            values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &
1535            values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d  &
1536            ) RESULT( return_value )
1537
1538   CHARACTER(LEN=charlen)            ::  file_format    !< file format chosen for file
1539   CHARACTER(LEN=*),      INTENT(IN) ::  file_name      !< name of file
1540   CHARACTER(LEN=*),      INTENT(IN) ::  variable_name  !< name of variable
1541
1542   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_write_var'  !< name of routine
1543
1544   INTEGER ::  file_id              !< file ID
1545   INTEGER ::  i                    !< loop index
1546   INTEGER ::  j                    !< loop index
1547   INTEGER ::  k                    !< loop index
1548   INTEGER ::  output_return_value  !< return value of a called output routine
1549   INTEGER ::  return_value         !< return value
1550   INTEGER ::  variable_id          !< variable ID
1551
1552   INTEGER, DIMENSION(:),   INTENT(IN)  ::  bounds_end             !< end index per dimension of variable
1553   INTEGER, DIMENSION(:),   INTENT(IN)  ::  bounds_start           !< start index per dimension of variable
1554   INTEGER, DIMENSION(:),   ALLOCATABLE ::  bounds_origin          !< first index of each dimension
1555   INTEGER, DIMENSION(:),   ALLOCATABLE ::  bounds_start_internal  !< start index per dim. for output after masking
1556   INTEGER, DIMENSION(:),   ALLOCATABLE ::  value_counts           !< count of indices to be written per dimension
1557   INTEGER, DIMENSION(:,:), ALLOCATABLE ::  masked_indices         !< list containing all output indices along a dimension
1558
1559   LOGICAL ::  do_output  !< true if any data lies within given range of masked dimension
1560   LOGICAL ::  is_global  !< true if variable is global
1561
1562   INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL                   ::  values_int8_0d             !< output variable
1563   INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL                   ::  values_int16_0d            !< output variable
1564   INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL                   ::  values_int32_0d            !< output variable
1565   INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL                   ::  values_intwp_0d            !< output variable
1566   INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int8_1d             !< output variable
1567   INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int16_1d            !< output variable
1568   INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int32_1d            !< output variable
1569   INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_intwp_1d            !< output variable
1570   INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int8_2d             !< output variable
1571   INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int16_2d            !< output variable
1572   INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int32_2d            !< output variable
1573   INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_intwp_2d            !< output variable
1574   INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int8_3d             !< output variable
1575   INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int16_3d            !< output variable
1576   INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int32_3d            !< output variable
1577   INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_intwp_3d            !< output variable
1578
1579   INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_int8_1d_resorted    !< resorted output variable
1580   INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_int16_1d_resorted   !< resorted output variable
1581   INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_int32_1d_resorted   !< resorted output variable
1582   INTEGER(iwp),    TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_intwp_1d_resorted   !< resorted output variable
1583   INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_int8_2d_resorted    !< resorted output variable
1584   INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_int16_2d_resorted   !< resorted output variable
1585   INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_int32_2d_resorted   !< resorted output variable
1586   INTEGER(iwp),    TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_intwp_2d_resorted   !< resorted output variable
1587   INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_int8_3d_resorted    !< resorted output variable
1588   INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_int16_3d_resorted   !< resorted output variable
1589   INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_int32_3d_resorted   !< resorted output variable
1590   INTEGER(iwp),    TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_intwp_3d_resorted   !< resorted output variable
1591
1592   INTEGER(KIND=1), POINTER                                         ::  values_int8_0d_pointer     !< pointer to resortet array
1593   INTEGER(KIND=2), POINTER                                         ::  values_int16_0d_pointer    !< pointer to resortet array
1594   INTEGER(KIND=4), POINTER                                         ::  values_int32_0d_pointer    !< pointer to resortet array
1595   INTEGER(iwp),    POINTER                                         ::  values_intwp_0d_pointer    !< pointer to resortet array
1596   INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_int8_1d_pointer     !< pointer to resortet array
1597   INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_int16_1d_pointer    !< pointer to resortet array
1598   INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_int32_1d_pointer    !< pointer to resortet array
1599   INTEGER(iwp),    POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_intwp_1d_pointer    !< pointer to resortet array
1600   INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_int8_2d_pointer     !< pointer to resortet array
1601   INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_int16_2d_pointer    !< pointer to resortet array
1602   INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_int32_2d_pointer    !< pointer to resortet array
1603   INTEGER(iwp),    POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_intwp_2d_pointer    !< pointer to resortet array
1604   INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_int8_3d_pointer     !< pointer to resortet array
1605   INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_int16_3d_pointer    !< pointer to resortet array
1606   INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_int32_3d_pointer    !< pointer to resortet array
1607   INTEGER(iwp),    POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_intwp_3d_pointer    !< pointer to resortet array
1608
1609   REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL                      ::  values_real32_0d           !< output variable
1610   REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL                      ::  values_real64_0d           !< output variable
1611   REAL(wp),     POINTER, INTENT(IN), OPTIONAL                      ::  values_realwp_0d           !< output variable
1612   REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)        ::  values_real32_1d           !< output variable
1613   REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)        ::  values_real64_1d           !< output variable
1614   REAL(wp),     POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)        ::  values_realwp_1d           !< output variable
1615   REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)      ::  values_real32_2d           !< output variable
1616   REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)      ::  values_real64_2d           !< output variable
1617   REAL(wp),     POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)      ::  values_realwp_2d           !< output variable
1618   REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:)    ::  values_real32_3d           !< output variable
1619   REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:)    ::  values_real64_3d           !< output variable
1620   REAL(wp),     POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:)    ::  values_realwp_3d           !< output variable
1621
1622   REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:)                  ::  values_real32_1d_resorted  !< resorted output variable
1623   REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:)                  ::  values_real64_1d_resorted  !< resorted output variable
1624   REAL(wp),     TARGET, ALLOCATABLE, DIMENSION(:)                  ::  values_realwp_1d_resorted  !< resorted output variable
1625   REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:)                ::  values_real32_2d_resorted  !< resorted output variable
1626   REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:)                ::  values_real64_2d_resorted  !< resorted output variable
1627   REAL(wp),     TARGET, ALLOCATABLE, DIMENSION(:,:)                ::  values_realwp_2d_resorted  !< resorted output variable
1628   REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:)              ::  values_real32_3d_resorted  !< resorted output variable
1629   REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:,:)              ::  values_real64_3d_resorted  !< resorted output variable
1630   REAL(wp),     TARGET, ALLOCATABLE, DIMENSION(:,:,:)              ::  values_realwp_3d_resorted  !< resorted output variable
1631
1632   REAL(KIND=4), POINTER                                            ::  values_real32_0d_pointer   !< pointer to resortet array
1633   REAL(KIND=8), POINTER                                            ::  values_real64_0d_pointer   !< pointer to resortet array
1634   REAL(wp),     POINTER                                            ::  values_realwp_0d_pointer   !< pointer to resortet array
1635   REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:)                  ::  values_real32_1d_pointer   !< pointer to resortet array
1636   REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:)                  ::  values_real64_1d_pointer   !< pointer to resortet array
1637   REAL(wp),     POINTER, CONTIGUOUS, DIMENSION(:)                  ::  values_realwp_1d_pointer   !< pointer to resortet array
1638   REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:)                ::  values_real32_2d_pointer   !< pointer to resortet array
1639   REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:)                ::  values_real64_2d_pointer   !< pointer to resortet array
1640   REAL(wp),     POINTER, CONTIGUOUS, DIMENSION(:,:)                ::  values_realwp_2d_pointer   !< pointer to resortet array
1641   REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:)              ::  values_real32_3d_pointer   !< pointer to resortet array
1642   REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:,:)              ::  values_real64_3d_pointer   !< pointer to resortet array
1643   REAL(wp),     POINTER, CONTIGUOUS, DIMENSION(:,:,:)              ::  values_realwp_3d_pointer   !< pointer to resortet array
1644
1645   TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  dimension_list  !< list of used dimensions of variable
1646
1647
1648   return_value = 0
1649   output_return_value = 0
1650
1651   CALL internal_message( 'debug', routine_name // ': write ' // TRIM( variable_name ) // &
1652                          ' into file ' // TRIM( file_name ) )
1653
1654   !-- Search for variable within file
1655   CALL find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, &
1656                          is_global, dimension_list, return_value=return_value  )
1657
1658   IF ( return_value == 0 )  THEN
1659
1660      !-- Check if the correct amount of variable bounds were given
1661      IF ( SIZE( bounds_start ) /= SIZE( dimension_list )  .OR.  &
1662           SIZE( bounds_end ) /= SIZE( dimension_list ) )  THEN
1663         return_value = 1
1664         CALL internal_message( 'error', routine_name //                  &
1665                                ': number bounds do not match with ' //   &
1666                                'number of dimensions of variable ' //    &
1667                                '(variable "' // TRIM( variable_name ) // &
1668                                '", file "' // TRIM( file_name ) // '")!' )
1669      ENDIF
1670
1671   ENDIF
1672
1673   IF ( return_value == 0 )  THEN
1674
1675      !-- Save starting index (lower bounds) of each dimension
1676      ALLOCATE( bounds_origin(SIZE( dimension_list )) )
1677      ALLOCATE( bounds_start_internal(SIZE( dimension_list )) )
1678      ALLOCATE( value_counts(SIZE( dimension_list )) )
1679
1680      WRITE( temp_string, * ) bounds_start
1681      CALL internal_message( 'debug', routine_name //                    &
1682                             ': file "' // TRIM( file_name ) //          &
1683                             '", variable "' // TRIM( variable_name ) // &
1684                             '", bounds_start =' // TRIM( temp_string ) )
1685      WRITE( temp_string, * ) bounds_end
1686      CALL internal_message( 'debug', routine_name //                    &
1687                             ': file "' // TRIM( file_name ) //          &
1688                             '", variable "' // TRIM( variable_name ) // &
1689                             '", bounds_end =' // TRIM( temp_string ) )
1690
1691      !-- Get bounds for masking
1692      CALL get_masked_indices_and_masked_dimension_bounds( dimension_list,                  &
1693              bounds_start, bounds_end, bounds_start_internal, value_counts, bounds_origin, &
1694              masked_indices )
1695
1696      do_output = .NOT. ANY( value_counts == 0 )
1697
1698      WRITE( temp_string, * ) bounds_start_internal
1699      CALL internal_message( 'debug', routine_name //                    &
1700                             ': file "' // TRIM( file_name ) //          &
1701                             '", variable "' // TRIM( variable_name ) // &
1702                             '", bounds_start_internal =' // TRIM( temp_string ) )
1703      WRITE( temp_string, * ) value_counts
1704      CALL internal_message( 'debug', routine_name //                    &
1705                             ': file "' // TRIM( file_name ) //          &
1706                             '", variable "' // TRIM( variable_name ) // &
1707                             '", value_counts =' // TRIM( temp_string ) )
1708
1709      !-- Mask and resort variable
1710      !-- 8bit integer output
1711      IF ( PRESENT( values_int8_0d ) )  THEN
1712         values_int8_0d_pointer => values_int8_0d
1713      ELSEIF ( PRESENT( values_int8_1d ) )  THEN
1714         IF ( do_output ) THEN
1715            ALLOCATE( values_int8_1d_resorted(0:value_counts(1)-1) )
1716            !$OMP PARALLEL PRIVATE (i)
1717            !$OMP DO
1718            DO  i = 0, value_counts(1) - 1
1719               values_int8_1d_resorted(i) = values_int8_1d(masked_indices(1,i))
1720            ENDDO
1721            !$OMP END PARALLEL
1722         ELSE
1723            ALLOCATE( values_int8_1d_resorted(1) )
1724            values_int8_1d_resorted = 0_1
1725         ENDIF
1726         values_int8_1d_pointer => values_int8_1d_resorted
1727      ELSEIF ( PRESENT( values_int8_2d ) )  THEN
1728         IF ( do_output ) THEN
1729            ALLOCATE( values_int8_2d_resorted(0:value_counts(1)-1, &
1730                                              0:value_counts(2)-1) )
1731            !$OMP PARALLEL PRIVATE (i,j)
1732            !$OMP DO
1733            DO  i = 0, value_counts(1) - 1
1734               DO  j = 0, value_counts(2) - 1
1735                  values_int8_2d_resorted(i,j) = values_int8_2d(masked_indices(2,j), &
1736                                                                masked_indices(1,i)  )
1737               ENDDO
1738            ENDDO
1739            !$OMP END PARALLEL
1740         ELSE
1741            ALLOCATE( values_int8_2d_resorted(1,1) )
1742            values_int8_2d_resorted = 0_1
1743         ENDIF
1744         values_int8_2d_pointer => values_int8_2d_resorted
1745      ELSEIF ( PRESENT( values_int8_3d ) )  THEN
1746         IF ( do_output ) THEN
1747            ALLOCATE( values_int8_3d_resorted(0:value_counts(1)-1, &
1748                                              0:value_counts(2)-1, &
1749                                              0:value_counts(3)-1) )
1750            !$OMP PARALLEL PRIVATE (i,j,k)
1751            !$OMP DO
1752            DO  i = 0, value_counts(1) - 1
1753               DO  j = 0, value_counts(2) - 1
1754                  DO  k = 0, value_counts(3) - 1
1755                     values_int8_3d_resorted(i,j,k) = values_int8_3d(masked_indices(3,k), &
1756                                                                     masked_indices(2,j), &
1757                                                                     masked_indices(1,i)  )
1758                  ENDDO
1759               ENDDO
1760            ENDDO
1761            !$OMP END PARALLEL
1762         ELSE
1763            ALLOCATE( values_int8_3d_resorted(1,1,1) )
1764            values_int8_3d_resorted = 0_1
1765         ENDIF
1766         values_int8_3d_pointer => values_int8_3d_resorted
1767
1768      !-- 16bit integer output
1769      ELSEIF ( PRESENT( values_int16_0d ) )  THEN
1770         values_int16_0d_pointer => values_int16_0d
1771      ELSEIF ( PRESENT( values_int16_1d ) )  THEN
1772         IF ( do_output ) THEN
1773            ALLOCATE( values_int16_1d_resorted(0:value_counts(1)-1) )
1774            !$OMP PARALLEL PRIVATE (i)
1775            !$OMP DO
1776            DO  i = 0, value_counts(1) - 1
1777               values_int16_1d_resorted(i) = values_int16_1d(masked_indices(1,i))
1778            ENDDO
1779            !$OMP END PARALLEL
1780         ELSE
1781            ALLOCATE( values_int16_1d_resorted(1) )
1782            values_int16_1d_resorted = 0_1
1783         ENDIF
1784         values_int16_1d_pointer => values_int16_1d_resorted
1785      ELSEIF ( PRESENT( values_int16_2d ) )  THEN
1786         IF ( do_output ) THEN
1787            ALLOCATE( values_int16_2d_resorted(0:value_counts(1)-1, &
1788                                               0:value_counts(2)-1) )
1789            !$OMP PARALLEL PRIVATE (i,j)
1790            !$OMP DO
1791            DO  i = 0, value_counts(1) - 1
1792               DO  j = 0, value_counts(2) - 1
1793                  values_int16_2d_resorted(i,j) = values_int16_2d(masked_indices(2,j), &
1794                                                                  masked_indices(1,i))
1795               ENDDO
1796            ENDDO
1797            !$OMP END PARALLEL
1798         ELSE
1799            ALLOCATE( values_int16_2d_resorted(1,1) )
1800            values_int16_2d_resorted = 0_1
1801         ENDIF
1802         values_int16_2d_pointer => values_int16_2d_resorted
1803      ELSEIF ( PRESENT( values_int16_3d ) )  THEN
1804         IF ( do_output ) THEN
1805            ALLOCATE( values_int16_3d_resorted(0:value_counts(1)-1, &
1806                                               0:value_counts(2)-1, &
1807                                               0:value_counts(3)-1) )
1808            !$OMP PARALLEL PRIVATE (i,j,k)
1809            !$OMP DO
1810            DO  i = 0, value_counts(1) - 1
1811               DO  j = 0, value_counts(2) - 1
1812                  DO  k = 0, value_counts(3) - 1
1813                     values_int16_3d_resorted(i,j,k) = values_int16_3d(masked_indices(3,k), &
1814                                                                       masked_indices(2,j), &
1815                                                                       masked_indices(1,i)  )
1816                  ENDDO
1817               ENDDO
1818            ENDDO
1819            !$OMP END PARALLEL
1820         ELSE
1821            ALLOCATE( values_int16_3d_resorted(1,1,1) )
1822            values_int16_3d_resorted = 0_1
1823         ENDIF
1824         values_int16_3d_pointer => values_int16_3d_resorted
1825
1826      !-- 32bit integer output
1827      ELSEIF ( PRESENT( values_int32_0d ) )  THEN
1828         values_int32_0d_pointer => values_int32_0d
1829      ELSEIF ( PRESENT( values_int32_1d ) )  THEN
1830         IF ( do_output ) THEN
1831            ALLOCATE( values_int32_1d_resorted(0:value_counts(1)-1) )
1832            !$OMP PARALLEL PRIVATE (i)
1833            !$OMP DO
1834            DO  i = 0, value_counts(1) - 1
1835               values_int32_1d_resorted(i) = values_int32_1d(masked_indices(1,i))
1836            ENDDO
1837            !$OMP END PARALLEL
1838         ELSE
1839            ALLOCATE( values_int32_1d_resorted(1) )
1840            values_int32_1d_resorted = 0_1
1841         ENDIF
1842         values_int32_1d_pointer => values_int32_1d_resorted
1843      ELSEIF ( PRESENT( values_int32_2d ) )  THEN
1844         IF ( do_output ) THEN
1845            ALLOCATE( values_int32_2d_resorted(0:value_counts(1)-1, &
1846                                               0:value_counts(2)-1) )
1847            !$OMP PARALLEL PRIVATE (i,j)
1848            !$OMP DO
1849            DO  i = 0, value_counts(1) - 1
1850               DO  j = 0, value_counts(2) - 1
1851                  values_int32_2d_resorted(i,j) = values_int32_2d(masked_indices(2,j), &
1852                                                                  masked_indices(1,i)  )
1853               ENDDO
1854            ENDDO
1855            !$OMP END PARALLEL
1856         ELSE
1857            ALLOCATE( values_int32_2d_resorted(1,1) )
1858            values_int32_2d_resorted = 0_1
1859         ENDIF
1860         values_int32_2d_pointer => values_int32_2d_resorted
1861      ELSEIF ( PRESENT( values_int32_3d ) )  THEN
1862         IF ( do_output ) THEN
1863            ALLOCATE( values_int32_3d_resorted(0:value_counts(1)-1, &
1864                                               0:value_counts(2)-1, &
1865                                               0:value_counts(3)-1) )
1866            !$OMP PARALLEL PRIVATE (i,j,k)
1867            !$OMP DO
1868            DO  i = 0, value_counts(1) - 1
1869               DO  j = 0, value_counts(2) - 1
1870                  DO  k = 0, value_counts(3) - 1
1871                     values_int32_3d_resorted(i,j,k) = values_int32_3d(masked_indices(3,k), &
1872                                                                       masked_indices(2,j), &
1873                                                                       masked_indices(1,i)  )
1874                  ENDDO
1875               ENDDO
1876            ENDDO
1877            !$OMP END PARALLEL
1878         ELSE
1879            ALLOCATE( values_int32_3d_resorted(1,1,1) )
1880            values_int32_3d_resorted = 0_1
1881         ENDIF
1882         values_int32_3d_pointer => values_int32_3d_resorted
1883
1884      !-- working-precision integer output
1885      ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
1886         values_intwp_0d_pointer => values_intwp_0d
1887      ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
1888         IF ( do_output ) THEN
1889            ALLOCATE( values_intwp_1d_resorted(0:value_counts(1)-1) )
1890            !$OMP PARALLEL PRIVATE (i)
1891            !$OMP DO
1892            DO  i = 0, value_counts(1) - 1
1893               values_intwp_1d_resorted(i) = values_intwp_1d(masked_indices(1,i))
1894            ENDDO
1895            !$OMP END PARALLEL
1896         ELSE
1897            ALLOCATE( values_intwp_1d_resorted(1) )
1898            values_intwp_1d_resorted = 0_1
1899         ENDIF
1900         values_intwp_1d_pointer => values_intwp_1d_resorted
1901      ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
1902         IF ( do_output ) THEN
1903            ALLOCATE( values_intwp_2d_resorted(0:value_counts(1)-1, &
1904                                               0:value_counts(2)-1) )
1905            !$OMP PARALLEL PRIVATE (i,j)
1906            !$OMP DO
1907            DO  i = 0, value_counts(1) - 1
1908               DO  j = 0, value_counts(2) - 1
1909                  values_intwp_2d_resorted(i,j) = values_intwp_2d(masked_indices(2,j), &
1910                                                                  masked_indices(1,i)  )
1911               ENDDO
1912            ENDDO
1913            !$OMP END PARALLEL
1914         ELSE
1915            ALLOCATE( values_intwp_2d_resorted(1,1) )
1916            values_intwp_2d_resorted = 0_1
1917         ENDIF
1918         values_intwp_2d_pointer => values_intwp_2d_resorted
1919      ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
1920         IF ( do_output ) THEN
1921            ALLOCATE( values_intwp_3d_resorted(0:value_counts(1)-1, &
1922                                               0:value_counts(2)-1, &
1923                                               0:value_counts(3)-1) )
1924            !$OMP PARALLEL PRIVATE (i,j,k)
1925            !$OMP DO
1926            DO  i = 0, value_counts(1) - 1
1927               DO  j = 0, value_counts(2) - 1
1928                  DO  k = 0, value_counts(3) - 1
1929                     values_intwp_3d_resorted(i,j,k) = values_intwp_3d(masked_indices(3,k), &
1930                                                                       masked_indices(2,j), &
1931                                                                       masked_indices(1,i)  )
1932                  ENDDO
1933               ENDDO
1934            ENDDO
1935            !$OMP END PARALLEL
1936         ELSE
1937            ALLOCATE( values_intwp_3d_resorted(1,1,1) )
1938            values_intwp_3d_resorted = 0_1
1939         ENDIF
1940         values_intwp_3d_pointer => values_intwp_3d_resorted
1941
1942      !-- 32bit real output
1943      ELSEIF ( PRESENT( values_real32_0d ) )  THEN
1944         values_real32_0d_pointer => values_real32_0d
1945      ELSEIF ( PRESENT( values_real32_1d ) )  THEN
1946         IF ( do_output ) THEN
1947            ALLOCATE( values_real32_1d_resorted(0:value_counts(1)-1) )
1948            !$OMP PARALLEL PRIVATE (i)
1949            !$OMP DO
1950            DO  i = 0, value_counts(1) - 1
1951               values_real32_1d_resorted(i) = values_real32_1d(masked_indices(1,i))
1952            ENDDO
1953            !$OMP END PARALLEL
1954         ELSE
1955            ALLOCATE( values_real32_1d_resorted(1) )
1956            values_real32_1d_resorted = 0_1
1957         ENDIF
1958         values_real32_1d_pointer => values_real32_1d_resorted
1959      ELSEIF ( PRESENT( values_real32_2d ) )  THEN
1960         IF ( do_output ) THEN
1961            ALLOCATE( values_real32_2d_resorted(0:value_counts(1)-1, &
1962                                                0:value_counts(2)-1) )
1963            !$OMP PARALLEL PRIVATE (i,j)
1964            !$OMP DO
1965            DO  i = 0, value_counts(1) - 1
1966               DO  j = 0, value_counts(2) - 1
1967                  values_real32_2d_resorted(i,j) = values_real32_2d(masked_indices(2,j), &
1968                                                                    masked_indices(1,i)  )
1969               ENDDO
1970            ENDDO
1971            !$OMP END PARALLEL
1972         ELSE
1973            ALLOCATE( values_real32_2d_resorted(1,1) )
1974            values_real32_2d_resorted = 0_1
1975         ENDIF
1976         values_real32_2d_pointer => values_real32_2d_resorted
1977      ELSEIF ( PRESENT( values_real32_3d ) )  THEN
1978         IF ( do_output ) THEN
1979            ALLOCATE( values_real32_3d_resorted(0:value_counts(1)-1, &
1980                                                0:value_counts(2)-1, &
1981                                                0:value_counts(3)-1) )
1982            !$OMP PARALLEL PRIVATE (i,j,k)
1983            !$OMP DO
1984            DO  i = 0, value_counts(1) - 1
1985               DO  j = 0, value_counts(2) - 1
1986                  DO  k = 0, value_counts(3) - 1
1987                     values_real32_3d_resorted(i,j,k) = values_real32_3d(masked_indices(3,k), &
1988                                                                         masked_indices(2,j), &
1989                                                                         masked_indices(1,i)  )
1990                  ENDDO
1991               ENDDO
1992            ENDDO
1993            !$OMP END PARALLEL
1994         ELSE
1995            ALLOCATE( values_real32_3d_resorted(1,1,1) )
1996            values_real32_3d_resorted = 0_1
1997         ENDIF
1998         values_real32_3d_pointer => values_real32_3d_resorted
1999
2000      !-- 64bit real output
2001      ELSEIF ( PRESENT( values_real64_0d ) )  THEN
2002         values_real64_0d_pointer => values_real64_0d
2003      ELSEIF ( PRESENT( values_real64_1d ) )  THEN
2004         IF ( do_output ) THEN
2005            ALLOCATE( values_real64_1d_resorted(0:value_counts(1)-1) )
2006            !$OMP PARALLEL PRIVATE (i)
2007            !$OMP DO
2008            DO  i = 0, value_counts(1) - 1
2009               values_real64_1d_resorted(i) = values_real64_1d(masked_indices(1,i))
2010            ENDDO
2011            !$OMP END PARALLEL
2012         ELSE
2013            ALLOCATE( values_real64_1d_resorted(1) )
2014            values_real64_1d_resorted = 0_1
2015         ENDIF
2016         values_real64_1d_pointer => values_real64_1d_resorted
2017      ELSEIF ( PRESENT( values_real64_2d ) )  THEN
2018         IF ( do_output ) THEN
2019            ALLOCATE( values_real64_2d_resorted(0:value_counts(1)-1, &
2020                                                0:value_counts(2)-1) )
2021            !$OMP PARALLEL PRIVATE (i,j)
2022            !$OMP DO
2023            DO  i = 0, value_counts(1) - 1
2024               DO  j = 0, value_counts(2) - 1
2025                  values_real64_2d_resorted(i,j) = values_real64_2d(masked_indices(2,j), &
2026                                                                    masked_indices(1,i)  )
2027               ENDDO
2028            ENDDO
2029            !$OMP END PARALLEL
2030         ELSE
2031            ALLOCATE( values_real64_2d_resorted(1,1) )
2032            values_real64_2d_resorted = 0_1
2033         ENDIF
2034         values_real64_2d_pointer => values_real64_2d_resorted
2035      ELSEIF ( PRESENT( values_real64_3d ) )  THEN
2036         IF ( do_output ) THEN
2037            ALLOCATE( values_real64_3d_resorted(0:value_counts(1)-1, &
2038                                                0:value_counts(2)-1, &
2039                                                0:value_counts(3)-1) )
2040            !$OMP PARALLEL PRIVATE (i,j,k)
2041            !$OMP DO
2042            DO  i = 0, value_counts(1) - 1
2043               DO  j = 0, value_counts(2) - 1
2044                  DO  k = 0, value_counts(3) - 1
2045                     values_real64_3d_resorted(i,j,k) = values_real64_3d(masked_indices(3,k), &
2046                                                                         masked_indices(2,j), &
2047                                                                         masked_indices(1,i)  )
2048                  ENDDO
2049               ENDDO
2050            ENDDO
2051            !$OMP END PARALLEL
2052         ELSE
2053            ALLOCATE( values_real64_3d_resorted(1,1,1) )
2054            values_real64_3d_resorted = 0_1
2055         ENDIF
2056         values_real64_3d_pointer => values_real64_3d_resorted
2057
2058      !-- working-precision real output
2059      ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
2060         values_realwp_0d_pointer => values_realwp_0d
2061      ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
2062         IF ( do_output ) THEN
2063            ALLOCATE( values_realwp_1d_resorted(0:value_counts(1)-1) )
2064            !$OMP PARALLEL PRIVATE (i)
2065            !$OMP DO
2066            DO  i = 0, value_counts(1) - 1
2067               values_realwp_1d_resorted(i) = values_realwp_1d(masked_indices(1,i))
2068            ENDDO
2069            !$OMP END PARALLEL
2070         ELSE
2071            ALLOCATE( values_realwp_1d_resorted(1) )
2072            values_realwp_1d_resorted = 0_1
2073         ENDIF
2074         values_realwp_1d_pointer => values_realwp_1d_resorted
2075      ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
2076         IF ( do_output ) THEN
2077            ALLOCATE( values_realwp_2d_resorted(0:value_counts(1)-1, &
2078                                                0:value_counts(2)-1) )
2079            !$OMP PARALLEL PRIVATE (i,j)
2080            !$OMP DO
2081            DO  i = 0, value_counts(1) - 1
2082               DO  j = 0, value_counts(2) - 1
2083                  values_realwp_2d_resorted(i,j) = values_realwp_2d(masked_indices(2,j), &
2084                                                                    masked_indices(1,i)  )
2085               ENDDO
2086            ENDDO
2087            !$OMP END PARALLEL
2088         ELSE
2089            ALLOCATE( values_realwp_2d_resorted(1,1) )
2090            values_realwp_2d_resorted = 0_1
2091         ENDIF
2092         values_realwp_2d_pointer => values_realwp_2d_resorted
2093      ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
2094         IF ( do_output ) THEN
2095            ALLOCATE( values_realwp_3d_resorted(0:value_counts(1)-1, &
2096                                                0:value_counts(2)-1, &
2097                                                0:value_counts(3)-1) )
2098            !$OMP PARALLEL PRIVATE (i,j,k)
2099            !$OMP DO
2100            DO  i = 0, value_counts(1) - 1
2101               DO  j = 0, value_counts(2) - 1
2102                  DO  k = 0, value_counts(3) - 1
2103                     values_realwp_3d_resorted(i,j,k) = values_realwp_3d(masked_indices(3,k), &
2104                                                                         masked_indices(2,j), &
2105                                                                         masked_indices(1,i)  )
2106                  ENDDO
2107               ENDDO
2108            ENDDO
2109            !$OMP END PARALLEL
2110         ELSE
2111            ALLOCATE( values_realwp_3d_resorted(1,1,1) )
2112            values_realwp_3d_resorted = 0_1
2113         ENDIF
2114         values_realwp_3d_pointer => values_realwp_3d_resorted
2115
[4070]2116      ELSE
[4141]2117         return_value = 1
2118         CALL internal_message( 'error', routine_name //                  &
2119                                ': no output values given ' //            &
2120                                '(variable "' // TRIM( variable_name ) // &
2121                                '", file "' // TRIM( file_name ) // '")!'  )
[4070]2122      ENDIF
[4141]2123
2124      DEALLOCATE( masked_indices )
2125
2126   ENDIF  ! Check for error
2127
2128   IF ( return_value == 0 )  THEN
2129
2130      !-- Write variable into file
2131      SELECT CASE ( TRIM( file_format ) )
2132
2133         CASE ( 'binary' )
2134            !-- 8bit integer output
2135            IF ( PRESENT( values_int8_0d ) )  THEN
2136               CALL binary_write_variable( file_id, variable_id,                      &
2137                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2138                       values_int8_0d=values_int8_0d_pointer, return_value=output_return_value )
2139            ELSEIF ( PRESENT( values_int8_1d ) )  THEN
2140               CALL binary_write_variable( file_id, variable_id,                      &
2141                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2142                       values_int8_1d=values_int8_1d_pointer, return_value=output_return_value )
2143            ELSEIF ( PRESENT( values_int8_2d ) )  THEN
2144               CALL binary_write_variable( file_id, variable_id,                      &
2145                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2146                       values_int8_2d=values_int8_2d_pointer, return_value=output_return_value )
2147            ELSEIF ( PRESENT( values_int8_3d ) )  THEN
2148               CALL binary_write_variable( file_id, variable_id,                      &
2149                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2150                       values_int8_3d=values_int8_3d_pointer, return_value=output_return_value )
2151            !-- 16bit integer output
2152            ELSEIF ( PRESENT( values_int16_0d ) )  THEN
2153               CALL binary_write_variable( file_id, variable_id,                      &
2154                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2155                       values_int16_0d=values_int16_0d_pointer, return_value=output_return_value )
2156            ELSEIF ( PRESENT( values_int16_1d ) )  THEN
2157               CALL binary_write_variable( file_id, variable_id,                      &
2158                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2159                       values_int16_1d=values_int16_1d_pointer, return_value=output_return_value )
2160            ELSEIF ( PRESENT( values_int16_2d ) )  THEN
2161               CALL binary_write_variable( file_id, variable_id,                      &
2162                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2163                       values_int16_2d=values_int16_2d_pointer, return_value=output_return_value )
2164            ELSEIF ( PRESENT( values_int16_3d ) )  THEN
2165               CALL binary_write_variable( file_id, variable_id,                      &
2166                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2167                       values_int16_3d=values_int16_3d_pointer, return_value=output_return_value )
2168            !-- 32bit integer output
2169            ELSEIF ( PRESENT( values_int32_0d ) )  THEN
2170               CALL binary_write_variable( file_id, variable_id,                      &
2171                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2172                       values_int32_0d=values_int32_0d_pointer, return_value=output_return_value )
2173            ELSEIF ( PRESENT( values_int32_1d ) )  THEN
2174               CALL binary_write_variable( file_id, variable_id,                      &
2175                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2176                       values_int32_1d=values_int32_1d_pointer, return_value=output_return_value )
2177            ELSEIF ( PRESENT( values_int32_2d ) )  THEN
2178               CALL binary_write_variable( file_id, variable_id,                      &
2179                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2180                       values_int32_2d=values_int32_2d_pointer, return_value=output_return_value )
2181            ELSEIF ( PRESENT( values_int32_3d ) )  THEN
2182               CALL binary_write_variable( file_id, variable_id,                      &
2183                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2184                       values_int32_3d=values_int32_3d_pointer, return_value=output_return_value )
2185            !-- working-precision integer output
2186            ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
2187               CALL binary_write_variable( file_id, variable_id,                      &
2188                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2189                       values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value )
2190            ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
2191               CALL binary_write_variable( file_id, variable_id,                      &
2192                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2193                       values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value )
2194            ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
2195               CALL binary_write_variable( file_id, variable_id,                      &
2196                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2197                       values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value )
2198            ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
2199               CALL binary_write_variable( file_id, variable_id,                      &
2200                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2201                       values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value )
2202            !-- 32bit real output
2203            ELSEIF ( PRESENT( values_real32_0d ) )  THEN
2204               CALL binary_write_variable( file_id, variable_id,                      &
2205                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2206                       values_real32_0d=values_real32_0d_pointer, return_value=output_return_value )
2207            ELSEIF ( PRESENT( values_real32_1d ) )  THEN
2208               CALL binary_write_variable( file_id, variable_id,                      &
2209                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2210                       values_real32_1d=values_real32_1d_pointer, return_value=output_return_value )
2211            ELSEIF ( PRESENT( values_real32_2d ) )  THEN
2212               CALL binary_write_variable( file_id, variable_id,                      &
2213                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2214                       values_real32_2d=values_real32_2d_pointer, return_value=output_return_value )
2215            ELSEIF ( PRESENT( values_real32_3d ) )  THEN
2216               CALL binary_write_variable( file_id, variable_id,                      &
2217                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2218                       values_real32_3d=values_real32_3d_pointer, return_value=output_return_value )
2219            !-- 64bit real output
2220            ELSEIF ( PRESENT( values_real64_0d ) )  THEN
2221               CALL binary_write_variable( file_id, variable_id,                      &
2222                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2223                       values_real64_0d=values_real64_0d_pointer, return_value=output_return_value )
2224            ELSEIF ( PRESENT( values_real64_1d ) )  THEN
2225               CALL binary_write_variable( file_id, variable_id,                      &
2226                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2227                       values_real64_1d=values_real64_1d_pointer, return_value=output_return_value )
2228            ELSEIF ( PRESENT( values_real64_2d ) )  THEN
2229               CALL binary_write_variable( file_id, variable_id,                      &
2230                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2231                       values_real64_2d=values_real64_2d_pointer, return_value=output_return_value )
2232            ELSEIF ( PRESENT( values_real64_3d ) )  THEN
2233               CALL binary_write_variable( file_id, variable_id,                      &
2234                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2235                       values_real64_3d=values_real64_3d_pointer, return_value=output_return_value )
2236            !-- working-precision real output
2237            ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
2238               CALL binary_write_variable( file_id, variable_id,                      &
2239                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2240                       values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value )
2241            ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
2242               CALL binary_write_variable( file_id, variable_id,                      &
2243                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2244                       values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value )
2245            ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
2246               CALL binary_write_variable( file_id, variable_id,                      &
2247                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2248                       values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value )
2249            ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
2250               CALL binary_write_variable( file_id, variable_id,                      &
2251                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2252                       values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value )
2253            ELSE
2254               return_value = 1
2255               CALL internal_message( 'error', routine_name //                          &
2256                                      ': output_type not supported by file format "' // &
2257                                      TRIM( file_format ) // '" ' //                    &
2258                                      '(variable "' // TRIM( variable_name ) //         &
2259                                      '", file "' // TRIM( file_name ) // '")!' )
2260            ENDIF
2261
2262         CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
2263            !-- 8bit integer output
2264            IF ( PRESENT( values_int8_0d ) )  THEN
2265               CALL netcdf4_write_variable( file_id, variable_id,                     &
2266                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2267                       values_int8_0d=values_int8_0d_pointer, return_value=output_return_value )
2268            ELSEIF ( PRESENT( values_int8_1d ) )  THEN
2269               CALL netcdf4_write_variable( file_id, variable_id,                     &
2270                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2271                       values_int8_1d=values_int8_1d_pointer, return_value=output_return_value )
2272            ELSEIF ( PRESENT( values_int8_2d ) )  THEN
2273               CALL netcdf4_write_variable( file_id, variable_id,                     &
2274                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2275                       values_int8_2d=values_int8_2d_pointer, return_value=output_return_value )
2276            ELSEIF ( PRESENT( values_int8_3d ) )  THEN
2277               CALL netcdf4_write_variable( file_id, variable_id,                     &
2278                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2279                       values_int8_3d=values_int8_3d_pointer, return_value=output_return_value )
2280            !-- 16bit integer output
2281            ELSEIF ( PRESENT( values_int16_0d ) )  THEN
2282               CALL netcdf4_write_variable( file_id, variable_id,                     &
2283                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2284                       values_int16_0d=values_int16_0d_pointer, return_value=output_return_value )
2285            ELSEIF ( PRESENT( values_int16_1d ) )  THEN
2286               CALL netcdf4_write_variable( file_id, variable_id,                     &
2287                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2288                       values_int16_1d=values_int16_1d_pointer, return_value=output_return_value )
2289            ELSEIF ( PRESENT( values_int16_2d ) )  THEN
2290               CALL netcdf4_write_variable( file_id, variable_id,                     &
2291                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2292                       values_int16_2d=values_int16_2d_pointer, return_value=output_return_value )
2293            ELSEIF ( PRESENT( values_int16_3d ) )  THEN
2294               CALL netcdf4_write_variable( file_id, variable_id,                     &
2295                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2296                       values_int16_3d=values_int16_3d_pointer, return_value=output_return_value )
2297            !-- 32bit integer output
2298            ELSEIF ( PRESENT( values_int32_0d ) )  THEN
2299               CALL netcdf4_write_variable( file_id, variable_id,                     &
2300                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2301                       values_int32_0d=values_int32_0d_pointer, return_value=output_return_value )
2302            ELSEIF ( PRESENT( values_int32_1d ) )  THEN
2303               CALL netcdf4_write_variable( file_id, variable_id,                     &
2304                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2305                       values_int32_1d=values_int32_1d_pointer, return_value=output_return_value )
2306            ELSEIF ( PRESENT( values_int32_2d ) )  THEN
2307               CALL netcdf4_write_variable( file_id, variable_id,                     &
2308                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2309                       values_int32_2d=values_int32_2d_pointer, return_value=output_return_value )
2310            ELSEIF ( PRESENT( values_int32_3d ) )  THEN
2311               CALL netcdf4_write_variable( file_id, variable_id,                     &
2312                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2313                       values_int32_3d=values_int32_3d_pointer, return_value=output_return_value )
2314            !-- working-precision integer output
2315            ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
2316               CALL netcdf4_write_variable( file_id, variable_id,                     &
2317                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2318                       values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value )
2319            ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
2320               CALL netcdf4_write_variable( file_id, variable_id,                     &
2321                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2322                       values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value )
2323            ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
2324               CALL netcdf4_write_variable( file_id, variable_id,                     &
2325                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2326                       values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value )
2327            ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
2328               CALL netcdf4_write_variable( file_id, variable_id,                     &
2329                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2330                       values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value )
2331            !-- 32bit real output
2332            ELSEIF ( PRESENT( values_real32_0d ) )  THEN
2333               CALL netcdf4_write_variable( file_id, variable_id,                     &
2334                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2335                       values_real32_0d=values_real32_0d_pointer, return_value=output_return_value )
2336            ELSEIF ( PRESENT( values_real32_1d ) )  THEN
2337               CALL netcdf4_write_variable( file_id, variable_id,                     &
2338                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2339                       values_real32_1d=values_real32_1d_pointer, return_value=output_return_value )
2340            ELSEIF ( PRESENT( values_real32_2d ) )  THEN
2341               CALL netcdf4_write_variable( file_id, variable_id,                     &
2342                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2343                       values_real32_2d=values_real32_2d_pointer, return_value=output_return_value )
2344            ELSEIF ( PRESENT( values_real32_3d ) )  THEN
2345               CALL netcdf4_write_variable( file_id, variable_id,                     &
2346                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2347                       values_real32_3d=values_real32_3d_pointer, return_value=output_return_value )
2348            !-- 64bit real output
2349            ELSEIF ( PRESENT( values_real64_0d ) )  THEN
2350               CALL netcdf4_write_variable( file_id, variable_id,                     &
2351                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2352                       values_real64_0d=values_real64_0d_pointer, return_value=output_return_value )
2353            ELSEIF ( PRESENT( values_real64_1d ) )  THEN
2354               CALL netcdf4_write_variable( file_id, variable_id,                     &
2355                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2356                       values_real64_1d=values_real64_1d_pointer, return_value=output_return_value )
2357            ELSEIF ( PRESENT( values_real64_2d ) )  THEN
2358               CALL netcdf4_write_variable( file_id, variable_id,                     &
2359                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2360                       values_real64_2d=values_real64_2d_pointer, return_value=output_return_value )
2361            ELSEIF ( PRESENT( values_real64_3d ) )  THEN
2362               CALL netcdf4_write_variable( file_id, variable_id,                     &
2363                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2364                       values_real64_3d=values_real64_3d_pointer, return_value=output_return_value )
2365            !-- working-precision real output
2366            ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
2367               CALL netcdf4_write_variable( file_id, variable_id,                     &
2368                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2369                       values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value )
2370            ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
2371               CALL netcdf4_write_variable( file_id, variable_id,                     &
2372                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2373                       values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value )
2374            ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
2375               CALL netcdf4_write_variable( file_id, variable_id,                     &
2376                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2377                       values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value )
2378            ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
2379               CALL netcdf4_write_variable( file_id, variable_id,                     &
2380                       bounds_start_internal, value_counts, bounds_origin, is_global, &
2381                       values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value )
2382            ELSE
2383               return_value = 1
2384               CALL internal_message( 'error', routine_name //                          &
2385                                      ': output_type not supported by file format "' // &
2386                                      TRIM( file_format ) // '" ' //                    &
2387                                      '(variable "' // TRIM( variable_name ) //         &
2388                                      '", file "' // TRIM( file_name ) // '")!' )
2389            ENDIF
2390
2391         CASE DEFAULT
2392            return_value = 1
2393            CALL internal_message( 'error', routine_name //                    &
2394                                   ': file format "' // TRIM( file_format ) // &
2395                                   '" not supported ' //                       &
2396                                   '(variable "' // TRIM( variable_name ) //   &
2397                                   '", file "' // TRIM( file_name ) // '")!' )
2398
2399      END SELECT
2400
2401      IF ( return_value == 0  .AND.  output_return_value /= 0 )  THEN
2402         return_value = 1
2403         CALL internal_message( 'error', routine_name //                  &
2404                                ': error while writing variable ' //      &
2405                                '(variable "' // TRIM( variable_name ) // &
2406                                '", file "' // TRIM( file_name ) // '")!' )
2407      ENDIF
2408
[4070]2409   ENDIF
2410
[4141]2411END FUNCTION dom_write_var
[4070]2412
2413!--------------------------------------------------------------------------------------------------!
2414! Description:
2415! ------------
[4141]2416!> Finalize output.
2417!> All necessary steps are carried out to close all output files. If a file could not be closed,
2418!> this is noted in the error message.
2419!>
2420!> @bug if multiple files failed to be closed, only the last failure is given in the error message.
2421!--------------------------------------------------------------------------------------------------!
2422FUNCTION dom_finalize_output() RESULT( return_value )
2423
2424   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_finalize_output'  !< name of routine
2425
2426   INTEGER ::  f                      !< loop index
2427   INTEGER ::  output_return_value    !< return value from called routines
2428   INTEGER ::  return_value           !< return value
2429   INTEGER ::  return_value_internal  !< error code after closing a single file
2430
2431
2432   return_value = 0
2433
2434   DO  f = 1, nfiles
2435
2436      IF ( files(f)%is_init )  THEN
2437
2438         output_return_value = 0
2439         return_value_internal = 0
2440
2441         SELECT CASE ( TRIM( files(f)%format ) )
2442
2443            CASE ( 'binary' )
2444               CALL binary_finalize( files(f)%id, output_return_value )
2445
2446            CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
2447               CALL netcdf4_finalize( files(f)%id, output_return_value )
2448
2449            CASE DEFAULT
2450               return_value_internal = 1
2451
2452         END SELECT
2453
2454         IF ( output_return_value /= 0 )  THEN
2455            return_value = output_return_value
2456            CALL internal_message( 'error', routine_name //             &
2457                                   ': error while finalizing file "' // &
2458                                   TRIM( files(f)%name ) // '"' )
2459         ELSEIF ( return_value_internal /= 0 )  THEN
2460            return_value = return_value_internal
2461            CALL internal_message( 'error', routine_name //                     &
2462                                   ': unsupported file format "' //             &
2463                                   TRIM( files(f)%format ) // '" for file "' // &
2464                                   TRIM( files(f)%name ) // '"' )
2465         ENDIF
2466
2467      ENDIF
2468
2469   ENDDO
2470
2471END FUNCTION dom_finalize_output
2472
2473!--------------------------------------------------------------------------------------------------!
2474! Description:
2475! ------------
2476!> Return the last created error message.
2477!--------------------------------------------------------------------------------------------------!
2478FUNCTION dom_get_error_message() RESULT( error_message )
2479
2480   CHARACTER(LEN=800) ::  error_message  !< return error message to main program
2481
2482
2483   error_message = TRIM( internal_error_message )
2484
2485   error_message = TRIM( error_message ) // TRIM( binary_get_error_message() )
2486   
2487   error_message = TRIM( error_message ) // TRIM( netcdf4_get_error_message() )
2488   
2489   internal_error_message = ''
2490
2491END FUNCTION dom_get_error_message
2492
2493!--------------------------------------------------------------------------------------------------!
2494! Description:
2495! ------------
[4070]2496!> Add attribute to database.
2497!>
2498!> @todo Try to combine similar code parts and shorten routine.
2499!--------------------------------------------------------------------------------------------------!
[4141]2500FUNCTION save_attribute_in_database( file_name, variable_name, attribute, append ) &
2501            RESULT( return_value )
[4070]2502
[4141]2503   CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< name of file
2504   CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
[4070]2505
[4141]2506   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'save_attribute_in_database'  !< name of routine
[4070]2507
[4141]2508   INTEGER ::  a             !< loop index
2509   INTEGER ::  d             !< loop index
2510   INTEGER ::  f             !< loop index
2511   INTEGER ::  natts         !< number of attributes
2512   INTEGER ::  return_value  !< return value
[4070]2513
2514   LOGICAL             ::  found   !< true if variable or dimension of name 'variable_name' found
2515   LOGICAL, INTENT(IN) ::  append  !< if true, append value to existing value
2516
2517   TYPE(attribute_type), INTENT(IN) ::  attribute  !< new attribute
2518
2519   TYPE(attribute_type), DIMENSION(:), ALLOCATABLE ::  atts_tmp  !< temporary attribute list
2520
2521
2522   return_value = 0
2523   found = .FALSE.
2524
[4141]2525   CALL internal_message( 'debug', routine_name //                            &
2526                          ': define attribute "' // TRIM( attribute%name ) // &
2527                          '" of variable "' // TRIM( variable_name ) //       &
2528                          '" in file "' // TRIM( file_name ) // '"' )
[4116]2529
[4141]2530   DO  f = 1, nfiles
[4070]2531
[4141]2532      IF ( TRIM( file_name ) == files(f)%name )  THEN
[4070]2533
[4106]2534         IF ( files(f)%is_init )  THEN
2535            return_value = 1
[4141]2536            CALL internal_message( 'error', routine_name // ': file "' // TRIM( file_name ) // &
[4106]2537                    '" is already initialized. No further attribute definition allowed!' )
2538            EXIT
2539         ENDIF
2540
[4070]2541         !-- Add attribute to file
[4141]2542         IF ( TRIM( variable_name ) == '' )  THEN
[4070]2543
2544            !-- Initialize first file attribute
2545            IF ( .NOT. ALLOCATED( files(f)%attributes ) )  THEN
[4141]2546               natts = 1
2547               ALLOCATE( files(f)%attributes(natts) )
[4070]2548            ELSE
[4141]2549               natts = SIZE( files(f)%attributes )
[4070]2550
2551               !-- Check if attribute already exists
[4141]2552               DO  a = 1, natts
[4070]2553                  IF ( files(f)%attributes(a)%name == attribute%name )  THEN
2554                     IF ( append )  THEN
2555                        !-- Append existing string attribute
2556                        files(f)%attributes(a)%value_char =             &
2557                           TRIM( files(f)%attributes(a)%value_char ) // &
2558                           TRIM( attribute%value_char )
2559                     ELSE
2560                        files(f)%attributes(a) = attribute
2561                     ENDIF
2562                     found = .TRUE.
2563                     EXIT
2564                  ENDIF
2565               ENDDO
2566
2567               !-- Extend attribute list by 1
2568               IF ( .NOT. found )  THEN
[4141]2569                  ALLOCATE( atts_tmp(natts) )
[4070]2570                  atts_tmp = files(f)%attributes
2571                  DEALLOCATE( files(f)%attributes )
[4141]2572                  natts = natts + 1
2573                  ALLOCATE( files(f)%attributes(natts) )
2574                  files(f)%attributes(:natts-1) = atts_tmp
[4070]2575                  DEALLOCATE( atts_tmp )
2576               ENDIF
2577            ENDIF
2578
2579            !-- Save new attribute to the end of the attribute list
2580            IF ( .NOT. found )  THEN
[4141]2581               files(f)%attributes(natts) = attribute
[4070]2582               found = .TRUE.
2583            ENDIF
2584
2585            EXIT
2586
2587         ELSE
2588
2589            !-- Add attribute to dimension
2590            IF ( ALLOCATED( files(f)%dimensions ) )  THEN
2591
2592               DO  d = 1, SIZE( files(f)%dimensions )
2593
2594                  IF ( files(f)%dimensions(d)%name == TRIM( variable_name ) )  THEN
2595
2596                     IF ( .NOT. ALLOCATED( files(f)%dimensions(d)%attributes ) )  THEN
2597                        !-- Initialize first attribute
[4141]2598                        natts = 1
2599                        ALLOCATE( files(f)%dimensions(d)%attributes(natts) )
[4070]2600                     ELSE
[4141]2601                        natts = SIZE( files(f)%dimensions(d)%attributes )
[4070]2602
2603                        !-- Check if attribute already exists
[4141]2604                        DO  a = 1, natts
[4106]2605                           IF ( files(f)%dimensions(d)%attributes(a)%name == attribute%name ) &
2606                           THEN
[4070]2607                              IF ( append )  THEN
2608                                 !-- Append existing character attribute
2609                                 files(f)%dimensions(d)%attributes(a)%value_char =             &
2610                                    TRIM( files(f)%dimensions(d)%attributes(a)%value_char ) // &
2611                                    TRIM( attribute%value_char )
2612                              ELSE
2613                                 !-- Update existing attribute
2614                                 files(f)%dimensions(d)%attributes(a) = attribute
2615                              ENDIF
2616                              found = .TRUE.
2617                              EXIT
2618                           ENDIF
2619                        ENDDO
2620
2621                        !-- Extend attribute list
2622                        IF ( .NOT. found )  THEN
[4141]2623                           ALLOCATE( atts_tmp(natts) )
[4070]2624                           atts_tmp = files(f)%dimensions(d)%attributes
2625                           DEALLOCATE( files(f)%dimensions(d)%attributes )
[4141]2626                           natts = natts + 1
2627                           ALLOCATE( files(f)%dimensions(d)%attributes(natts) )
2628                           files(f)%dimensions(d)%attributes(:natts-1) = atts_tmp
[4070]2629                           DEALLOCATE( atts_tmp )
2630                        ENDIF
2631                     ENDIF
2632
2633                     !-- Add new attribute to database
2634                     IF ( .NOT. found )  THEN
[4141]2635                        files(f)%dimensions(d)%attributes(natts) = attribute
[4070]2636                        found = .TRUE.
2637                     ENDIF
2638
2639                     EXIT
2640
2641                  ENDIF  ! dimension found
2642
2643               ENDDO  ! loop over dimensions
2644
2645            ENDIF  ! dimensions exist in file
2646
2647            !-- Add attribute to variable
2648            IF ( .NOT. found  .AND.  ALLOCATED( files(f)%variables) )  THEN
2649
2650               DO  d = 1, SIZE( files(f)%variables )
2651
2652                  IF ( files(f)%variables(d)%name == TRIM( variable_name ) )  THEN
2653
2654                     IF ( .NOT. ALLOCATED( files(f)%variables(d)%attributes ) )  THEN
2655                        !-- Initialize first attribute
[4141]2656                        natts = 1
2657                        ALLOCATE( files(f)%variables(d)%attributes(natts) )
[4070]2658                     ELSE
[4141]2659                        natts = SIZE( files(f)%variables(d)%attributes )
[4070]2660
2661                        !-- Check if attribute already exists
[4141]2662                        DO  a = 1, natts
[4106]2663                           IF ( files(f)%variables(d)%attributes(a)%name == attribute%name )  &
2664                           THEN
[4070]2665                              IF ( append )  THEN
2666                                 !-- Append existing character attribute
2667                                 files(f)%variables(d)%attributes(a)%value_char =             &
2668                                    TRIM( files(f)%variables(d)%attributes(a)%value_char ) // &
2669                                    TRIM( attribute%value_char )
2670                              ELSE
2671                                 !-- Update existing attribute
2672                                 files(f)%variables(d)%attributes(a) = attribute
2673                              ENDIF
2674                              found = .TRUE.
2675                              EXIT
2676                           ENDIF
2677                        ENDDO
2678
2679                        !-- Extend attribute list
2680                        IF ( .NOT. found )  THEN
[4141]2681                           ALLOCATE( atts_tmp(natts) )
[4070]2682                           atts_tmp = files(f)%variables(d)%attributes
2683                           DEALLOCATE( files(f)%variables(d)%attributes )
[4141]2684                           natts = natts + 1
2685                           ALLOCATE( files(f)%variables(d)%attributes(natts) )
2686                           files(f)%variables(d)%attributes(:natts-1) = atts_tmp
[4070]2687                           DEALLOCATE( atts_tmp )
2688                        ENDIF
2689
2690                     ENDIF
2691
2692                     !-- Add new attribute to database
2693                     IF ( .NOT. found )  THEN
[4141]2694                        files(f)%variables(d)%attributes(natts) = attribute
[4070]2695                        found = .TRUE.
2696                     ENDIF
2697
2698                     EXIT
2699
2700                  ENDIF  ! variable found
2701
2702               ENDDO  ! loop over variables
2703
2704            ENDIF  ! variables exist in file
2705
2706            IF ( .NOT. found )  THEN
2707               return_value = 1
2708               CALL internal_message( 'error',                                        &
2709                       routine_name //                                                &
2710                       ': requested dimension/variable "' // TRIM( variable_name ) // &
2711                       '" for attribute "' // TRIM( attribute%name ) //               &
[4141]2712                       '" does not exist in file "' // TRIM( file_name ) // '"' )
[4070]2713            ENDIF
2714
2715            EXIT
2716
[4141]2717         ENDIF  ! variable_name not empty
[4070]2718
[4141]2719      ENDIF  ! check file_name
[4070]2720
2721   ENDDO  ! loop over files
2722
2723   IF ( .NOT. found  .AND.  return_value == 0 )  THEN
2724      return_value = 1
2725      CALL internal_message( 'error',                                         &
2726                             routine_name //                                  &
[4141]2727                             ': requested file "' // TRIM( file_name ) //     &
[4070]2728                             '" for attribute "' // TRIM( attribute%name ) // &
2729                             '" does not exist' )
2730   ENDIF
2731
[4141]2732END FUNCTION save_attribute_in_database
[4070]2733
2734!--------------------------------------------------------------------------------------------------!
2735! Description:
2736! ------------
2737!> Check database and delete any unused dimensions and empty files (i.e. files
2738!> without variables).
2739!--------------------------------------------------------------------------------------------------!
2740FUNCTION cleanup_database() RESULT( return_value )
2741
2742   ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'cleanup_database'  !< name of routine
2743
[4141]2744   INTEGER ::  d             !< loop index
2745   INTEGER ::  f             !< loop index
2746   INTEGER ::  i             !< loop index
2747   INTEGER ::  ndims         !< number of dimensions in a file
2748   INTEGER ::  ndims_used    !< number of used dimensions in a file
2749   INTEGER ::  nfiles_used   !< number of used files
2750   INTEGER ::  nvars         !< number of variables in a file
2751   INTEGER ::  return_value  !< return value
[4070]2752
[4141]2753   LOGICAL, DIMENSION(1:nfiles)             ::  file_is_used       !< true if file contains variables
2754   LOGICAL, DIMENSION(:),       ALLOCATABLE ::  dimension_is_used  !< true if dimension is used by any variable
[4070]2755
2756   TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  used_dimensions  !< list of used dimensions
2757
2758   TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  used_files  !< list of used files
2759
2760
2761   return_value = 0
2762
[4106]2763   !-- Flag files which contain output variables as used
[4070]2764   file_is_used(:) = .FALSE.
[4141]2765   DO  f = 1, nfiles
[4070]2766      IF ( ALLOCATED( files(f)%variables ) )  THEN
2767         file_is_used(f) = .TRUE.
2768      ENDIF
2769   ENDDO
2770
2771   !-- Copy flagged files into temporary list
[4141]2772   nfiles_used = COUNT( file_is_used )
2773   ALLOCATE( used_files(nfiles_used) )
[4070]2774   i = 0
[4141]2775   DO  f = 1, nfiles
[4070]2776      IF ( file_is_used(f) )  THEN
2777         i = i + 1
2778         used_files(i) = files(f)
2779      ENDIF
2780   ENDDO
2781
2782   !-- Replace file list with list of used files
2783   DEALLOCATE( files )
[4141]2784   nfiles = nfiles_used
2785   ALLOCATE( files(nfiles) )
[4070]2786   files = used_files
2787   DEALLOCATE( used_files )
2788
2789   !-- Check every file for unused dimensions
[4141]2790   DO  f = 1, nfiles
[4070]2791
[4106]2792      !-- If a file is already initialized, it was already checked previously
2793      IF ( files(f)%is_init )  CYCLE
2794
[4070]2795      !-- Get number of defined dimensions
[4141]2796      ndims = SIZE( files(f)%dimensions )
2797      ALLOCATE( dimension_is_used(ndims) )
[4070]2798
2799      !-- Go through all variables and flag all used dimensions
[4141]2800      nvars = SIZE( files(f)%variables )
2801      DO  d = 1, ndims
2802         DO  i = 1, nvars
[4070]2803            dimension_is_used(d) = &
2804               ANY( files(f)%dimensions(d)%name == files(f)%variables(i)%dimension_names )
2805            IF ( dimension_is_used(d) )  EXIT
2806         ENDDO
2807      ENDDO
2808
2809      !-- Copy used dimensions to temporary list
[4141]2810      ndims_used = COUNT( dimension_is_used )
2811      ALLOCATE( used_dimensions(ndims_used) )
[4070]2812      i = 0
[4141]2813      DO  d = 1, ndims
[4070]2814         IF ( dimension_is_used(d) )  THEN
2815            i = i + 1
2816            used_dimensions(i) = files(f)%dimensions(d)
2817         ENDIF
2818      ENDDO
2819
2820      !-- Replace dimension list with list of used dimensions
2821      DEALLOCATE( files(f)%dimensions )
[4141]2822      ndims = ndims_used
2823      ALLOCATE( files(f)%dimensions(ndims) )
[4070]2824      files(f)%dimensions = used_dimensions
2825      DEALLOCATE( used_dimensions )
2826      DEALLOCATE( dimension_is_used )
2827
2828   ENDDO
2829
2830END FUNCTION cleanup_database
2831
2832!--------------------------------------------------------------------------------------------------!
2833! Description:
2834! ------------
2835!> Open requested output file.
2836!--------------------------------------------------------------------------------------------------!
[4141]2837SUBROUTINE open_output_file( file_format, file_name, file_id, return_value )
[4070]2838
2839   CHARACTER(LEN=*), INTENT(IN) ::  file_format  !< file format chosen for file
[4141]2840   CHARACTER(LEN=*), INTENT(IN) ::  file_name    !< name of file to be checked
[4070]2841
2842   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'open_output_file'  !< name of routine
2843
[4141]2844   INTEGER, INTENT(OUT) ::  file_id              !< file ID
2845   INTEGER              ::  output_return_value  !< return value of a called output routine
2846   INTEGER, INTENT(OUT) ::  return_value         !< return value
[4070]2847
2848
[4106]2849   return_value = 0
2850   output_return_value = 0
[4070]2851
2852   SELECT CASE ( TRIM( file_format ) )
2853
2854      CASE ( 'binary' )
[4141]2855         CALL binary_open_file( 'binary', file_name, file_id, output_return_value )
[4070]2856
2857      CASE ( 'netcdf4-serial' )
[4141]2858         CALL netcdf4_open_file( 'serial', file_name, file_id, output_return_value )
[4070]2859
2860      CASE ( 'netcdf4-parallel' )
[4141]2861         CALL netcdf4_open_file( 'parallel', file_name, file_id, output_return_value )
[4070]2862
2863      CASE DEFAULT
2864         return_value = 1
2865
2866   END SELECT
2867
[4106]2868   IF ( output_return_value /= 0 )  THEN
2869      return_value = output_return_value
2870      CALL internal_message( 'error', routine_name // &
[4141]2871                             ': error while opening file "' // TRIM( file_name ) // '"' )
[4106]2872   ELSEIF ( return_value /= 0 )  THEN
[4141]2873      CALL internal_message( 'error', routine_name //                     &
2874                             ': file "' // TRIM( file_name ) //           &
2875                             '": file format "' // TRIM( file_format ) // &
2876                             '" not supported' )
[4106]2877   ENDIF
[4070]2878
2879END SUBROUTINE open_output_file
2880
2881!--------------------------------------------------------------------------------------------------!
2882! Description:
2883! ------------
[4141]2884!> Initialize attributes, dimensions and variables in a file.
[4070]2885!--------------------------------------------------------------------------------------------------!
[4141]2886SUBROUTINE init_file_header( file, return_value )
[4070]2887
[4141]2888   ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'init_file_header'  !< name of routine
[4070]2889
[4141]2890   INTEGER              ::  a             !< loop index
2891   INTEGER              ::  d             !< loop index
2892   INTEGER, INTENT(OUT) ::  return_value  !< return value
[4070]2893
2894   TYPE(file_type), INTENT(INOUT) ::  file  !< initialize header of this file
2895
2896
2897   return_value  = 0
2898
2899   !-- Write file attributes
2900   IF ( ALLOCATED( file%attributes ) )  THEN
2901      DO  a = 1, SIZE( file%attributes )
[4141]2902         return_value = write_attribute( file%format, file%id, file%name,     &
2903                                         variable_id=no_id, variable_name='', &
[4106]2904                                         attribute=file%attributes(a) )
[4070]2905         IF ( return_value /= 0 )  EXIT
2906      ENDDO
2907   ENDIF
2908
2909   IF ( return_value == 0 )  THEN
2910
2911      !-- Initialize file dimensions
2912      DO  d = 1, SIZE( file%dimensions )
2913
2914         IF ( .NOT. file%dimensions(d)%is_masked )  THEN
2915
2916            !-- Initialize non-masked dimension
[4141]2917            CALL init_file_dimension( file%format, file%id, file%name,       &
2918                    file%dimensions(d)%id, file%dimensions(d)%name,          &
2919                    file%dimensions(d)%data_type, file%dimensions(d)%length, &
2920                    file%dimensions(d)%variable_id, return_value )
[4070]2921
2922         ELSE
2923
2924            !-- Initialize masked dimension
[4141]2925            CALL init_file_dimension( file%format, file%id, file%name,            &
2926                    file%dimensions(d)%id, file%dimensions(d)%name,               &
2927                    file%dimensions(d)%data_type, file%dimensions(d)%length_mask, &
2928                    file%dimensions(d)%variable_id, return_value )
[4070]2929
2930         ENDIF
2931
2932         IF ( return_value == 0  .AND.  ALLOCATED( file%dimensions(d)%attributes ) )  THEN
2933            !-- Write dimension attributes
2934            DO  a = 1, SIZE( file%dimensions(d)%attributes )
[4106]2935               return_value = write_attribute( file%format, file%id, file%name, &
[4141]2936                                 variable_id=file%dimensions(d)%variable_id,    &
2937                                 variable_name=file%dimensions(d)%name,         &
[4070]2938                                 attribute=file%dimensions(d)%attributes(a) )
2939               IF ( return_value /= 0 )  EXIT
2940            ENDDO
2941         ENDIF
2942
2943         IF ( return_value /= 0 )  EXIT
2944
2945      ENDDO
2946
2947      !-- Save dimension IDs for variables wihtin database
2948      IF ( return_value == 0 )  &
[4141]2949         CALL collect_dimesion_ids_for_variables( file%name, file%variables, file%dimensions, &
2950                                                  return_value )
[4070]2951
2952      !-- Initialize file variables
2953      IF ( return_value == 0 )  THEN
2954         DO  d = 1, SIZE( file%variables )
2955
[4106]2956            CALL init_file_variable( file%format, file%id, file%name,                          &
2957                    file%variables(d)%id, file%variables(d)%name, file%variables(d)%data_type, &
2958                    file%variables(d)%dimension_ids,                                           &
2959                    file%variables(d)%is_global, return_value )
[4070]2960
2961            IF ( return_value == 0  .AND.  ALLOCATED( file%variables(d)%attributes ) )  THEN
[4113]2962               !-- Write variable attributes
[4070]2963               DO  a = 1, SIZE( file%variables(d)%attributes )
[4106]2964                  return_value = write_attribute( file%format, file%id, file%name, &
[4141]2965                                    variable_id=file%variables(d)%id,              &
2966                                    variable_name=file%variables(d)%name,          &
[4070]2967                                    attribute=file%variables(d)%attributes(a) )
2968                  IF ( return_value /= 0 )  EXIT
2969               ENDDO
2970            ENDIF
2971
2972            IF ( return_value /= 0 )  EXIT
2973
2974         ENDDO
2975      ENDIF
2976
2977   ENDIF
2978
[4141]2979END SUBROUTINE init_file_header
[4070]2980
2981!--------------------------------------------------------------------------------------------------!
2982! Description:
2983! ------------
[4141]2984!> Initialize dimension in file.
2985!--------------------------------------------------------------------------------------------------!
2986SUBROUTINE init_file_dimension( file_format, file_id, file_name,              &
2987              dimension_id, dimension_name, dimension_type, dimension_length, &
2988              variable_id, return_value )
2989
2990   CHARACTER(LEN=*), INTENT(IN) ::  dimension_name  !< name of dimension
2991   CHARACTER(LEN=*), INTENT(IN) ::  dimension_type  !< data type of dimension
2992   CHARACTER(LEN=*), INTENT(IN) ::  file_format     !< file format chosen for file
2993   CHARACTER(LEN=*), INTENT(IN) ::  file_name       !< name of file
2994
2995   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'init_file_dimension'  !< file format chosen for file
2996
2997   INTEGER, INTENT(OUT) ::  dimension_id         !< dimension ID
2998   INTEGER, INTENT(IN)  ::  dimension_length     !< length of dimension
2999   INTEGER, INTENT(IN)  ::  file_id              !< file ID
3000   INTEGER              ::  output_return_value  !< return value of a called output routine
3001   INTEGER, INTENT(OUT) ::  return_value         !< return value
3002   INTEGER, INTENT(OUT) ::  variable_id          !< associated variable ID
3003
3004
3005   return_value = 0
3006   output_return_value = 0
3007
3008   temp_string = '(file "' // TRIM( file_name ) // &
3009                 '", dimension "' // TRIM( dimension_name ) // '")'
3010
3011   SELECT CASE ( TRIM( file_format ) )
3012
3013      CASE ( 'binary' )
3014         CALL binary_init_dimension( 'binary', file_id, dimension_id, variable_id, &
3015                 dimension_name, dimension_type, dimension_length,                 &
3016                 return_value=output_return_value )
3017
3018      CASE ( 'netcdf4-serial' )
3019         CALL netcdf4_init_dimension( 'serial', file_id, dimension_id, variable_id, &
3020                 dimension_name, dimension_type, dimension_length,                  &
3021                 return_value=output_return_value )
3022
3023      CASE ( 'netcdf4-parallel' )
3024         CALL netcdf4_init_dimension( 'parallel', file_id, dimension_id, variable_id, &
3025                 dimension_name, dimension_type, dimension_length,                    &
3026                 return_value=output_return_value )
3027
3028      CASE DEFAULT
3029         return_value = 1
3030         CALL internal_message( 'error', routine_name //                    &
3031                                ': file format "' // TRIM( file_format ) // &
3032                                '" not supported ' // TRIM( temp_string ) )
3033
3034   END SELECT
3035
3036   IF ( output_return_value /= 0 )  THEN
3037      return_value = output_return_value
3038      CALL internal_message( 'error', routine_name // &
3039                             ': error while defining dimension ' // TRIM( temp_string ) )
3040   ENDIF
3041
3042END SUBROUTINE init_file_dimension
3043
3044!--------------------------------------------------------------------------------------------------!
3045! Description:
3046! ------------
3047!> Initialize variable.
3048!--------------------------------------------------------------------------------------------------!
3049SUBROUTINE init_file_variable( file_format, file_id, file_name,        &
3050                               variable_id, variable_name, variable_type, dimension_ids, &
3051                               is_global, return_value )
3052
3053   CHARACTER(LEN=*), INTENT(IN) ::  file_format    !< file format chosen for file
3054   CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< file name
3055   CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
3056   CHARACTER(LEN=*), INTENT(IN) ::  variable_type  !< data type of variable
3057
3058   CHARACTER(LEN=*), PARAMETER ::  routine_name = 'init_file_variable'  !< file format chosen for file
3059
3060   INTEGER, INTENT(IN)  ::  file_id              !< file ID
3061   INTEGER              ::  output_return_value  !< return value of a called output routine
3062   INTEGER, INTENT(OUT) ::  return_value         !< return value
3063   INTEGER, INTENT(OUT) ::  variable_id          !< variable ID
3064
3065   INTEGER, DIMENSION(:), INTENT(IN) ::  dimension_ids  !< list of dimension IDs used by variable
3066
3067   LOGICAL, INTENT(IN)  ::  is_global  !< true if variable is global
3068
3069
3070   return_value = 0
3071   output_return_value = 0
3072
3073   temp_string = '(file "' // TRIM( file_name ) // &
3074                 '", variable "' // TRIM( variable_name ) // '")'
3075
3076   SELECT CASE ( TRIM( file_format ) )
3077
3078      CASE ( 'binary' )
3079         CALL binary_init_variable( 'binary', file_id, variable_id, variable_name, &
3080                 variable_type, dimension_ids, is_global, return_value=output_return_value )
3081
3082      CASE ( 'netcdf4-serial' )
3083         CALL netcdf4_init_variable( 'serial', file_id, variable_id, variable_name, &
3084                 variable_type, dimension_ids, is_global, return_value=output_return_value )
3085
3086      CASE ( 'netcdf4-parallel' )
3087         CALL netcdf4_init_variable( 'parallel', file_id, variable_id, variable_name, &
3088                 variable_type, dimension_ids, is_global, return_value=output_return_value )
3089
3090      CASE DEFAULT
3091         return_value = 1
3092         CALL internal_message( 'error', routine_name //                    &
3093                                ': file format "' // TRIM( file_format ) // &
3094                                '" not supported ' // TRIM( temp_string ) )
3095
3096   END SELECT
3097
3098   IF ( output_return_value /= 0 )  THEN
3099      return_value = output_return_value
3100      CALL internal_message( 'error', routine_name // &
3101                             ': error while defining variable ' // TRIM( temp_string ) )
3102   ENDIF
3103
3104END SUBROUTINE init_file_variable
3105
3106!--------------------------------------------------------------------------------------------------!
3107! Description:
3108! ------------
[4070]3109!> Write attribute to file.
3110!--------------------------------------------------------------------------------------------------!
[4141]3111FUNCTION write_attribute( file_format, file_id, file_name,        &
3112                          variable_id, variable_name, attribute ) RESULT( return_value )
[4070]3113
[4141]3114   CHARACTER(LEN=*), INTENT(IN) ::  file_format    !< file format chosen for file
3115   CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< file name
3116   CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< variable name
[4070]3117
3118   CHARACTER(LEN=*), PARAMETER ::  routine_name