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

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

made dom_database_debug_output available (data_output_module.f90)

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