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

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

Add new data output modules

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