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

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

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

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