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

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

combine new netcdf4 output modules into a single module; improvements of DOM error messages; check initialization state of file before defining/writing anything; improvements in binary output

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