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

Last change on this file since 4134 was 4124, checked in by gronemeier, 5 years ago

remove unused variables

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