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

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

bugfix: check for empty file list in data_ouput_module when starting output

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