Changeset 4147 for palm


Ignore:
Timestamp:
Aug 7, 2019 9:42:31 AM (5 years ago)
Author:
gronemeier
Message:

corrected indentation according to coding standard

Location:
palm/trunk/SOURCE
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • palm/trunk/SOURCE/data_output_binary_module.f90

    r4141 r4147  
    2525! -----------------
    2626! $Id$
     27! corrected indentation according to coding standard
     28!
     29! 4141 2019-08-05 12:24:51Z gronemeier
    2730! Initial revision
    2831!
     
    3841!> @todo Get iostat value of write statements.
    3942!--------------------------------------------------------------------------------------------------!
    40 MODULE data_output_binary_module
    41 
    42    USE kinds
     43 MODULE data_output_binary_module
     44
     45    USE kinds
    4346
    4447#if defined( __parallel )
    4548#if defined( __mpifh )
    46    INCLUDE "mpif.h"
     49    INCLUDE "mpif.h"
    4750#else
    48    USE MPI
     51    USE MPI
    4952#endif
    5053#endif
    5154
    52    IMPLICIT NONE
    53 
    54    INTEGER, PARAMETER ::  charlen = 100  !< maximum length of character variables
    55 
    56    CHARACTER(LEN=*), PARAMETER ::  config_file_name = 'BINARY_TO_NETCDF_CONFIG'  !< name of config file
    57    CHARACTER(LEN=*), PARAMETER ::  mode_binary = 'binary'                        !< string to select operation mode of module
    58    CHARACTER(LEN=*), PARAMETER ::  file_prefix = 'BIN_'                          !< file prefix for binary files
    59 
    60    CHARACTER(LEN=charlen)      ::  file_suffix = ''             !< file suffix added to each file name
    61    CHARACTER(LEN=800)          ::  internal_error_message = ''  !< string containing the last error message
    62    CHARACTER(LEN=800)          ::  temp_string                  !< dummy string
    63 
    64    INTEGER ::  binary_file_lowest_unit = 1000  !< lowest unit number of all binary files created by this module
    65    INTEGER ::  config_file_unit                !< unit number of config file
    66    INTEGER ::  debug_output_unit               !< Fortran Unit Number of the debug-output file
    67    INTEGER ::  global_id_in_file = -1          !< value of global ID within a file
    68    INTEGER ::  master_rank                     !< master rank for tasks to be executed by single PE only
    69    INTEGER ::  next_available_unit             !< next unit number available for new file
    70    INTEGER ::  output_group_comm               !< MPI communicator addressing all MPI ranks which participate in output
    71 
    72    INTEGER, DIMENSION(:), ALLOCATABLE ::  files_highest_variable_id  !< highest assigned ID of variable or dimension in a file
    73 
    74    LOGICAL ::  binary_open_file_first_call = .TRUE.  !< true if binary_open_file routine was not called yet
    75    LOGICAL ::  config_file_open = .FALSE.            !< true if config file is opened and not closed
    76    LOGICAL ::  print_debug_output = .FALSE.          !< if true, debug output is printed
    77 
    78    SAVE
    79 
    80    PRIVATE
    81 
    82    INTERFACE binary_init_module
    83       MODULE PROCEDURE binary_init_module
    84    END INTERFACE binary_init_module
    85 
    86    INTERFACE binary_open_file
    87       MODULE PROCEDURE binary_open_file
    88    END INTERFACE binary_open_file
    89 
    90    INTERFACE binary_init_dimension
    91       MODULE PROCEDURE binary_init_dimension
    92    END INTERFACE binary_init_dimension
    93 
    94    INTERFACE binary_init_variable
    95       MODULE PROCEDURE binary_init_variable
    96    END INTERFACE binary_init_variable
    97 
    98    INTERFACE binary_write_attribute
    99       MODULE PROCEDURE binary_write_attribute
    100    END INTERFACE binary_write_attribute
    101 
    102    INTERFACE binary_stop_file_header_definition
    103       MODULE PROCEDURE binary_stop_file_header_definition
    104    END INTERFACE binary_stop_file_header_definition
    105 
    106    INTERFACE binary_write_variable
    107       MODULE PROCEDURE binary_write_variable
    108    END INTERFACE binary_write_variable
    109 
    110    INTERFACE binary_finalize
    111       MODULE PROCEDURE binary_finalize
    112    END INTERFACE binary_finalize
    113 
    114    INTERFACE binary_get_error_message
    115       MODULE PROCEDURE binary_get_error_message
    116    END INTERFACE binary_get_error_message
    117 
    118    PUBLIC &
    119       binary_finalize, &
    120       binary_get_error_message, &
    121       binary_init_dimension, &
    122       binary_stop_file_header_definition, &
    123       binary_init_module, &
    124       binary_init_variable, &
    125       binary_open_file, &
    126       binary_write_attribute, &
    127       binary_write_variable
    128 
    129 
    130 CONTAINS
     55    IMPLICIT NONE
     56
     57    INTEGER, PARAMETER ::  charlen = 100  !< maximum length of character variables
     58
     59    CHARACTER(LEN=*), PARAMETER ::  config_file_name = 'BINARY_TO_NETCDF_CONFIG'  !< name of config file
     60    CHARACTER(LEN=*), PARAMETER ::  mode_binary = 'binary'                        !< string to select operation mode of module
     61    CHARACTER(LEN=*), PARAMETER ::  file_prefix = 'BIN_'                          !< file prefix for binary files
     62
     63    CHARACTER(LEN=charlen)      ::  file_suffix = ''             !< file suffix added to each file name
     64    CHARACTER(LEN=800)          ::  internal_error_message = ''  !< string containing the last error message
     65    CHARACTER(LEN=800)          ::  temp_string                  !< dummy string
     66
     67    INTEGER ::  binary_file_lowest_unit = 1000  !< lowest unit number of all binary files created by this module
     68    INTEGER ::  config_file_unit                !< unit number of config file
     69    INTEGER ::  debug_output_unit               !< Fortran Unit Number of the debug-output file
     70    INTEGER ::  global_id_in_file = -1          !< value of global ID within a file
     71    INTEGER ::  master_rank                     !< master rank for tasks to be executed by single PE only
     72    INTEGER ::  next_available_unit             !< next unit number available for new file
     73    INTEGER ::  output_group_comm               !< MPI communicator addressing all MPI ranks which participate in output
     74
     75    INTEGER, DIMENSION(:), ALLOCATABLE ::  files_highest_variable_id  !< highest assigned ID of variable or dimension in a file
     76
     77    LOGICAL ::  binary_open_file_first_call = .TRUE.  !< true if binary_open_file routine was not called yet
     78    LOGICAL ::  config_file_open = .FALSE.            !< true if config file is opened and not closed
     79    LOGICAL ::  print_debug_output = .FALSE.          !< if true, debug output is printed
     80
     81    SAVE
     82
     83    PRIVATE
     84
     85    INTERFACE binary_init_module
     86       MODULE PROCEDURE binary_init_module
     87    END INTERFACE binary_init_module
     88
     89    INTERFACE binary_open_file
     90       MODULE PROCEDURE binary_open_file
     91    END INTERFACE binary_open_file
     92
     93    INTERFACE binary_init_dimension
     94       MODULE PROCEDURE binary_init_dimension
     95    END INTERFACE binary_init_dimension
     96
     97    INTERFACE binary_init_variable
     98       MODULE PROCEDURE binary_init_variable
     99    END INTERFACE binary_init_variable
     100
     101    INTERFACE binary_write_attribute
     102       MODULE PROCEDURE binary_write_attribute
     103    END INTERFACE binary_write_attribute
     104
     105    INTERFACE binary_stop_file_header_definition
     106       MODULE PROCEDURE binary_stop_file_header_definition
     107    END INTERFACE binary_stop_file_header_definition
     108
     109    INTERFACE binary_write_variable
     110       MODULE PROCEDURE binary_write_variable
     111    END INTERFACE binary_write_variable
     112
     113    INTERFACE binary_finalize
     114       MODULE PROCEDURE binary_finalize
     115    END INTERFACE binary_finalize
     116
     117    INTERFACE binary_get_error_message
     118       MODULE PROCEDURE binary_get_error_message
     119    END INTERFACE binary_get_error_message
     120
     121    PUBLIC &
     122       binary_finalize, &
     123       binary_get_error_message, &
     124       binary_init_dimension, &
     125       binary_stop_file_header_definition, &
     126       binary_init_module, &
     127       binary_init_variable, &
     128       binary_open_file, &
     129       binary_write_attribute, &
     130       binary_write_variable
     131
     132
     133 CONTAINS
    131134
    132135
     
    136139!> Initialize data-output module.
    137140!--------------------------------------------------------------------------------------------------!
    138 SUBROUTINE binary_init_module( file_suffix_of_output_group, mpi_comm_of_output_group, &
    139                                master_output_rank,                                    &
    140                                program_debug_output_unit, debug_output, dom_global_id )
    141 
    142    CHARACTER(LEN=*), INTENT(IN) ::  file_suffix_of_output_group  !> file-name suffix added to each file;
    143                                                                  !> must be unique for each output group
    144 
    145    INTEGER, INTENT(IN) ::  dom_global_id              !< global id within a file defined by DOM
    146    INTEGER, INTENT(IN) ::  master_output_rank         !< MPI rank executing tasks which must be executed by a single PE
    147    INTEGER, INTENT(IN) ::  mpi_comm_of_output_group   !< MPI communicator specifying the rank group participating in output
    148    INTEGER, INTENT(IN) ::  program_debug_output_unit  !< file unit number for debug output
    149 
    150    LOGICAL, INTENT(IN) ::  debug_output  !< if true, debug output is printed
    151 
    152 
    153    file_suffix = file_suffix_of_output_group
    154    output_group_comm = mpi_comm_of_output_group
    155    master_rank = master_output_rank
    156 
    157    debug_output_unit = program_debug_output_unit
    158    print_debug_output = debug_output
    159 
    160    global_id_in_file = dom_global_id
    161 
    162 END SUBROUTINE binary_init_module
     141 SUBROUTINE binary_init_module( file_suffix_of_output_group, mpi_comm_of_output_group, &
     142                                master_output_rank,                                    &
     143                                program_debug_output_unit, debug_output, dom_global_id )
     144
     145    CHARACTER(LEN=*), INTENT(IN) ::  file_suffix_of_output_group  !> file-name suffix added to each file;
     146                                                                  !> must be unique for each output group
     147
     148    INTEGER, INTENT(IN) ::  dom_global_id              !< global id within a file defined by DOM
     149    INTEGER, INTENT(IN) ::  master_output_rank         !< MPI rank executing tasks which must be executed by a single PE
     150    INTEGER, INTENT(IN) ::  mpi_comm_of_output_group   !< MPI communicator specifying the rank group participating in output
     151    INTEGER, INTENT(IN) ::  program_debug_output_unit  !< file unit number for debug output
     152
     153    LOGICAL, INTENT(IN) ::  debug_output  !< if true, debug output is printed
     154
     155
     156    file_suffix = file_suffix_of_output_group
     157    output_group_comm = mpi_comm_of_output_group
     158    master_rank = master_output_rank
     159
     160    debug_output_unit = program_debug_output_unit
     161    print_debug_output = debug_output
     162
     163    global_id_in_file = dom_global_id
     164
     165 END SUBROUTINE binary_init_module
    163166
    164167!--------------------------------------------------------------------------------------------------!
     
    167170!> Open binary file.
    168171!--------------------------------------------------------------------------------------------------!
    169 SUBROUTINE binary_open_file( mode, file_name, file_id, return_value )
    170 
    171    CHARACTER(LEN=charlen)             ::  bin_filename = ''  !< actual name of binary file
    172    CHARACTER(LEN=charlen), INTENT(IN) ::  file_name          !< name of file
    173    CHARACTER(LEN=7)                   ::  my_rank_char       !< string containing value of my_rank with leading zeros
    174    CHARACTER(LEN=*),       INTENT(IN) ::  mode               !< operation mode
    175 
    176    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_open_file'  !< name of this routine
    177 
    178    INTEGER, INTENT(OUT) ::  file_id       !< file ID
    179    INTEGER              ::  my_rank       !< MPI rank of local processor
    180    INTEGER              ::  nranks        !< number of MPI ranks participating in output
    181    INTEGER, INTENT(OUT) ::  return_value  !< return value
    182 
    183    INTEGER, DIMENSION(:), ALLOCATABLE ::  files_highest_variable_id_tmp  !< temporary list of given variable IDs in file
    184 
    185    LOGICAL ::  file_exists  !< true if file to be opened already exists
    186 
    187 
    188    return_value = 0
     172 SUBROUTINE binary_open_file( mode, file_name, file_id, return_value )
     173
     174    CHARACTER(LEN=charlen)             ::  bin_filename = ''  !< actual name of binary file
     175    CHARACTER(LEN=charlen), INTENT(IN) ::  file_name          !< name of file
     176    CHARACTER(LEN=7)                   ::  my_rank_char       !< string containing value of my_rank with leading zeros
     177    CHARACTER(LEN=*),       INTENT(IN) ::  mode               !< operation mode
     178
     179    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_open_file'  !< name of this routine
     180
     181    INTEGER, INTENT(OUT) ::  file_id       !< file ID
     182    INTEGER              ::  my_rank       !< MPI rank of local processor
     183    INTEGER              ::  nranks        !< number of MPI ranks participating in output
     184    INTEGER, INTENT(OUT) ::  return_value  !< return value
     185
     186    INTEGER, DIMENSION(:), ALLOCATABLE ::  files_highest_variable_id_tmp  !< temporary list of given variable IDs in file
     187
     188    LOGICAL ::  file_exists  !< true if file to be opened already exists
     189
     190
     191    return_value = 0
    189192
    190193#if defined( __parallel )
    191    CALL MPI_COMM_SIZE( output_group_comm, nranks, return_value )
    192    IF ( return_value == 0 )  CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
    193    IF ( return_value == 0 )  THEN
    194       WRITE( my_rank_char, '("_",I6.6)' )  my_rank
    195    ELSE
    196       CALL internal_message( 'error', routine_name // ': MPI error' )
    197    ENDIF
     194    CALL MPI_COMM_SIZE( output_group_comm, nranks, return_value )
     195    IF ( return_value == 0 )  CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
     196    IF ( return_value == 0 )  THEN
     197       WRITE( my_rank_char, '("_",I6.6)' )  my_rank
     198    ELSE
     199       CALL internal_message( 'error', routine_name // ': MPI error' )
     200    ENDIF
    198201#else
    199    nranks = 1
    200    my_rank = master_rank
    201    WRITE( my_rank_char, '("_",I6.6)' )  my_rank
     202    nranks = 1
     203    my_rank = master_rank
     204    WRITE( my_rank_char, '("_",I6.6)' )  my_rank
    202205#endif
    203 
    204    !-- Check mode (not required, added for compatibility reasons)
    205    IF ( TRIM( mode ) == mode_binary )  CONTINUE
    206 
    207    !-- Open binary config file for combining script
    208    IF ( return_value == 0  .AND.  binary_open_file_first_call )  THEN
    209 
    210       binary_open_file_first_call = .FALSE.
    211       config_file_unit = binary_file_lowest_unit
    212 
    213       IF ( my_rank == master_rank )  THEN
    214 
    215          !-- Remove any pre-existing file
    216          INQUIRE( FILE=TRIM( config_file_name ) // TRIM( file_suffix ), &
    217                   EXIST=file_exists )
    218 
    219          IF ( file_exists )  THEN
    220             CALL internal_message( 'debug', routine_name //     &
    221                                    ': Remove existing file ' // &
    222                                    TRIM( config_file_name ) // TRIM( file_suffix ) )
    223             !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by
    224             !>       PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used
    225             ! CALL EXECUTE_COMMAND_LINE(                                                &
    226             !         COMMAND='rm ' // TRIM( config_file_name ) // TRIM( file_suffix ), &
    227             !         WAIT=.TRUE., EXITSTAT=return_value )
    228             CALL SYSTEM( 'rm ' // TRIM( config_file_name ) // TRIM( file_suffix ) )
    229          ENDIF
    230 
    231          OPEN( config_file_unit, FILE=TRIM( config_file_name ) // TRIM( file_suffix ), &
    232                FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value )
    233 
    234          IF ( return_value == 0 )  THEN
    235 
    236             config_file_open = .TRUE.
    237 
    238             !-- Write some general information to config file
    239             WRITE( config_file_unit )  nranks
    240             WRITE( config_file_unit )  master_rank
    241             WRITE( config_file_unit )  LEN( file_prefix )
    242             WRITE( config_file_unit )  file_prefix
    243             WRITE( config_file_unit )  charlen
    244             WRITE( config_file_unit )  global_id_in_file
    245 
    246          ELSE
    247 
    248             return_value = 1
    249             CALL internal_message( 'error', routine_name // ': could not create config' )
    250 
    251          ENDIF
    252 
    253       ENDIF
    254 
    255       next_available_unit = binary_file_lowest_unit + 1
    256 
    257    ENDIF
    258 
    259    !-- Initialize output file: open, write header, initialize variable/dimension IDs
    260    IF ( return_value == 0 )  THEN
    261 
    262       bin_filename = file_prefix // TRIM( file_name ) // TRIM( file_suffix ) // my_rank_char
    263 
    264       !-- Remove any pre-existing file
    265       INQUIRE( FILE=TRIM( bin_filename ), EXIST=file_exists )
    266 
    267       IF ( file_exists )  THEN
    268          CALL internal_message( 'debug', routine_name // &
    269                                 ': remove existing file ' // TRIM( bin_filename ) )
    270          !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by
    271          !>       PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used
    272          ! CALL EXECUTE_COMMAND_LINE( COMMAND='rm ' // TRIM( bin_filename ), &
    273          !                            WAIT=.TRUE., EXITSTAT=return_value )
    274          CALL SYSTEM( 'rm ' // TRIM( bin_filename ) )
    275       ENDIF
    276 
    277       !-- Open binary file
    278       CALL internal_message( 'debug', routine_name // ': open file ' // TRIM( bin_filename ) )
    279       OPEN ( next_available_unit, FILE=TRIM( bin_filename ), &
    280              FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value )
    281 
    282       IF ( return_value == 0 )  THEN
    283 
    284          !-- Add file_name to config file
    285          IF ( my_rank == master_rank )  THEN
    286             WRITE( config_file_unit )  file_name
    287          ENDIF
    288 
    289          !-- Save file ID and increase next file unit number
    290          file_id = next_available_unit
    291          next_available_unit = next_available_unit + 1
    292 
    293          !-- Write some meta data to file
    294          WRITE ( file_id )  charlen
    295          WRITE ( file_id )  file_id
    296          WRITE ( file_id )  file_name
    297 
    298          !-- Extend file-variable/dimension-ID list by 1 and set it to 0 for new file.
    299          IF ( ALLOCATED( files_highest_variable_id ) )  THEN
    300             ALLOCATE( files_highest_variable_id_tmp(SIZE( files_highest_variable_id )) )
    301             files_highest_variable_id_tmp = files_highest_variable_id
    302             DEALLOCATE( files_highest_variable_id )
    303             ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
    304             files_highest_variable_id(:file_id-1) = files_highest_variable_id_tmp
    305             DEALLOCATE( files_highest_variable_id_tmp )
    306          ELSE
    307             ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
    308          ENDIF
    309          files_highest_variable_id(file_id) = 0
    310 
    311       ELSE
    312          return_value = 1
    313          CALL internal_message( 'error', routine_name // &
    314                                 ': could not open file "' // TRIM( file_name ) // '"')
    315       ENDIF
    316 
    317    ENDIF
    318 
    319 END SUBROUTINE binary_open_file
     206!
     207!-- Check mode (not required, added for compatibility reasons)
     208    IF ( TRIM( mode ) == mode_binary )  CONTINUE
     209!
     210!-- Open binary config file for combining script
     211    IF ( return_value == 0  .AND.  binary_open_file_first_call )  THEN
     212
     213       binary_open_file_first_call = .FALSE.
     214       config_file_unit = binary_file_lowest_unit
     215
     216       IF ( my_rank == master_rank )  THEN
     217!
     218!--      Remove any pre-existing file
     219          INQUIRE( FILE=TRIM( config_file_name ) // TRIM( file_suffix ), &
     220                   EXIST=file_exists )
     221
     222          IF ( file_exists )  THEN
     223             CALL internal_message( 'debug', routine_name //     &
     224                                    ': Remove existing file ' // &
     225                                    TRIM( config_file_name ) // TRIM( file_suffix ) )
     226             !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by
     227             !>       PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used
     228             ! CALL EXECUTE_COMMAND_LINE(                                                &
     229             !         COMMAND='rm ' // TRIM( config_file_name ) // TRIM( file_suffix ), &
     230             !         WAIT=.TRUE., EXITSTAT=return_value )
     231             CALL SYSTEM( 'rm ' // TRIM( config_file_name ) // TRIM( file_suffix ) )
     232          ENDIF
     233
     234          OPEN( config_file_unit, FILE=TRIM( config_file_name ) // TRIM( file_suffix ), &
     235                FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value )
     236
     237          IF ( return_value == 0 )  THEN
     238
     239             config_file_open = .TRUE.
     240!
     241!--          Write some general information to config file
     242             WRITE( config_file_unit )  nranks
     243             WRITE( config_file_unit )  master_rank
     244             WRITE( config_file_unit )  LEN( file_prefix )
     245             WRITE( config_file_unit )  file_prefix
     246             WRITE( config_file_unit )  charlen
     247             WRITE( config_file_unit )  global_id_in_file
     248
     249          ELSE
     250
     251             return_value = 1
     252             CALL internal_message( 'error', routine_name // ': could not create config' )
     253
     254          ENDIF
     255
     256       ENDIF
     257
     258       next_available_unit = binary_file_lowest_unit + 1
     259
     260    ENDIF
     261!
     262!-- Initialize output file: open, write header, initialize variable/dimension IDs
     263    IF ( return_value == 0 )  THEN
     264
     265       bin_filename = file_prefix // TRIM( file_name ) // TRIM( file_suffix ) // my_rank_char
     266!
     267!--    Remove any pre-existing file
     268       INQUIRE( FILE=TRIM( bin_filename ), EXIST=file_exists )
     269
     270       IF ( file_exists )  THEN
     271          CALL internal_message( 'debug', routine_name // &
     272                                 ': remove existing file ' // TRIM( bin_filename ) )
     273          !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by
     274          !>       PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used
     275          ! CALL EXECUTE_COMMAND_LINE( COMMAND='rm ' // TRIM( bin_filename ), &
     276          !                            WAIT=.TRUE., EXITSTAT=return_value )
     277          CALL SYSTEM( 'rm ' // TRIM( bin_filename ) )
     278       ENDIF
     279!
     280!--    Open binary file
     281       CALL internal_message( 'debug', routine_name // ': open file ' // TRIM( bin_filename ) )
     282       OPEN ( next_available_unit, FILE=TRIM( bin_filename ), &
     283              FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value )
     284
     285       IF ( return_value == 0 )  THEN
     286!
     287!--      Add file_name to config file
     288          IF ( my_rank == master_rank )  THEN
     289             WRITE( config_file_unit )  file_name
     290          ENDIF
     291!
     292!--      Save file ID and increase next file unit number
     293          file_id = next_available_unit
     294          next_available_unit = next_available_unit + 1
     295!
     296!--      Write some meta data to file
     297          WRITE ( file_id )  charlen
     298          WRITE ( file_id )  file_id
     299          WRITE ( file_id )  file_name
     300!
     301!--      Extend file-variable/dimension-ID list by 1 and set it to 0 for new file.
     302          IF ( ALLOCATED( files_highest_variable_id ) )  THEN
     303             ALLOCATE( files_highest_variable_id_tmp(SIZE( files_highest_variable_id )) )
     304             files_highest_variable_id_tmp = files_highest_variable_id
     305             DEALLOCATE( files_highest_variable_id )
     306             ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
     307             files_highest_variable_id(:file_id-1) = files_highest_variable_id_tmp
     308             DEALLOCATE( files_highest_variable_id_tmp )
     309          ELSE
     310             ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
     311          ENDIF
     312          files_highest_variable_id(file_id) = 0
     313
     314       ELSE
     315          return_value = 1
     316          CALL internal_message( 'error', routine_name // &
     317                                 ': could not open file "' // TRIM( file_name ) // '"')
     318       ENDIF
     319
     320    ENDIF
     321
     322 END SUBROUTINE binary_open_file
    320323
    321324!--------------------------------------------------------------------------------------------------!
     
    324327!> Write attribute to file.
    325328!--------------------------------------------------------------------------------------------------!
    326 SUBROUTINE binary_write_attribute( file_id, variable_id, attribute_name, &
    327               value_char, value_int8, value_int16, value_int32,          &
    328               value_real32, value_real64, return_value )
    329 
    330    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_write_attribute'  !< name of this routine
    331 
    332    CHARACTER(LEN=charlen), INTENT(IN)           ::  attribute_name        !< name of attribute
    333    CHARACTER(LEN=charlen), INTENT(IN), OPTIONAL ::  value_char  !< value of attribute
    334    CHARACTER(LEN=charlen)                       ::  attribute_type        !< data type of attribute
    335    CHARACTER(LEN=charlen)                       ::  output_string         !< output string
    336 
    337    INTEGER(KIND=1), INTENT(IN), OPTIONAL ::  value_int8   !< value of attribute
    338    INTEGER(KIND=2), INTENT(IN), OPTIONAL ::  value_int16  !< value of attribute
    339    INTEGER(KIND=4), INTENT(IN), OPTIONAL ::  value_int32  !< value of attribute
    340 
    341    INTEGER, INTENT(IN)  ::  file_id       !< file ID
    342    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
    343    INTEGER, INTENT(OUT) ::  return_value  !< return value
    344 
    345    REAL(KIND=4), INTENT(IN), OPTIONAL ::  value_real32  !< value of attribute
    346    REAL(KIND=8), INTENT(IN), OPTIONAL ::  value_real64  !< value of attribute
    347 
    348 
    349    return_value = 0
    350 
    351    CALL internal_message( 'debug', TRIM( routine_name ) // &
    352                           ': write attribute ' // TRIM( attribute_name ) )
    353 
    354    !-- Write attribute to file
    355    output_string = 'attribute'
    356    WRITE( file_id )  output_string
    357 
    358    WRITE( file_id )  variable_id
    359    WRITE( file_id )  attribute_name
    360 
    361    IF ( PRESENT( value_char ) )  THEN
    362       attribute_type = 'char'
    363       WRITE( file_id )  attribute_type
    364       WRITE( file_id )  value_char
    365    ELSEIF ( PRESENT( value_int8 ) )  THEN
    366       attribute_type = 'int8'
    367       WRITE( file_id )  attribute_type
    368       WRITE( file_id )  value_int8
    369    ELSEIF ( PRESENT( value_int16 ) )  THEN
    370       attribute_type = 'int16'
    371       WRITE( file_id )  attribute_type
    372       WRITE( file_id )  value_int16
    373    ELSEIF ( PRESENT( value_int32 ) )  THEN
    374       attribute_type = 'int32'
    375       WRITE( file_id )  attribute_type
    376       WRITE( file_id )  value_int32
    377    ELSEIF ( PRESENT( value_real32 ) )  THEN
    378       attribute_type = 'real32'
    379       WRITE( file_id )  attribute_type
    380       WRITE( file_id )  value_real32
    381    ELSEIF ( PRESENT( value_real64 ) )  THEN
    382       attribute_type = 'real64'
    383       WRITE( file_id )  attribute_type
    384       WRITE( file_id )  value_real64
    385    ELSE
    386       return_value = 1
    387       CALL internal_message( 'error', TRIM( routine_name ) // &
    388                              ': no value given for attribute "' // TRIM( attribute_name ) // '"' )
    389    ENDIF
    390 
    391 END SUBROUTINE binary_write_attribute
     329 SUBROUTINE binary_write_attribute( file_id, variable_id, attribute_name, &
     330               value_char, value_int8, value_int16, value_int32,          &
     331               value_real32, value_real64, return_value )
     332
     333    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_write_attribute'  !< name of this routine
     334
     335    CHARACTER(LEN=charlen), INTENT(IN)           ::  attribute_name        !< name of attribute
     336    CHARACTER(LEN=charlen), INTENT(IN), OPTIONAL ::  value_char  !< value of attribute
     337    CHARACTER(LEN=charlen)                       ::  attribute_type        !< data type of attribute
     338    CHARACTER(LEN=charlen)                       ::  output_string         !< output string
     339
     340    INTEGER(KIND=1), INTENT(IN), OPTIONAL ::  value_int8   !< value of attribute
     341    INTEGER(KIND=2), INTENT(IN), OPTIONAL ::  value_int16  !< value of attribute
     342    INTEGER(KIND=4), INTENT(IN), OPTIONAL ::  value_int32  !< value of attribute
     343
     344    INTEGER, INTENT(IN)  ::  file_id       !< file ID
     345    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
     346    INTEGER, INTENT(OUT) ::  return_value  !< return value
     347
     348    REAL(KIND=4), INTENT(IN), OPTIONAL ::  value_real32  !< value of attribute
     349    REAL(KIND=8), INTENT(IN), OPTIONAL ::  value_real64  !< value of attribute
     350
     351
     352    return_value = 0
     353
     354    CALL internal_message( 'debug', TRIM( routine_name ) // &
     355                           ': write attribute ' // TRIM( attribute_name ) )
     356!
     357!-- Write attribute to file
     358    output_string = 'attribute'
     359    WRITE( file_id )  output_string
     360
     361    WRITE( file_id )  variable_id
     362    WRITE( file_id )  attribute_name
     363
     364    IF ( PRESENT( value_char ) )  THEN
     365       attribute_type = 'char'
     366       WRITE( file_id )  attribute_type
     367       WRITE( file_id )  value_char
     368    ELSEIF ( PRESENT( value_int8 ) )  THEN
     369       attribute_type = 'int8'
     370       WRITE( file_id )  attribute_type
     371       WRITE( file_id )  value_int8
     372    ELSEIF ( PRESENT( value_int16 ) )  THEN
     373       attribute_type = 'int16'
     374       WRITE( file_id )  attribute_type
     375       WRITE( file_id )  value_int16
     376    ELSEIF ( PRESENT( value_int32 ) )  THEN
     377       attribute_type = 'int32'
     378       WRITE( file_id )  attribute_type
     379       WRITE( file_id )  value_int32
     380    ELSEIF ( PRESENT( value_real32 ) )  THEN
     381       attribute_type = 'real32'
     382       WRITE( file_id )  attribute_type
     383       WRITE( file_id )  value_real32
     384    ELSEIF ( PRESENT( value_real64 ) )  THEN
     385       attribute_type = 'real64'
     386       WRITE( file_id )  attribute_type
     387       WRITE( file_id )  value_real64
     388    ELSE
     389       return_value = 1
     390       CALL internal_message( 'error', TRIM( routine_name ) // &
     391                              ': no value given for attribute "' // TRIM( attribute_name ) // '"' )
     392    ENDIF
     393
     394 END SUBROUTINE binary_write_attribute
    392395
    393396!--------------------------------------------------------------------------------------------------!
     
    397400!> and save dimension values to be later written to file.
    398401!--------------------------------------------------------------------------------------------------!
    399 SUBROUTINE binary_init_dimension( mode, file_id, dimension_id, variable_id, &
    400               dimension_name, dimension_type, dimension_length, return_value )
    401 
    402    CHARACTER(LEN=charlen), INTENT(IN) ::  dimension_name  !< name of dimension
    403    CHARACTER(LEN=charlen), INTENT(IN) ::  dimension_type  !< data type of dimension
    404    CHARACTER(LEN=charlen)             ::  output_string   !< output string
    405    CHARACTER(LEN=*),       INTENT(IN) ::  mode            !< operation mode
    406 
    407    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_init_dimension'  !< name of this routine
    408 
    409    INTEGER, INTENT(OUT) ::  dimension_id      !< dimension ID
    410    INTEGER, INTENT(IN)  ::  dimension_length  !< length of dimension
    411    INTEGER, INTENT(IN)  ::  file_id           !< file ID
    412    INTEGER, INTENT(OUT) ::  return_value      !< return value
    413    INTEGER, INTENT(OUT) ::  variable_id       !< variable ID
    414 
    415 
    416    return_value = 0
    417 
    418    CALL internal_message( 'debug', routine_name // ': init dimension ' // TRIM( dimension_name ) )
    419 
    420    !-- Check mode (not required, added for compatibility reasons only)
    421    IF ( TRIM( mode ) == mode_binary )  CONTINUE
    422 
    423    !-- Assign dimension ID
    424    dimension_id = files_highest_variable_id( file_id ) + 1
    425    files_highest_variable_id( file_id ) = dimension_id
    426 
    427    !-- Define dimension in file
    428    output_string = 'dimension'
    429    WRITE( file_id )  output_string
    430    WRITE( file_id )  dimension_name
    431    WRITE( file_id )  dimension_id
    432    WRITE( file_id )  dimension_type
    433    WRITE( file_id )  dimension_length
    434 
    435    !-- Define variable associated with dimension
    436    CALL binary_init_variable( mode, file_id, variable_id, dimension_name, dimension_type, &
    437                               (/ dimension_id /), is_global=.TRUE., return_value=return_value )
    438    IF ( return_value /= 0 )  THEN
    439       CALL internal_message( 'error', routine_name // &
    440                              ': init dimension "' // TRIM( dimension_name ) // '"' )
    441    ENDIF
    442 
    443 END SUBROUTINE binary_init_dimension
     402 SUBROUTINE binary_init_dimension( mode, file_id, dimension_id, variable_id, &
     403               dimension_name, dimension_type, dimension_length, return_value )
     404
     405    CHARACTER(LEN=charlen), INTENT(IN) ::  dimension_name  !< name of dimension
     406    CHARACTER(LEN=charlen), INTENT(IN) ::  dimension_type  !< data type of dimension
     407    CHARACTER(LEN=charlen)             ::  output_string   !< output string
     408    CHARACTER(LEN=*),       INTENT(IN) ::  mode            !< operation mode
     409
     410    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_init_dimension'  !< name of this routine
     411
     412    INTEGER, INTENT(OUT) ::  dimension_id      !< dimension ID
     413    INTEGER, INTENT(IN)  ::  dimension_length  !< length of dimension
     414    INTEGER, INTENT(IN)  ::  file_id           !< file ID
     415    INTEGER, INTENT(OUT) ::  return_value      !< return value
     416    INTEGER, INTENT(OUT) ::  variable_id       !< variable ID
     417
     418
     419    return_value = 0
     420
     421    CALL internal_message( 'debug', routine_name // ': init dimension ' // TRIM( dimension_name ) )
     422!
     423!-- Check mode (not required, added for compatibility reasons only)
     424    IF ( TRIM( mode ) == mode_binary )  CONTINUE
     425!
     426!-- Assign dimension ID
     427    dimension_id = files_highest_variable_id( file_id ) + 1
     428    files_highest_variable_id( file_id ) = dimension_id
     429!
     430!-- Define dimension in file
     431    output_string = 'dimension'
     432    WRITE( file_id )  output_string
     433    WRITE( file_id )  dimension_name
     434    WRITE( file_id )  dimension_id
     435    WRITE( file_id )  dimension_type
     436    WRITE( file_id )  dimension_length
     437!
     438!-- Define variable associated with dimension
     439    CALL binary_init_variable( mode, file_id, variable_id, dimension_name, dimension_type, &
     440                               (/ dimension_id /), is_global=.TRUE., return_value=return_value )
     441    IF ( return_value /= 0 )  THEN
     442       CALL internal_message( 'error', routine_name // &
     443                              ': init dimension "' // TRIM( dimension_name ) // '"' )
     444    ENDIF
     445
     446 END SUBROUTINE binary_init_dimension
    444447
    445448!--------------------------------------------------------------------------------------------------!
     
    448451!> Initialize variable. Write information of variable into file header.
    449452!--------------------------------------------------------------------------------------------------!
    450 SUBROUTINE binary_init_variable( mode, file_id, variable_id, variable_name, variable_type, &
    451                                  dimension_ids, is_global, return_value )
    452 
    453    CHARACTER(LEN=charlen)             ::  output_string   !< output string
    454    CHARACTER(LEN=charlen), INTENT(IN) ::  variable_name   !< name of variable
    455    CHARACTER(LEN=charlen), INTENT(IN) ::  variable_type   !< data type of variable
    456    CHARACTER(LEN=*),       INTENT(IN) ::  mode            !< operation mode
    457 
    458    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_init_variable'  !< name of this routine
    459 
    460    INTEGER, INTENT(IN)  ::  file_id       !< file ID
    461    INTEGER, INTENT(OUT) ::  variable_id   !< variable ID
    462    INTEGER, INTENT(OUT) ::  return_value  !< return value
    463 
    464    INTEGER, DIMENSION(:), INTENT(IN) ::  dimension_ids  !< list of dimension IDs used by variable
    465 
    466    LOGICAL, INTENT(IN)  ::  is_global  !< true if variable is global (same on all PE)
    467 
    468 
    469    return_value = 0
    470 
    471    CALL internal_message( 'debug', routine_name // ': init variable ' // TRIM( variable_name ) )
    472 
    473    !-- Check mode (not required, added for compatibility reasons only)
    474    IF ( TRIM( mode ) == mode_binary )  CONTINUE
    475 
    476    !-- Check if variable is global (not required, added for compatibility reasons only)
    477    IF ( is_global )  CONTINUE
    478 
    479    !-- Assign variable ID
    480    variable_id = files_highest_variable_id( file_id ) + 1
    481    files_highest_variable_id( file_id ) = variable_id
    482 
    483    !-- Write variable information in file
    484    output_string = 'variable'
    485    WRITE( file_id )  output_string
    486    WRITE( file_id )  variable_name
    487    WRITE( file_id )  variable_id
    488    WRITE( file_id )  variable_type
    489    WRITE( file_id )  SIZE( dimension_ids )
    490    WRITE( file_id )  dimension_ids
    491 
    492 END SUBROUTINE binary_init_variable
     453 SUBROUTINE binary_init_variable( mode, file_id, variable_id, variable_name, variable_type, &
     454                                  dimension_ids, is_global, return_value )
     455
     456    CHARACTER(LEN=charlen)             ::  output_string   !< output string
     457    CHARACTER(LEN=charlen), INTENT(IN) ::  variable_name   !< name of variable
     458    CHARACTER(LEN=charlen), INTENT(IN) ::  variable_type   !< data type of variable
     459    CHARACTER(LEN=*),       INTENT(IN) ::  mode            !< operation mode
     460
     461    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_init_variable'  !< name of this routine
     462
     463    INTEGER, INTENT(IN)  ::  file_id       !< file ID
     464    INTEGER, INTENT(OUT) ::  variable_id   !< variable ID
     465    INTEGER, INTENT(OUT) ::  return_value  !< return value
     466
     467    INTEGER, DIMENSION(:), INTENT(IN) ::  dimension_ids  !< list of dimension IDs used by variable
     468
     469    LOGICAL, INTENT(IN)  ::  is_global  !< true if variable is global (same on all PE)
     470
     471
     472    return_value = 0
     473
     474    CALL internal_message( 'debug', routine_name // ': init variable ' // TRIM( variable_name ) )
     475!
     476!-- Check mode (not required, added for compatibility reasons only)
     477    IF ( TRIM( mode ) == mode_binary )  CONTINUE
     478!
     479!-- Check if variable is global (not required, added for compatibility reasons only)
     480    IF ( is_global )  CONTINUE
     481!
     482!-- Assign variable ID
     483    variable_id = files_highest_variable_id( file_id ) + 1
     484    files_highest_variable_id( file_id ) = variable_id
     485!
     486!-- Write variable information in file
     487    output_string = 'variable'
     488    WRITE( file_id )  output_string
     489    WRITE( file_id )  variable_name
     490    WRITE( file_id )  variable_id
     491    WRITE( file_id )  variable_type
     492    WRITE( file_id )  SIZE( dimension_ids )
     493    WRITE( file_id )  dimension_ids
     494
     495 END SUBROUTINE binary_init_variable
    493496
    494497!--------------------------------------------------------------------------------------------------!
     
    497500!> Leave file definition state.
    498501!--------------------------------------------------------------------------------------------------!
    499 SUBROUTINE binary_stop_file_header_definition( file_id, return_value )
    500 
    501    CHARACTER(LEN=charlen) ::  output_string  !< output string
    502 
    503    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_stop_file_header_definition'  !< name of this routine
    504 
    505    INTEGER, INTENT(IN)  ::  file_id       !< file ID
    506    INTEGER, INTENT(OUT) ::  return_value  !< return value
    507 
    508 
    509    return_value = 0
    510 
    511    WRITE( temp_string, * ) file_id
    512    CALL internal_message( 'debug', routine_name // &
    513                           ': finalize file definition (file_id=' // TRIM( temp_string ) // ')' )
    514 
    515    output_string = '*** end file header ***'
    516    WRITE( file_id )  output_string
    517 
    518 END SUBROUTINE binary_stop_file_header_definition
     502 SUBROUTINE binary_stop_file_header_definition( file_id, return_value )
     503
     504    CHARACTER(LEN=charlen) ::  output_string  !< output string
     505
     506    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_stop_file_header_definition'  !< name of this routine
     507
     508    INTEGER, INTENT(IN)  ::  file_id       !< file ID
     509    INTEGER, INTENT(OUT) ::  return_value  !< return value
     510
     511
     512    return_value = 0
     513
     514    WRITE( temp_string, * ) file_id
     515    CALL internal_message( 'debug', routine_name // &
     516                           ': finalize file definition (file_id=' // TRIM( temp_string ) // ')' )
     517
     518    output_string = '*** end file header ***'
     519    WRITE( file_id )  output_string
     520
     521 END SUBROUTINE binary_stop_file_header_definition
    519522
    520523!--------------------------------------------------------------------------------------------------!
     
    523526!> Write variable to file.
    524527!--------------------------------------------------------------------------------------------------!
    525 SUBROUTINE binary_write_variable(                                                     &
    526               file_id, variable_id, bounds_start, value_counts, bounds_origin,        &
    527               is_global,                                                              &
    528               values_int8_0d,   values_int8_1d,   values_int8_2d,   values_int8_3d,   &
    529               values_int16_0d,  values_int16_1d,  values_int16_2d,  values_int16_3d,  &
    530               values_int32_0d,  values_int32_1d,  values_int32_2d,  values_int32_3d,  &
    531               values_intwp_0d,  values_intwp_1d,  values_intwp_2d,  values_intwp_3d,  &
    532               values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &
    533               values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &
    534               values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d, &
    535               return_value )
    536 
    537    CHARACTER(LEN=charlen) ::  output_string  !< output string
    538 
    539    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_write_variable'  !< name of this routine
    540 
    541    INTEGER, INTENT(IN)  ::  file_id       !< file ID
    542    INTEGER, INTENT(OUT) ::  return_value  !< return value
    543    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
    544 
    545    INTEGER, DIMENSION(:), INTENT(IN) ::  bounds_origin  !< starting index of each dimension
    546    INTEGER, DIMENSION(:), INTENT(IN) ::  bounds_start   !< starting index of variable
    547    INTEGER, DIMENSION(:), INTENT(IN) ::  value_counts   !< count of values along each dimension to be written
    548 
    549    INTEGER(KIND=1), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int8_0d   !< output variable
    550    INTEGER(KIND=2), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int16_0d  !< output variable
    551    INTEGER(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int32_0d  !< output variable
    552    INTEGER(iwp),    POINTER,             INTENT(IN), OPTIONAL                   ::  values_intwp_0d  !< output variable
    553    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int8_1d   !< output variable
    554    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int16_1d  !< output variable
    555    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int32_1d  !< output variable
    556    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_intwp_1d  !< output variable
    557    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int8_2d   !< output variable
    558    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int16_2d  !< output variable
    559    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int32_2d  !< output variable
    560    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_intwp_2d  !< output variable
    561    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int8_3d   !< output variable
    562    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int16_3d  !< output variable
    563    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int32_3d  !< output variable
    564    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_intwp_3d  !< output variable
    565 
    566    LOGICAL, INTENT(IN) ::  is_global  !< true if variable is global (same on all PE)
    567 
    568    REAL(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real32_0d  !< output variable
    569    REAL(KIND=8), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real64_0d  !< output variable
    570    REAL(wp),     POINTER,             INTENT(IN), OPTIONAL                   ::  values_realwp_0d  !< output variable
    571    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real32_1d  !< output variable
    572    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real64_1d  !< output variable
    573    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_realwp_1d  !< output variable
    574    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real32_2d  !< output variable
    575    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real64_2d  !< output variable
    576    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_realwp_2d  !< output variable
    577    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real32_3d  !< output variable
    578    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real64_3d  !< output variable
    579    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_realwp_3d  !< output variable
    580 
    581 
    582    return_value = 0
    583 
    584    WRITE( temp_string, '(": write variable ",I6," into file ",I6)' ) variable_id, file_id
    585    CALL internal_message( 'debug', routine_name // TRIM( temp_string ) )
    586 
    587    IF ( is_global )  CONTINUE  ! reqired to prevent compiler warning
    588 
    589    IF ( .NOT. ANY( value_counts == 0 ) )  THEN
    590       WRITE( file_id )  variable_id
    591       WRITE( file_id )  bounds_start
    592       WRITE( file_id )  value_counts
    593       WRITE( file_id )  bounds_origin
    594       !-- 8bit integer output
    595       IF ( PRESENT( values_int8_0d ) )  THEN
    596          output_string = 'int8'
    597          WRITE( file_id )  output_string
    598          WRITE( file_id )  values_int8_0d
    599       ELSEIF ( PRESENT( values_int8_1d ) )  THEN
    600          output_string = 'int8'
    601          WRITE( file_id )  output_string
    602          WRITE( file_id )  values_int8_1d
    603       ELSEIF ( PRESENT( values_int8_2d ) )  THEN
    604          output_string = 'int8'
    605          WRITE( file_id )  output_string
    606          WRITE( file_id )  values_int8_2d
    607       ELSEIF ( PRESENT( values_int8_3d ) )  THEN
    608          output_string = 'int8'
    609          WRITE( file_id )  output_string
    610          WRITE( file_id )  values_int8_3d
    611       !-- 16bit integer output
    612       ELSEIF ( PRESENT( values_int16_0d ) )  THEN
    613          output_string = 'int16'
    614          WRITE( file_id )  output_string
    615          WRITE( file_id )  values_int16_0d
    616       ELSEIF ( PRESENT( values_int16_1d ) )  THEN
    617          output_string = 'int16'
    618          WRITE( file_id )  output_string
    619          WRITE( file_id )  values_int16_1d
    620       ELSEIF ( PRESENT( values_int16_2d ) )  THEN
    621          output_string = 'int16'
    622          WRITE( file_id )  output_string
    623          WRITE( file_id )  values_int16_2d
    624       ELSEIF ( PRESENT( values_int16_3d ) )  THEN
    625          output_string = 'int16'
    626          WRITE( file_id )  output_string
    627          WRITE( file_id )  values_int16_3d
    628       !-- 32bit integer output
    629       ELSEIF ( PRESENT( values_int32_0d ) )  THEN
    630          output_string = 'int32'
    631          WRITE( file_id )  output_string
    632          WRITE( file_id )  values_int32_0d
    633       ELSEIF ( PRESENT( values_int32_1d ) )  THEN
    634          output_string = 'int32'
    635          WRITE( file_id )  output_string
    636          WRITE( file_id )  values_int32_1d
    637       ELSEIF ( PRESENT( values_int32_2d ) )  THEN
    638          output_string = 'int32'
    639          WRITE( file_id )  output_string
    640          WRITE( file_id )  values_int32_2d
    641       ELSEIF ( PRESENT( values_int32_3d ) )  THEN
    642          output_string = 'int32'
    643          WRITE( file_id )  output_string
    644          WRITE( file_id )  values_int32_3d
    645       !-- working-precision integer output
    646       ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
    647          output_string = 'intwp'
    648          WRITE( file_id )  output_string
    649          WRITE( file_id )  values_intwp_0d
    650       ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
    651          output_string = 'intwp'
    652          WRITE( file_id )  output_string
    653          WRITE( file_id )  values_intwp_1d
    654       ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
    655          output_string = 'intwp'
    656          WRITE( file_id )  output_string
    657          WRITE( file_id )  values_intwp_2d
    658       ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
    659          output_string = 'intwp'
    660          WRITE( file_id )  output_string
    661          WRITE( file_id )  values_intwp_3d
    662       !-- 32bit real output
    663       ELSEIF ( PRESENT( values_real32_0d ) )  THEN
    664          output_string = 'real32'
    665          WRITE( file_id )  output_string
    666          WRITE( file_id )  values_real32_0d
    667       ELSEIF ( PRESENT( values_real32_1d ) )  THEN
    668          output_string = 'real32'
    669          WRITE( file_id )  output_string
    670          WRITE( file_id )  values_real32_1d
    671       ELSEIF ( PRESENT( values_real32_2d ) )  THEN
    672          output_string = 'real32'
    673          WRITE( file_id )  output_string
    674          WRITE( file_id )  values_real32_2d
    675       ELSEIF ( PRESENT( values_real32_3d ) )  THEN
    676          output_string = 'real32'
    677          WRITE( file_id )  output_string
    678          WRITE( file_id )  values_real32_3d
    679       !-- 64bit real output
    680       ELSEIF ( PRESENT( values_real64_0d ) )  THEN
    681          output_string = 'real64'
    682          WRITE( file_id )  output_string
    683          WRITE( file_id )  values_real64_0d
    684       ELSEIF ( PRESENT( values_real64_1d ) )  THEN
    685          output_string = 'real64'
    686          WRITE( file_id )  output_string
    687          WRITE( file_id )  values_real64_1d
    688       ELSEIF ( PRESENT( values_real64_2d ) )  THEN
    689          output_string = 'real64'
    690          WRITE( file_id )  output_string
    691          WRITE( file_id )  values_real64_2d
    692       ELSEIF ( PRESENT( values_real64_3d ) )  THEN
    693          output_string = 'real64'
    694          WRITE( file_id )  output_string
    695          WRITE( file_id )  values_real64_3d
    696       !-- working-precision real output
    697       ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
    698          output_string = 'realwp'
    699          WRITE( file_id )  output_string
    700          WRITE( file_id )  values_realwp_0d
    701       ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
    702          output_string = 'realwp'
    703          WRITE( file_id )  output_string
    704          WRITE( file_id )  values_realwp_1d
    705       ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
    706          output_string = 'realwp'
    707          WRITE( file_id )  output_string
    708          WRITE( file_id )  values_realwp_2d
    709       ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
    710          output_string = 'realwp'
    711          WRITE( file_id )  output_string
    712          WRITE( file_id )  values_realwp_3d
    713       ELSE
    714          return_value = 1
    715          CALL internal_message( 'error', routine_name // ': no values given' )
    716       ENDIF
    717 
    718    ENDIF
    719 
    720 END SUBROUTINE binary_write_variable
     528 SUBROUTINE binary_write_variable(                                                     &
     529               file_id, variable_id, bounds_start, value_counts, bounds_origin,        &
     530               is_global,                                                              &
     531               values_int8_0d,   values_int8_1d,   values_int8_2d,   values_int8_3d,   &
     532               values_int16_0d,  values_int16_1d,  values_int16_2d,  values_int16_3d,  &
     533               values_int32_0d,  values_int32_1d,  values_int32_2d,  values_int32_3d,  &
     534               values_intwp_0d,  values_intwp_1d,  values_intwp_2d,  values_intwp_3d,  &
     535               values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &
     536               values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &
     537               values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d, &
     538               return_value )
     539
     540    CHARACTER(LEN=charlen) ::  output_string  !< output string
     541
     542    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_write_variable'  !< name of this routine
     543
     544    INTEGER, INTENT(IN)  ::  file_id       !< file ID
     545    INTEGER, INTENT(OUT) ::  return_value  !< return value
     546    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
     547
     548    INTEGER, DIMENSION(:), INTENT(IN) ::  bounds_origin  !< starting index of each dimension
     549    INTEGER, DIMENSION(:), INTENT(IN) ::  bounds_start   !< starting index of variable
     550    INTEGER, DIMENSION(:), INTENT(IN) ::  value_counts   !< count of values along each dimension to be written
     551
     552    INTEGER(KIND=1), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int8_0d   !< output variable
     553    INTEGER(KIND=2), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int16_0d  !< output variable
     554    INTEGER(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int32_0d  !< output variable
     555    INTEGER(iwp),    POINTER,             INTENT(IN), OPTIONAL                   ::  values_intwp_0d  !< output variable
     556    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int8_1d   !< output variable
     557    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int16_1d  !< output variable
     558    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int32_1d  !< output variable
     559    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_intwp_1d  !< output variable
     560    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int8_2d   !< output variable
     561    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int16_2d  !< output variable
     562    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int32_2d  !< output variable
     563    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_intwp_2d  !< output variable
     564    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int8_3d   !< output variable
     565    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int16_3d  !< output variable
     566    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int32_3d  !< output variable
     567    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_intwp_3d  !< output variable
     568
     569    LOGICAL, INTENT(IN) ::  is_global  !< true if variable is global (same on all PE)
     570
     571    REAL(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real32_0d  !< output variable
     572    REAL(KIND=8), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real64_0d  !< output variable
     573    REAL(wp),     POINTER,             INTENT(IN), OPTIONAL                   ::  values_realwp_0d  !< output variable
     574    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real32_1d  !< output variable
     575    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real64_1d  !< output variable
     576    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_realwp_1d  !< output variable
     577    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real32_2d  !< output variable
     578    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real64_2d  !< output variable
     579    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_realwp_2d  !< output variable
     580    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real32_3d  !< output variable
     581    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real64_3d  !< output variable
     582    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_realwp_3d  !< output variable
     583
     584
     585    return_value = 0
     586
     587    WRITE( temp_string, '(": write variable ",I6," into file ",I6)' ) variable_id, file_id
     588    CALL internal_message( 'debug', routine_name // TRIM( temp_string ) )
     589
     590    IF ( is_global )  CONTINUE  ! reqired to prevent compiler warning
     591
     592    IF ( .NOT. ANY( value_counts == 0 ) )  THEN
     593       WRITE( file_id )  variable_id
     594       WRITE( file_id )  bounds_start
     595       WRITE( file_id )  value_counts
     596       WRITE( file_id )  bounds_origin
     597!
     598!--    8bit integer output
     599       IF ( PRESENT( values_int8_0d ) )  THEN
     600          output_string = 'int8'
     601          WRITE( file_id )  output_string
     602          WRITE( file_id )  values_int8_0d
     603       ELSEIF ( PRESENT( values_int8_1d ) )  THEN
     604          output_string = 'int8'
     605          WRITE( file_id )  output_string
     606          WRITE( file_id )  values_int8_1d
     607       ELSEIF ( PRESENT( values_int8_2d ) )  THEN
     608          output_string = 'int8'
     609          WRITE( file_id )  output_string
     610          WRITE( file_id )  values_int8_2d
     611       ELSEIF ( PRESENT( values_int8_3d ) )  THEN
     612          output_string = 'int8'
     613          WRITE( file_id )  output_string
     614          WRITE( file_id )  values_int8_3d
     615!
     616!--    16bit integer output
     617       ELSEIF ( PRESENT( values_int16_0d ) )  THEN
     618          output_string = 'int16'
     619          WRITE( file_id )  output_string
     620          WRITE( file_id )  values_int16_0d
     621       ELSEIF ( PRESENT( values_int16_1d ) )  THEN
     622          output_string = 'int16'
     623          WRITE( file_id )  output_string
     624          WRITE( file_id )  values_int16_1d
     625       ELSEIF ( PRESENT( values_int16_2d ) )  THEN
     626          output_string = 'int16'
     627          WRITE( file_id )  output_string
     628          WRITE( file_id )  values_int16_2d
     629       ELSEIF ( PRESENT( values_int16_3d ) )  THEN
     630          output_string = 'int16'
     631          WRITE( file_id )  output_string
     632          WRITE( file_id )  values_int16_3d
     633!
     634!--    32bit integer output
     635       ELSEIF ( PRESENT( values_int32_0d ) )  THEN
     636          output_string = 'int32'
     637          WRITE( file_id )  output_string
     638          WRITE( file_id )  values_int32_0d
     639       ELSEIF ( PRESENT( values_int32_1d ) )  THEN
     640          output_string = 'int32'
     641          WRITE( file_id )  output_string
     642          WRITE( file_id )  values_int32_1d
     643       ELSEIF ( PRESENT( values_int32_2d ) )  THEN
     644          output_string = 'int32'
     645          WRITE( file_id )  output_string
     646          WRITE( file_id )  values_int32_2d
     647       ELSEIF ( PRESENT( values_int32_3d ) )  THEN
     648          output_string = 'int32'
     649          WRITE( file_id )  output_string
     650          WRITE( file_id )  values_int32_3d
     651!
     652!--    working-precision integer output
     653       ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
     654          output_string = 'intwp'
     655          WRITE( file_id )  output_string
     656          WRITE( file_id )  values_intwp_0d
     657       ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
     658          output_string = 'intwp'
     659          WRITE( file_id )  output_string
     660          WRITE( file_id )  values_intwp_1d
     661       ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
     662          output_string = 'intwp'
     663          WRITE( file_id )  output_string
     664          WRITE( file_id )  values_intwp_2d
     665       ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
     666          output_string = 'intwp'
     667          WRITE( file_id )  output_string
     668          WRITE( file_id )  values_intwp_3d
     669!
     670!--    32bit real output
     671       ELSEIF ( PRESENT( values_real32_0d ) )  THEN
     672          output_string = 'real32'
     673          WRITE( file_id )  output_string
     674          WRITE( file_id )  values_real32_0d
     675       ELSEIF ( PRESENT( values_real32_1d ) )  THEN
     676          output_string = 'real32'
     677          WRITE( file_id )  output_string
     678          WRITE( file_id )  values_real32_1d
     679       ELSEIF ( PRESENT( values_real32_2d ) )  THEN
     680          output_string = 'real32'
     681          WRITE( file_id )  output_string
     682          WRITE( file_id )  values_real32_2d
     683       ELSEIF ( PRESENT( values_real32_3d ) )  THEN
     684          output_string = 'real32'
     685          WRITE( file_id )  output_string
     686          WRITE( file_id )  values_real32_3d
     687!
     688!--    64bit real output
     689       ELSEIF ( PRESENT( values_real64_0d ) )  THEN
     690          output_string = 'real64'
     691          WRITE( file_id )  output_string
     692          WRITE( file_id )  values_real64_0d
     693       ELSEIF ( PRESENT( values_real64_1d ) )  THEN
     694          output_string = 'real64'
     695          WRITE( file_id )  output_string
     696          WRITE( file_id )  values_real64_1d
     697       ELSEIF ( PRESENT( values_real64_2d ) )  THEN
     698          output_string = 'real64'
     699          WRITE( file_id )  output_string
     700          WRITE( file_id )  values_real64_2d
     701       ELSEIF ( PRESENT( values_real64_3d ) )  THEN
     702          output_string = 'real64'
     703          WRITE( file_id )  output_string
     704          WRITE( file_id )  values_real64_3d
     705!
     706!--    working-precision real output
     707       ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
     708          output_string = 'realwp'
     709          WRITE( file_id )  output_string
     710          WRITE( file_id )  values_realwp_0d
     711       ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
     712          output_string = 'realwp'
     713          WRITE( file_id )  output_string
     714          WRITE( file_id )  values_realwp_1d
     715       ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
     716          output_string = 'realwp'
     717          WRITE( file_id )  output_string
     718          WRITE( file_id )  values_realwp_2d
     719       ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
     720          output_string = 'realwp'
     721          WRITE( file_id )  output_string
     722          WRITE( file_id )  values_realwp_3d
     723       ELSE
     724          return_value = 1
     725          CALL internal_message( 'error', routine_name // ': no values given' )
     726       ENDIF
     727
     728    ENDIF
     729
     730 END SUBROUTINE binary_write_variable
    721731
    722732!--------------------------------------------------------------------------------------------------!
     
    725735!> Close opened files.
    726736!--------------------------------------------------------------------------------------------------!
    727 SUBROUTINE binary_finalize( file_id, return_value )
    728 
    729    CHARACTER(LEN=charlen) ::  output_string  !< output string
    730 
    731    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_finalize'  !< name of this routine
    732 
    733    INTEGER, INTENT(IN)  ::  file_id       !< file ID
    734    INTEGER, INTENT(OUT) ::  return_value  !< return value
    735 
    736 
    737    IF ( config_file_open )  THEN
    738 
    739       output_string = '*** end config file ***'
    740       WRITE( config_file_unit )  output_string
    741 
    742       CLOSE( config_file_unit, IOSTAT=return_value )
    743 
    744       IF ( return_value /= 0 )  THEN
    745          CALL internal_message( 'error', routine_name // ': cannot close configuration file' )
    746       ELSE
    747          config_file_open = .FALSE.
    748       ENDIF
    749 
    750    ELSE
    751 
    752       return_value = 0
    753 
    754    ENDIF
    755 
    756    IF ( return_value == 0 )  THEN
    757 
    758       WRITE( temp_string, * ) file_id
    759       CALL internal_message( 'debug', routine_name // &
    760                              ': close file (file_id=' // TRIM( temp_string ) // ')' )
    761 
    762       CLOSE( file_id, IOSTAT=return_value )
    763       IF ( return_value /= 0 )  THEN
    764          WRITE( temp_string, * ) file_id
    765          CALL internal_message( 'error', routine_name // &
    766                                 ': cannot close file (file_id=' // TRIM( temp_string ) // ')' )
    767       ENDIF
    768 
    769    ENDIF
    770 
    771 END SUBROUTINE binary_finalize
     737 SUBROUTINE binary_finalize( file_id, return_value )
     738
     739    CHARACTER(LEN=charlen) ::  output_string  !< output string
     740
     741    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_finalize'  !< name of this routine
     742
     743    INTEGER, INTENT(IN)  ::  file_id       !< file ID
     744    INTEGER, INTENT(OUT) ::  return_value  !< return value
     745
     746
     747    IF ( config_file_open )  THEN
     748
     749       output_string = '*** end config file ***'
     750       WRITE( config_file_unit )  output_string
     751
     752       CLOSE( config_file_unit, IOSTAT=return_value )
     753
     754       IF ( return_value /= 0 )  THEN
     755          CALL internal_message( 'error', routine_name // ': cannot close configuration file' )
     756       ELSE
     757          config_file_open = .FALSE.
     758       ENDIF
     759
     760    ELSE
     761
     762       return_value = 0
     763
     764    ENDIF
     765
     766    IF ( return_value == 0 )  THEN
     767
     768       WRITE( temp_string, * ) file_id
     769       CALL internal_message( 'debug', routine_name // &
     770                              ': close file (file_id=' // TRIM( temp_string ) // ')' )
     771
     772       CLOSE( file_id, IOSTAT=return_value )
     773       IF ( return_value /= 0 )  THEN
     774          WRITE( temp_string, * ) file_id
     775          CALL internal_message( 'error', routine_name // &
     776                                 ': cannot close file (file_id=' // TRIM( temp_string ) // ')' )
     777       ENDIF
     778
     779    ENDIF
     780
     781 END SUBROUTINE binary_finalize
    772782
    773783!--------------------------------------------------------------------------------------------------!
     
    777787!> or creating the error message string.
    778788!--------------------------------------------------------------------------------------------------!
    779 SUBROUTINE internal_message( level, string )
    780 
    781    CHARACTER(LEN=*), INTENT(IN) ::  level   !< message importance level
    782    CHARACTER(LEN=*), INTENT(IN) ::  string  !< message string
    783 
    784 
    785    IF ( TRIM( level ) == 'error' )  THEN
    786 
    787       WRITE( internal_error_message, '(A,A)' ) ': ', string
    788 
    789    ELSEIF ( TRIM( level ) == 'debug'  .AND.  print_debug_output )  THEN
    790 
    791       WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
    792       FLUSH( debug_output_unit )
    793 
    794    ENDIF
    795 
    796 END SUBROUTINE internal_message
     789 SUBROUTINE internal_message( level, string )
     790
     791    CHARACTER(LEN=*), INTENT(IN) ::  level   !< message importance level
     792    CHARACTER(LEN=*), INTENT(IN) ::  string  !< message string
     793
     794
     795    IF ( TRIM( level ) == 'error' )  THEN
     796
     797       WRITE( internal_error_message, '(A,A)' ) ': ', string
     798
     799    ELSEIF ( TRIM( level ) == 'debug'  .AND.  print_debug_output )  THEN
     800
     801       WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
     802       FLUSH( debug_output_unit )
     803
     804    ENDIF
     805
     806 END SUBROUTINE internal_message
    797807
    798808!--------------------------------------------------------------------------------------------------!
     
    801811!> Return the last created error message.
    802812!--------------------------------------------------------------------------------------------------!
    803 FUNCTION binary_get_error_message() RESULT( error_message )
    804 
    805    CHARACTER(LEN=800) ::  error_message  !< return error message to main program
    806 
    807 
    808    error_message = TRIM( internal_error_message )
    809    
    810    internal_error_message = ''
    811 
    812 END FUNCTION binary_get_error_message
    813 
    814 END MODULE data_output_binary_module
     813 FUNCTION binary_get_error_message() RESULT( error_message )
     814
     815    CHARACTER(LEN=800) ::  error_message  !< return error message to main program
     816
     817
     818    error_message = TRIM( internal_error_message )
     819
     820    internal_error_message = ''
     821
     822 END FUNCTION binary_get_error_message
     823
     824 END MODULE data_output_binary_module
  • palm/trunk/SOURCE/data_output_module.f90

    r4141 r4147  
    2525! -----------------
    2626! $Id$
     27! corrected indentation according to coding standard
     28!
     29! 4141 2019-08-05 12:24:51Z gronemeier
    2730! Initial revision
    2831!
     
    5962!> @todo Convert variable if type of given values do not fit specified type.
    6063!--------------------------------------------------------------------------------------------------!
    61 MODULE data_output_module
    62 
    63    USE kinds
    64 
    65    USE data_output_netcdf4_module, &
    66       ONLY: netcdf4_init_dimension, &
    67             netcdf4_get_error_message, &
    68             netcdf4_stop_file_header_definition, &
    69             netcdf4_init_module, &
    70             netcdf4_init_variable, &
    71             netcdf4_finalize, &
    72             netcdf4_open_file, &
    73             netcdf4_write_attribute, &
    74             netcdf4_write_variable
    75 
    76    USE data_output_binary_module, &
    77       ONLY: binary_finalize, &
    78             binary_get_error_message, &
    79             binary_init_dimension, &
    80             binary_stop_file_header_definition, &
    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, PARAMETER ::  charlen = 100  !< maximum length of character variables
    90    INTEGER, PARAMETER ::  no_id = -1     !< default ID if no ID was assigned
    91 
    92    TYPE attribute_type
    93       CHARACTER(LEN=charlen) ::  data_type = ''  !< data type
    94       CHARACTER(LEN=charlen) ::  name            !< attribute name
    95       CHARACTER(LEN=charlen) ::  value_char      !< attribute value if character
    96       INTEGER(KIND=1)        ::  value_int8      !< attribute value if 8bit integer
    97       INTEGER(KIND=2)        ::  value_int16     !< attribute value if 16bit integer
    98       INTEGER(KIND=4)        ::  value_int32     !< attribute value if 32bit integer
    99       REAL(KIND=4)           ::  value_real32    !< attribute value if 32bit real
    100       REAL(KIND=8)           ::  value_real64    !< attribute value if 64bit real
    101    END TYPE attribute_type
    102 
    103    TYPE variable_type
    104       CHARACTER(LEN=charlen)                            ::  data_type = ''       !< data type
    105       CHARACTER(LEN=charlen)                            ::  name                 !< variable name
    106       INTEGER                                           ::  id = no_id           !< id within file
    107       LOGICAL                                           ::  is_global = .FALSE.  !< true if global variable
    108       CHARACTER(LEN=charlen), DIMENSION(:), ALLOCATABLE ::  dimension_names      !< list of dimension names used by variable
    109       INTEGER,                DIMENSION(:), ALLOCATABLE ::  dimension_ids        !< list of dimension ids used by variable
    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                                    ::  id = no_id            !< dimension id within file
    117       INTEGER                                    ::  length                !< length of dimension
    118       INTEGER                                    ::  length_mask           !< length of masked dimension
    119       INTEGER                                    ::  variable_id = no_id   !< associated variable id within file
    120       LOGICAL                                    ::  is_masked = .FALSE.   !< true if masked
    121       INTEGER,         DIMENSION(2)              ::  bounds                !< lower and upper bound of dimension
    122       INTEGER,         DIMENSION(:), ALLOCATABLE ::  masked_indices        !< list of masked indices of dimension
    123       INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE ::  masked_values_int8    !< masked dimension values if 16bit integer
    124       INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE ::  masked_values_int16   !< masked dimension values if 16bit integer
    125       INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE ::  masked_values_int32   !< masked dimension values if 32bit integer
    126       INTEGER(iwp),    DIMENSION(:), ALLOCATABLE ::  masked_values_intwp   !< masked dimension values if working-precision int
    127       INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE ::  values_int8           !< dimension values if 16bit integer
    128       INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE ::  values_int16          !< dimension values if 16bit integer
    129       INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE ::  values_int32          !< dimension values if 32bit integer
    130       INTEGER(iwp),    DIMENSION(:), ALLOCATABLE ::  values_intwp          !< dimension values if working-precision integer
    131       LOGICAL,         DIMENSION(:), ALLOCATABLE ::  mask                  !< mask
    132       REAL(KIND=4),    DIMENSION(:), ALLOCATABLE ::  masked_values_real32  !< masked dimension values if 32bit real
    133       REAL(KIND=8),    DIMENSION(:), ALLOCATABLE ::  masked_values_real64  !< masked dimension values if 64bit real
    134       REAL(wp),        DIMENSION(:), ALLOCATABLE ::  masked_values_realwp  !< masked dimension values if working-precision real
    135       REAL(KIND=4),    DIMENSION(:), ALLOCATABLE ::  values_real32         !< dimension values if 32bit real
    136       REAL(KIND=8),    DIMENSION(:), ALLOCATABLE ::  values_real64         !< dimension values if 64bit real
    137       REAL(wp),        DIMENSION(:), ALLOCATABLE ::  values_realwp         !< dimension values if working-precision real
    138       TYPE(attribute_type), DIMENSION(:), ALLOCATABLE ::  attributes       !< list of attributes
    139    END TYPE dimension_type
    140 
    141    TYPE file_type
    142       CHARACTER(LEN=charlen)                          ::  format = ''        !< file format
    143       CHARACTER(LEN=charlen)                          ::  name = ''          !< file name
    144       INTEGER                                         ::  id = no_id         !< id of file
    145       LOGICAL                                         ::  is_init = .FALSE.  !< true if initialized
    146       TYPE(attribute_type), DIMENSION(:), ALLOCATABLE ::  attributes         !< list of attributes
    147       TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  dimensions         !< list of dimensions
    148       TYPE(variable_type),  DIMENSION(:), ALLOCATABLE ::  variables          !< list of variables
    149    END TYPE file_type
    150 
    151 
    152    CHARACTER(LEN=charlen) ::  output_file_suffix = ''      !< file suffix added to each file name
    153    CHARACTER(LEN=800)     ::  internal_error_message = ''  !< string containing the last error message
    154    CHARACTER(LEN=800)     ::  temp_string                  !< dummy string
    155 
    156    INTEGER ::  debug_output_unit  !< Fortran Unit Number of the debug-output file
    157    INTEGER ::  nfiles = 0         !< number of files
    158    INTEGER ::  master_rank = 0    !< master rank for tasks to be executed by single PE only
    159    INTEGER ::  output_group_comm  !< MPI communicator addressing all MPI ranks which participate in output
    160 
    161    LOGICAL ::  print_debug_output = .FALSE.  !< if true, debug output is printed
    162 
    163    TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  files  !< file list
    164 
    165    SAVE
    166 
    167    PRIVATE
    168 
    169    !> Initialize the data-output module
    170    INTERFACE dom_init
    171       MODULE PROCEDURE dom_init
    172    END INTERFACE dom_init
    173 
    174    !> Add files to database
    175    INTERFACE dom_def_file
    176       MODULE PROCEDURE dom_def_file
    177    END INTERFACE dom_def_file
    178 
    179    !> Add dimensions to database
    180    INTERFACE dom_def_dim
    181       MODULE PROCEDURE dom_def_dim
    182    END INTERFACE dom_def_dim
    183 
    184    !> Add variables to database
    185    INTERFACE dom_def_var
    186       MODULE PROCEDURE dom_def_var
    187    END INTERFACE dom_def_var
    188 
    189    !> Add attributes to database
    190    INTERFACE dom_def_att
    191       MODULE PROCEDURE dom_def_att_char
    192       MODULE PROCEDURE dom_def_att_int8
    193       MODULE PROCEDURE dom_def_att_int16
    194       MODULE PROCEDURE dom_def_att_int32
    195       MODULE PROCEDURE dom_def_att_real32
    196       MODULE PROCEDURE dom_def_att_real64
    197    END INTERFACE dom_def_att
    198 
    199    !> Prepare for output: evaluate database and create files
    200    INTERFACE dom_def_end
    201       MODULE PROCEDURE dom_def_end
    202    END INTERFACE dom_def_end
    203 
    204    !> Write variables to file
    205    INTERFACE dom_write_var
    206       MODULE PROCEDURE dom_write_var
    207    END INTERFACE dom_write_var
    208 
    209    !> Last actions required for output befor termination
    210    INTERFACE dom_finalize_output
    211       MODULE PROCEDURE dom_finalize_output
    212    END INTERFACE dom_finalize_output
    213 
    214    !> Return error message
    215    INTERFACE dom_get_error_message
    216       MODULE PROCEDURE dom_get_error_message
    217    END INTERFACE dom_get_error_message
    218 
    219    !> Write database to debug output
    220    INTERFACE dom_database_debug_output
    221       MODULE PROCEDURE dom_database_debug_output
    222    END INTERFACE dom_database_debug_output
    223 
    224    PUBLIC &
    225       dom_init, &
    226       dom_def_file, &
    227       dom_def_dim, &
    228       dom_def_var, &
    229       dom_def_att, &
    230       dom_def_end, &
    231       dom_write_var, &
    232       dom_finalize_output, &
    233       dom_get_error_message, &
    234       dom_database_debug_output
    235 
    236 CONTAINS
     64 MODULE data_output_module
     65
     66    USE kinds
     67
     68    USE data_output_netcdf4_module, &
     69       ONLY: netcdf4_init_dimension, &
     70             netcdf4_get_error_message, &
     71             netcdf4_stop_file_header_definition, &
     72             netcdf4_init_module, &
     73             netcdf4_init_variable, &
     74             netcdf4_finalize, &
     75             netcdf4_open_file, &
     76             netcdf4_write_attribute, &
     77             netcdf4_write_variable
     78
     79    USE data_output_binary_module, &
     80       ONLY: binary_finalize, &
     81             binary_get_error_message, &
     82             binary_init_dimension, &
     83             binary_stop_file_header_definition, &
     84             binary_init_module, &
     85             binary_init_variable, &
     86             binary_open_file, &
     87             binary_write_attribute, &
     88             binary_write_variable
     89
     90    IMPLICIT NONE
     91
     92    INTEGER, PARAMETER ::  charlen = 100  !< maximum length of character variables
     93    INTEGER, PARAMETER ::  no_id = -1     !< default ID if no ID was assigned
     94
     95    TYPE attribute_type
     96       CHARACTER(LEN=charlen) ::  data_type = ''  !< data type
     97       CHARACTER(LEN=charlen) ::  name            !< attribute name
     98       CHARACTER(LEN=charlen) ::  value_char      !< attribute value if character
     99       INTEGER(KIND=1)        ::  value_int8      !< attribute value if 8bit integer
     100       INTEGER(KIND=2)        ::  value_int16     !< attribute value if 16bit integer
     101       INTEGER(KIND=4)        ::  value_int32     !< attribute value if 32bit integer
     102       REAL(KIND=4)           ::  value_real32    !< attribute value if 32bit real
     103       REAL(KIND=8)           ::  value_real64    !< attribute value if 64bit real
     104    END TYPE attribute_type
     105
     106    TYPE variable_type
     107       CHARACTER(LEN=charlen)                            ::  data_type = ''       !< data type
     108       CHARACTER(LEN=charlen)                            ::  name                 !< variable name
     109       INTEGER                                           ::  id = no_id           !< id within file
     110       LOGICAL                                           ::  is_global = .FALSE.  !< true if global variable
     111       CHARACTER(LEN=charlen), DIMENSION(:), ALLOCATABLE ::  dimension_names      !< list of dimension names used by variable
     112       INTEGER,                DIMENSION(:), ALLOCATABLE ::  dimension_ids        !< list of dimension ids used by variable
     113       TYPE(attribute_type),   DIMENSION(:), ALLOCATABLE ::  attributes           !< list of attributes
     114    END TYPE variable_type
     115
     116    TYPE dimension_type
     117       CHARACTER(LEN=charlen)                     ::  data_type = ''        !< data type
     118       CHARACTER(LEN=charlen)                     ::  name                  !< dimension name
     119       INTEGER                                    ::  id = no_id            !< dimension id within file
     120       INTEGER                                    ::  length                !< length of dimension
     121       INTEGER                                    ::  length_mask           !< length of masked dimension
     122       INTEGER                                    ::  variable_id = no_id   !< associated variable id within file
     123       LOGICAL                                    ::  is_masked = .FALSE.   !< true if masked
     124       INTEGER,         DIMENSION(2)              ::  bounds                !< lower and upper bound of dimension
     125       INTEGER,         DIMENSION(:), ALLOCATABLE ::  masked_indices        !< list of masked indices of dimension
     126       INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE ::  masked_values_int8    !< masked dimension values if 16bit integer
     127       INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE ::  masked_values_int16   !< masked dimension values if 16bit integer
     128       INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE ::  masked_values_int32   !< masked dimension values if 32bit integer
     129       INTEGER(iwp),    DIMENSION(:), ALLOCATABLE ::  masked_values_intwp   !< masked dimension values if working-precision int
     130       INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE ::  values_int8           !< dimension values if 16bit integer
     131       INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE ::  values_int16          !< dimension values if 16bit integer
     132       INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE ::  values_int32          !< dimension values if 32bit integer
     133       INTEGER(iwp),    DIMENSION(:), ALLOCATABLE ::  values_intwp          !< dimension values if working-precision integer
     134       LOGICAL,         DIMENSION(:), ALLOCATABLE ::  mask                  !< mask
     135       REAL(KIND=4),    DIMENSION(:), ALLOCATABLE ::  masked_values_real32  !< masked dimension values if 32bit real
     136       REAL(KIND=8),    DIMENSION(:), ALLOCATABLE ::  masked_values_real64  !< masked dimension values if 64bit real
     137       REAL(wp),        DIMENSION(:), ALLOCATABLE ::  masked_values_realwp  !< masked dimension values if working-precision real
     138       REAL(KIND=4),    DIMENSION(:), ALLOCATABLE ::  values_real32         !< dimension values if 32bit real
     139       REAL(KIND=8),    DIMENSION(:), ALLOCATABLE ::  values_real64         !< dimension values if 64bit real
     140       REAL(wp),        DIMENSION(:), ALLOCATABLE ::  values_realwp         !< dimension values if working-precision real
     141       TYPE(attribute_type), DIMENSION(:), ALLOCATABLE ::  attributes       !< list of attributes
     142    END TYPE dimension_type
     143
     144    TYPE file_type
     145       CHARACTER(LEN=charlen)                          ::  format = ''        !< file format
     146       CHARACTER(LEN=charlen)                          ::  name = ''          !< file name
     147       INTEGER                                         ::  id = no_id         !< id of file
     148       LOGICAL                                         ::  is_init = .FALSE.  !< true if initialized
     149       TYPE(attribute_type), DIMENSION(:), ALLOCATABLE ::  attributes         !< list of attributes
     150       TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  dimensions         !< list of dimensions
     151       TYPE(variable_type),  DIMENSION(:), ALLOCATABLE ::  variables          !< list of variables
     152    END TYPE file_type
     153
     154
     155    CHARACTER(LEN=charlen) ::  output_file_suffix = ''      !< file suffix added to each file name
     156    CHARACTER(LEN=800)     ::  internal_error_message = ''  !< string containing the last error message
     157    CHARACTER(LEN=800)     ::  temp_string                  !< dummy string
     158
     159    INTEGER ::  debug_output_unit  !< Fortran Unit Number of the debug-output file
     160    INTEGER ::  nfiles = 0         !< number of files
     161    INTEGER ::  master_rank = 0    !< master rank for tasks to be executed by single PE only
     162    INTEGER ::  output_group_comm  !< MPI communicator addressing all MPI ranks which participate in output
     163
     164    LOGICAL ::  print_debug_output = .FALSE.  !< if true, debug output is printed
     165
     166    TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  files  !< file list
     167
     168    SAVE
     169
     170    PRIVATE
     171
     172    !> Initialize the data-output module
     173    INTERFACE dom_init
     174       MODULE PROCEDURE dom_init
     175    END INTERFACE dom_init
     176
     177    !> Add files to database
     178    INTERFACE dom_def_file
     179       MODULE PROCEDURE dom_def_file
     180    END INTERFACE dom_def_file
     181
     182    !> Add dimensions to database
     183    INTERFACE dom_def_dim
     184       MODULE PROCEDURE dom_def_dim
     185    END INTERFACE dom_def_dim
     186
     187    !> Add variables to database
     188    INTERFACE dom_def_var
     189       MODULE PROCEDURE dom_def_var
     190    END INTERFACE dom_def_var
     191
     192    !> Add attributes to database
     193    INTERFACE dom_def_att
     194       MODULE PROCEDURE dom_def_att_char
     195       MODULE PROCEDURE dom_def_att_int8
     196       MODULE PROCEDURE dom_def_att_int16
     197       MODULE PROCEDURE dom_def_att_int32
     198       MODULE PROCEDURE dom_def_att_real32
     199       MODULE PROCEDURE dom_def_att_real64
     200    END INTERFACE dom_def_att
     201
     202    !> Prepare for output: evaluate database and create files
     203    INTERFACE dom_def_end
     204       MODULE PROCEDURE dom_def_end
     205    END INTERFACE dom_def_end
     206
     207    !> Write variables to file
     208    INTERFACE dom_write_var
     209       MODULE PROCEDURE dom_write_var
     210    END INTERFACE dom_write_var
     211
     212    !> Last actions required for output befor termination
     213    INTERFACE dom_finalize_output
     214       MODULE PROCEDURE dom_finalize_output
     215    END INTERFACE dom_finalize_output
     216
     217    !> Return error message
     218    INTERFACE dom_get_error_message
     219       MODULE PROCEDURE dom_get_error_message
     220    END INTERFACE dom_get_error_message
     221
     222    !> Write database to debug output
     223    INTERFACE dom_database_debug_output
     224       MODULE PROCEDURE dom_database_debug_output
     225    END INTERFACE dom_database_debug_output
     226
     227    PUBLIC &
     228       dom_init, &
     229       dom_def_file, &
     230       dom_def_dim, &
     231       dom_def_var, &
     232       dom_def_att, &
     233       dom_def_end, &
     234       dom_write_var, &
     235       dom_finalize_output, &
     236       dom_get_error_message, &
     237       dom_database_debug_output
     238
     239 CONTAINS
    237240
    238241
     
    247250!> prevents that multiple groups try to open and write to the same output file.
    248251!--------------------------------------------------------------------------------------------------!
    249 SUBROUTINE dom_init( file_suffix_of_output_group, mpi_comm_of_output_group, master_output_rank, &
    250                      program_debug_output_unit, debug_output )
    251 
    252    CHARACTER(LEN=*), INTENT(IN), OPTIONAL ::  file_suffix_of_output_group  !< file-name suffix added to each file;
    253                                                                            !> must be unique for each output group
    254 
    255    INTEGER, INTENT(IN), OPTIONAL ::  master_output_rank         !< MPI rank executing tasks which must
    256                                                                 !> be executed by a single PE only
    257    INTEGER, INTENT(IN)           ::  mpi_comm_of_output_group   !< MPI communicator specifying the MPI group
    258                                                                 !> which participate in the output
    259    INTEGER, INTENT(IN)           ::  program_debug_output_unit  !< file unit number for debug output
    260 
    261    LOGICAL, INTENT(IN)           ::  debug_output               !< if true, debug output is printed
    262 
    263 
    264    IF ( PRESENT( file_suffix_of_output_group ) )  output_file_suffix = file_suffix_of_output_group
    265    IF ( PRESENT( master_output_rank ) )  master_rank = master_output_rank
    266 
    267    output_group_comm = mpi_comm_of_output_group
    268 
    269    debug_output_unit = program_debug_output_unit
    270    print_debug_output = debug_output
    271 
    272    CALL binary_init_module( output_file_suffix, output_group_comm, master_rank, &
    273                             debug_output_unit, debug_output, no_id )
    274 
    275    CALL netcdf4_init_module( output_file_suffix, output_group_comm, master_rank, &
    276                             debug_output_unit, debug_output, no_id )
    277 
    278 END SUBROUTINE dom_init
     252 SUBROUTINE dom_init( file_suffix_of_output_group, mpi_comm_of_output_group, master_output_rank, &
     253                      program_debug_output_unit, debug_output )
     254
     255    CHARACTER(LEN=*), INTENT(IN), OPTIONAL ::  file_suffix_of_output_group  !< file-name suffix added to each file;
     256                                                                            !> must be unique for each output group
     257
     258    INTEGER, INTENT(IN), OPTIONAL ::  master_output_rank         !< MPI rank executing tasks which must
     259                                                                 !> be executed by a single PE only
     260    INTEGER, INTENT(IN)           ::  mpi_comm_of_output_group   !< MPI communicator specifying the MPI group
     261                                                                 !> which participate in the output
     262    INTEGER, INTENT(IN)           ::  program_debug_output_unit  !< file unit number for debug output
     263
     264    LOGICAL, INTENT(IN)           ::  debug_output               !< if true, debug output is printed
     265
     266
     267    IF ( PRESENT( file_suffix_of_output_group ) )  output_file_suffix = file_suffix_of_output_group
     268    IF ( PRESENT( master_output_rank ) )  master_rank = master_output_rank
     269
     270    output_group_comm = mpi_comm_of_output_group
     271
     272    debug_output_unit = program_debug_output_unit
     273    print_debug_output = debug_output
     274
     275    CALL binary_init_module( output_file_suffix, output_group_comm, master_rank, &
     276                             debug_output_unit, debug_output, no_id )
     277
     278    CALL netcdf4_init_module( output_file_suffix, output_group_comm, master_rank, &
     279                             debug_output_unit, debug_output, no_id )
     280
     281 END SUBROUTINE dom_init
    279282
    280283!--------------------------------------------------------------------------------------------------!
     
    285288!>   status = dom_def_file( 'my_output_file_name', 'binary' )
    286289!--------------------------------------------------------------------------------------------------!
    287 FUNCTION dom_def_file( file_name, file_format ) RESULT( return_value )
    288 
    289    CHARACTER(LEN=*), INTENT(IN) ::  file_name    !< name of file to be created
    290    CHARACTER(LEN=*), INTENT(IN) ::  file_format  !< format of file to be created
    291 
    292    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_file'  !< name of this routine
    293 
    294    INTEGER ::  f             !< loop index
    295    INTEGER ::  return_value  !< return value
    296 
    297    TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  files_tmp  !< temporary file list
    298 
    299 
    300    return_value = 0
    301 
    302    CALL internal_message( 'debug', routine_name // ': define file "' // TRIM( file_name ) // '"' )
    303 
    304    !-- Allocate file list or extend it by 1
    305    IF ( .NOT. ALLOCATED( files ) ) THEN
    306 
    307       nfiles = 1
    308       ALLOCATE( files(nfiles) )
    309 
    310    ELSE
    311 
    312       nfiles = SIZE( files )
    313       !-- Check if file already exists
    314       DO  f = 1, nfiles
    315          IF ( files(f)%name == TRIM( file_name ) )  THEN
    316             return_value = 1
    317             CALL internal_message( 'error', routine_name // &
    318                     ': file "' // TRIM( file_name ) // '" already exists' )
    319             EXIT
    320          ENDIF
    321       ENDDO
    322 
    323       !-- Extend file list
    324       IF ( return_value == 0 )  THEN
    325          ALLOCATE( files_tmp(nfiles) )
    326          files_tmp = files
    327          DEALLOCATE( files )
    328          nfiles = nfiles + 1
    329          ALLOCATE( files(nfiles) )
    330          files(:nfiles-1) = files_tmp
    331          DEALLOCATE( files_tmp )
    332       ENDIF
    333 
    334    ENDIF
    335 
    336    !-- Add new file to database
    337    IF ( return_value == 0 )  THEN
    338       files(nfiles)%name = TRIM( file_name )
    339       files(nfiles)%format = TRIM( file_format )
    340    ENDIF
    341 
    342 END FUNCTION dom_def_file
     290 FUNCTION dom_def_file( file_name, file_format ) RESULT( return_value )
     291
     292    CHARACTER(LEN=*), INTENT(IN) ::  file_name    !< name of file to be created
     293    CHARACTER(LEN=*), INTENT(IN) ::  file_format  !< format of file to be created
     294
     295    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_file'  !< name of this routine
     296
     297    INTEGER ::  f             !< loop index
     298    INTEGER ::  return_value  !< return value
     299
     300    TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  files_tmp  !< temporary file list
     301
     302
     303    return_value = 0
     304
     305    CALL internal_message( 'debug', routine_name // ': define file "' // TRIM( file_name ) // '"' )
     306!
     307!-- Allocate file list or extend it by 1
     308    IF ( .NOT. ALLOCATED( files ) ) THEN
     309
     310       nfiles = 1
     311       ALLOCATE( files(nfiles) )
     312
     313    ELSE
     314
     315       nfiles = SIZE( files )
     316!
     317!--    Check if file already exists
     318       DO  f = 1, nfiles
     319          IF ( files(f)%name == TRIM( file_name ) )  THEN
     320             return_value = 1
     321             CALL internal_message( 'error', routine_name // &
     322                     ': file "' // TRIM( file_name ) // '" already exists' )
     323             EXIT
     324          ENDIF
     325       ENDDO
     326!
     327!--    Extend file list
     328       IF ( return_value == 0 )  THEN
     329          ALLOCATE( files_tmp(nfiles) )
     330          files_tmp = files
     331          DEALLOCATE( files )
     332          nfiles = nfiles + 1
     333          ALLOCATE( files(nfiles) )
     334          files(:nfiles-1) = files_tmp
     335          DEALLOCATE( files_tmp )
     336       ENDIF
     337
     338    ENDIF
     339!
     340!-- Add new file to database
     341    IF ( return_value == 0 )  THEN
     342       files(nfiles)%name = TRIM( file_name )
     343       files(nfiles)%format = TRIM( file_format )
     344    ENDIF
     345
     346 END FUNCTION dom_def_file
    343347
    344348!--------------------------------------------------------------------------------------------------!
     
    370374!> @todo Convert given values into selected output_type.
    371375!--------------------------------------------------------------------------------------------------!
    372 FUNCTION dom_def_dim( file_name, dimension_name, output_type, bounds,        &
    373                       values_int8, values_int16, values_int32, values_intwp, &
    374                       values_real32, values_real64, values_realwp,           &
    375                       mask ) RESULT( return_value )
    376 
    377    CHARACTER(LEN=*), INTENT(IN) ::  file_name       !< name of file
    378    CHARACTER(LEN=*), INTENT(IN) ::  dimension_name  !< name of dimension
    379    CHARACTER(LEN=*), INTENT(IN) ::  output_type     !< data type of dimension variable in output file
    380 
    381    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_dim'  !< name of this routine
    382 
    383    INTEGER ::  d             !< loop index
    384    INTEGER ::  f             !< loop index
    385    INTEGER ::  i             !< loop index
    386    INTEGER ::  j             !< loop index
    387    INTEGER ::  ndims         !< number of dimensions in file
    388    INTEGER ::  return_value  !< return value
    389 
    390    INTEGER,         DIMENSION(:), INTENT(IN)           ::  bounds         !< lower and upper bound of dimension variable
    391    INTEGER(KIND=1), DIMENSION(:), INTENT(IN), OPTIONAL ::  values_int8    !< values of dimension
    392    INTEGER(KIND=2), DIMENSION(:), INTENT(IN), OPTIONAL ::  values_int16   !< values of dimension
    393    INTEGER(KIND=4), DIMENSION(:), INTENT(IN), OPTIONAL ::  values_int32   !< values of dimension
    394    INTEGER(iwp),    DIMENSION(:), INTENT(IN), OPTIONAL ::  values_intwp   !< values of dimension
    395 
    396    LOGICAL,         DIMENSION(:), INTENT(IN), OPTIONAL ::  mask           !< mask of dimesion
    397 
    398    REAL(KIND=4),    DIMENSION(:), INTENT(IN), OPTIONAL ::  values_real32  !< values of dimension
    399    REAL(KIND=8),    DIMENSION(:), INTENT(IN), OPTIONAL ::  values_real64  !< values of dimension
    400    REAL(wp),        DIMENSION(:), INTENT(IN), OPTIONAL ::  values_realwp  !< values of dimension
    401 
    402    TYPE(dimension_type)                            ::  dimension       !< new dimension
    403    TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  dimensions_tmp  !< temporary dimension list
    404 
    405 
    406    return_value = 0
    407 
    408    CALL internal_message( 'debug', routine_name //                    &
    409                           ': define dimension ' //                    &
    410                           '(dimension "' // TRIM( dimension_name ) // &
    411                           '", file "' // TRIM( file_name ) // '")' )
    412 
    413    dimension%name      = TRIM( dimension_name )
    414    dimension%data_type = TRIM( output_type )
    415 
    416    !-- Check dimension bounds and allocate dimension according to bounds
    417    IF ( SIZE( bounds ) == 1 )  THEN
    418 
    419       !-- Dimension has only lower bound, which means it changes its size
    420       !-- during simulation.
    421       !-- Set length to -1 as indicator.
    422       dimension%bounds(:) = bounds(1)
    423       dimension%length    = -1
    424 
    425       IF ( PRESENT( mask ) )  THEN
    426          return_value = 1
    427          CALL internal_message( 'error', routine_name //                      &
    428                                 ': unlimited dimensions cannot be masked ' // &
    429                                 '(dimension "' // TRIM( dimension_name ) //   &
    430                                 '", file "' // TRIM( file_name ) // '")!' )
    431       ENDIF
    432 
    433    ELSEIF ( SIZE( bounds ) == 2 )  THEN
    434 
    435       dimension%bounds = bounds
    436       dimension%length = bounds(2) - bounds(1) + 1
    437 
    438       !-- Save dimension values
    439       IF ( PRESENT( values_int8 ) )  THEN
    440          ALLOCATE( dimension%values_int8(dimension%bounds(1):dimension%bounds(2)) )
    441          IF ( SIZE( values_int8 ) == dimension%length )  THEN
    442             dimension%values_int8 = values_int8
    443          ELSEIF ( SIZE( values_int8 ) == 1 )  THEN
    444             dimension%values_int8(:) = values_int8(1)
    445          ELSE
    446             return_value = 2
    447          ENDIF
    448       ELSEIF( PRESENT( values_int16 ) )  THEN
    449          ALLOCATE( dimension%values_int16(dimension%bounds(1):dimension%bounds(2)) )
    450          IF ( SIZE( values_int16 ) == dimension%length )  THEN
    451             dimension%values_int16 = values_int16
    452          ELSEIF ( SIZE( values_int16 ) == 1 )  THEN
    453             dimension%values_int16(:) = values_int16(1)
    454          ELSE
    455             return_value = 2
    456          ENDIF
    457       ELSEIF( PRESENT( values_int32 ) )  THEN
    458          ALLOCATE( dimension%values_int32(dimension%bounds(1):dimension%bounds(2)) )
    459          IF ( SIZE( values_int32 ) == dimension%length )  THEN
    460             dimension%values_int32 = values_int32
    461          ELSEIF ( SIZE( values_int32 ) == 1 )  THEN
    462             dimension%values_int32(:) = values_int32(1)
    463          ELSE
    464             return_value = 2
    465          ENDIF
    466       ELSEIF( PRESENT( values_intwp ) )  THEN
    467          ALLOCATE( dimension%values_intwp(dimension%bounds(1):dimension%bounds(2)) )
    468          IF ( SIZE( values_intwp ) == dimension%length )  THEN
    469             dimension%values_intwp = values_intwp
    470          ELSEIF ( SIZE( values_intwp ) == 1 )  THEN
    471             dimension%values_intwp(:) = values_intwp(1)
    472          ELSE
    473             return_value = 2
    474          ENDIF
    475       ELSEIF( PRESENT( values_real32 ) )  THEN
    476          ALLOCATE( dimension%values_real32(dimension%bounds(1):dimension%bounds(2)) )
    477          IF ( SIZE( values_real32 ) == dimension%length )  THEN
    478             dimension%values_real32 = values_real32
    479          ELSEIF ( SIZE( values_real32 ) == 1 )  THEN
    480             dimension%values_real32(:) = values_real32(1)
    481          ELSE
    482             return_value = 2
    483          ENDIF
    484       ELSEIF( PRESENT( values_real64 ) )  THEN
    485          ALLOCATE( dimension%values_real64(dimension%bounds(1):dimension%bounds(2)) )
    486          IF ( SIZE( values_real64 ) == dimension%length )  THEN
    487             dimension%values_real64 = values_real64
    488          ELSEIF ( SIZE( values_real64 ) == 1 )  THEN
    489             dimension%values_real64(:) = values_real64(1)
    490          ELSE
    491             return_value = 2
    492          ENDIF
    493       ELSEIF( PRESENT( values_realwp ) )  THEN
    494          ALLOCATE( dimension%values_realwp(dimension%bounds(1):dimension%bounds(2)) )
    495          IF ( SIZE( values_realwp ) == dimension%length )  THEN
    496             dimension%values_realwp = values_realwp
    497          ELSEIF ( SIZE( values_realwp ) == 1 )  THEN
    498             dimension%values_realwp(:) = values_realwp(1)
    499          ELSE
    500             return_value = 2
    501          ENDIF
    502       ELSE
    503          return_value = 1
    504          CALL internal_message( 'error', routine_name //                    &
    505                                 ': no values given ' //                     &
    506                                 '(dimension "' // TRIM( dimension_name ) // &
    507                                 '", file "' // TRIM( file_name ) // '")!' )
    508       ENDIF
    509 
    510       IF ( return_value == 2 )  THEN
    511          return_value = 1
    512          CALL internal_message( 'error', routine_name //                               &
    513                                 ': number of values and given bounds do not match ' // &
    514                                 '(dimension "' // TRIM( dimension_name ) //            &
    515                                 '", file "' // TRIM( file_name ) // '")!' )
    516       ENDIF
    517 
    518       !-- Initialize mask
    519       IF ( PRESENT( mask )  .AND.  return_value == 0 )  THEN
    520 
    521          IF ( dimension%length == SIZE( mask ) )  THEN
    522 
    523             IF ( ALL( mask ) )  THEN
    524 
    525                CALL internal_message( 'debug', routine_name //                              &
    526                                       ': mask contains only TRUE values. Ignoring mask ' // &
    527                                       '(dimension "' // TRIM( dimension_name ) //           &
    528                                       '", file "' // TRIM( file_name ) // '")!' )
    529 
    530             ELSE
    531 
    532                dimension%is_masked = .TRUE.
    533                dimension%length_mask = COUNT( mask )
    534 
    535                ALLOCATE( dimension%mask(dimension%bounds(1):dimension%bounds(2)) )
    536                ALLOCATE( dimension%masked_indices(0:dimension%length_mask-1) )
    537 
    538                dimension%mask = mask
    539 
    540                !-- Save masked positions and masked values
    541                IF ( ALLOCATED( dimension%values_int8 ) )  THEN
    542 
    543                   ALLOCATE( dimension%masked_values_int8(0:dimension%length_mask-1) )
    544                   j = 0
    545                   DO  i = dimension%bounds(1), dimension%bounds(2)
    546                      IF ( dimension%mask(i) )  THEN
    547                         dimension%masked_values_int8(j) = dimension%values_int8(i)
    548                         dimension%masked_indices(j) = i
    549                         j = j + 1
    550                      ENDIF
    551                   ENDDO
    552 
    553                ELSEIF ( ALLOCATED( dimension%values_int16 ) )  THEN
    554 
    555                   ALLOCATE( dimension%masked_values_int16(0:dimension%length_mask-1) )
    556                   j = 0
    557                   DO  i = dimension%bounds(1), dimension%bounds(2)
    558                      IF ( dimension%mask(i) )  THEN
    559                         dimension%masked_values_int16(j) = dimension%values_int16(i)
    560                         dimension%masked_indices(j) = i
    561                         j = j + 1
    562                      ENDIF
    563                   ENDDO
    564 
    565                ELSEIF ( ALLOCATED( dimension%values_int32 ) )  THEN
    566 
    567                   ALLOCATE( dimension%masked_values_int32(0:dimension%length_mask-1) )
    568                   j = 0
    569                   DO  i =dimension%bounds(1), dimension%bounds(2)
    570                      IF ( dimension%mask(i) )  THEN
    571                         dimension%masked_values_int32(j) = dimension%values_int32(i)
    572                         dimension%masked_indices(j) = i
    573                         j = j + 1
    574                      ENDIF
    575                   ENDDO
    576 
    577                ELSEIF ( ALLOCATED( dimension%values_intwp ) )  THEN
    578 
    579                   ALLOCATE( dimension%masked_values_intwp(0:dimension%length_mask-1) )
    580                   j = 0
    581                   DO  i = dimension%bounds(1), dimension%bounds(2)
    582                      IF ( dimension%mask(i) )  THEN
    583                         dimension%masked_values_intwp(j) = dimension%values_intwp(i)
    584                         dimension%masked_indices(j) = i
    585                         j = j + 1
    586                      ENDIF
    587                   ENDDO
    588 
    589                ELSEIF ( ALLOCATED( dimension%values_real32 ) )  THEN
    590 
    591                   ALLOCATE( dimension%masked_values_real32(0:dimension%length_mask-1) )
    592                   j = 0
    593                   DO  i = dimension%bounds(1), dimension%bounds(2)
    594                      IF ( dimension%mask(i) )  THEN
    595                         dimension%masked_values_real32(j) = dimension%values_real32(i)
    596                         dimension%masked_indices(j) = i
    597                         j = j + 1
    598                      ENDIF
    599                   ENDDO
    600 
    601                ELSEIF ( ALLOCATED(dimension%values_real64) )  THEN
    602 
    603                   ALLOCATE( dimension%masked_values_real64(0:dimension%length_mask-1) )
    604                   j = 0
    605                   DO  i = dimension%bounds(1), dimension%bounds(2)
    606                      IF ( dimension%mask(i) )  THEN
    607                         dimension%masked_values_real64(j) = dimension%values_real64(i)
    608                         dimension%masked_indices(j) = i
    609                         j = j + 1
    610                      ENDIF
    611                   ENDDO
    612 
    613                ELSEIF ( ALLOCATED(dimension%values_realwp) )  THEN
    614 
    615                   ALLOCATE( dimension%masked_values_realwp(0:dimension%length_mask-1) )
    616                   j = 0
    617                   DO  i = dimension%bounds(1), dimension%bounds(2)
    618                      IF ( dimension%mask(i) )  THEN
    619                         dimension%masked_values_realwp(j) = dimension%values_realwp(i)
    620                         dimension%masked_indices(j) = i
    621                         j = j + 1
    622                      ENDIF
    623                   ENDDO
    624 
    625                ENDIF
    626 
    627             ENDIF  ! if not all mask = true
    628 
    629          ELSE
    630             return_value = 1
    631             CALL internal_message( 'error', routine_name //                           &
    632                                    ': size of mask and given bounds do not match ' // &
    633                                    '(dimension "' // TRIM( dimension_name ) //        &
    634                                    '", file "' // TRIM( file_name ) // '")!' )
    635          ENDIF
    636 
    637       ENDIF
    638 
    639    ELSE
    640 
    641       return_value = 1
    642       CALL internal_message( 'error', routine_name //                                       &
    643                              ': at least one but no more than two bounds must be given ' // &
    644                              '(dimension "' // TRIM( dimension_name ) //                    &
    645                              '", file "' // TRIM( file_name ) // '")!' )
    646 
    647    ENDIF
    648 
    649    !-- Add dimension to database
    650    IF ( return_value == 0 )  THEN
    651 
    652       DO  f = 1, nfiles
    653 
    654          IF ( TRIM( file_name ) == files(f)%name )  THEN
    655 
    656             IF ( files(f)%is_init )  THEN
    657 
    658                return_value = 1
    659                CALL internal_message( 'error', routine_name //                      &
    660                                       ': file already initialized. ' //             &
    661                                       'No further dimension definition allowed ' // &
    662                                       '(dimension "' // TRIM( dimension_name ) //   &
    663                                       '", file "' // TRIM( file_name ) // '")!' )
    664                EXIT
    665 
    666             ELSEIF ( .NOT. ALLOCATED( files(f)%dimensions ) )  THEN
    667 
    668                ndims = 1
    669                ALLOCATE( files(f)%dimensions(ndims) )
    670 
    671             ELSE
    672 
    673                !-- Check if any variable of the same name as the new dimension is already defined
    674                IF ( ALLOCATED( files(f)%variables ) )  THEN
    675                   DO  i = 1, SIZE( files(f)%variables )
    676                      IF ( files(f)%variables(i)%name == dimension%name )  THEN
    677                         return_value = 1
    678                         CALL internal_message( 'error', routine_name //                    &
    679                                 ': file already has a variable of this name defined. ' //  &
    680                                 'Defining a dimension of the same name is not allowed ' // &
    681                                 '(dimension "' // TRIM( dimension_name ) //                &
    682                                 '", file "' // TRIM( file_name ) // '")!' )
    683                         EXIT
    684                      ENDIF
    685                   ENDDO
    686                ENDIF
    687 
    688                IF ( return_value == 0 )  THEN
    689                   !-- Check if dimension already exists in file
    690                   ndims = SIZE( files(f)%dimensions )
    691 
    692                   DO  d = 1, ndims
    693                      IF ( files(f)%dimensions(d)%name == dimension%name )  THEN
    694                         return_value = 1
    695                         CALL internal_message( 'error', routine_name //     &
    696                                 ': dimension already exists in file ' //    &
    697                                 '(dimension "' // TRIM( dimension_name ) // &
    698                                 '", file "' // TRIM( file_name ) // '")!' )
    699                         EXIT
    700                      ENDIF
    701                   ENDDO
    702 
    703                   !-- Extend dimension list
    704                   IF ( return_value == 0 )  THEN
    705                      ALLOCATE( dimensions_tmp(ndims) )
    706                      dimensions_tmp = files(f)%dimensions
    707                      DEALLOCATE( files(f)%dimensions )
    708                      ndims = ndims + 1
    709                      ALLOCATE( files(f)%dimensions(ndims) )
    710                      files(f)%dimensions(:ndims-1) = dimensions_tmp
    711                      DEALLOCATE( dimensions_tmp )
    712                   ENDIF
    713                ENDIF
    714 
    715             ENDIF
    716 
    717             !-- Add new dimension to database
    718             IF ( return_value == 0 )  files(f)%dimensions(ndims) = dimension
    719 
    720             EXIT
    721 
    722          ENDIF
    723       ENDDO
    724 
    725       IF ( f > nfiles )  THEN
    726          return_value = 1
    727          CALL internal_message( 'error', routine_name //                                     &
    728                                 ': file not found (dimension "' // TRIM( dimension_name ) // &
    729                                 '", file "' // TRIM( file_name ) // '")!' )
    730       ENDIF
    731 
    732    ENDIF
    733 
    734 END FUNCTION dom_def_dim
     376 FUNCTION dom_def_dim( file_name, dimension_name, output_type, bounds,        &
     377                       values_int8, values_int16, values_int32, values_intwp, &
     378                       values_real32, values_real64, values_realwp,           &
     379                       mask ) RESULT( return_value )
     380
     381    CHARACTER(LEN=*), INTENT(IN) ::  file_name       !< name of file
     382    CHARACTER(LEN=*), INTENT(IN) ::  dimension_name  !< name of dimension
     383    CHARACTER(LEN=*), INTENT(IN) ::  output_type     !< data type of dimension variable in output file
     384
     385    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_dim'  !< name of this routine
     386
     387    INTEGER ::  d             !< loop index
     388    INTEGER ::  f             !< loop index
     389    INTEGER ::  i             !< loop index
     390    INTEGER ::  j             !< loop index
     391    INTEGER ::  ndims         !< number of dimensions in file
     392    INTEGER ::  return_value  !< return value
     393
     394    INTEGER,         DIMENSION(:), INTENT(IN)           ::  bounds         !< lower and upper bound of dimension variable
     395    INTEGER(KIND=1), DIMENSION(:), INTENT(IN), OPTIONAL ::  values_int8    !< values of dimension
     396    INTEGER(KIND=2), DIMENSION(:), INTENT(IN), OPTIONAL ::  values_int16   !< values of dimension
     397    INTEGER(KIND=4), DIMENSION(:), INTENT(IN), OPTIONAL ::  values_int32   !< values of dimension
     398    INTEGER(iwp),    DIMENSION(:), INTENT(IN), OPTIONAL ::  values_intwp   !< values of dimension
     399
     400    LOGICAL,         DIMENSION(:), INTENT(IN), OPTIONAL ::  mask           !< mask of dimesion
     401
     402    REAL(KIND=4),    DIMENSION(:), INTENT(IN), OPTIONAL ::  values_real32  !< values of dimension
     403    REAL(KIND=8),    DIMENSION(:), INTENT(IN), OPTIONAL ::  values_real64  !< values of dimension
     404    REAL(wp),        DIMENSION(:), INTENT(IN), OPTIONAL ::  values_realwp  !< values of dimension
     405
     406    TYPE(dimension_type)                            ::  dimension       !< new dimension
     407    TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  dimensions_tmp  !< temporary dimension list
     408
     409
     410    return_value = 0
     411
     412    CALL internal_message( 'debug', routine_name //                    &
     413                           ': define dimension ' //                    &
     414                           '(dimension "' // TRIM( dimension_name ) // &
     415                           '", file "' // TRIM( file_name ) // '")' )
     416
     417    dimension%name      = TRIM( dimension_name )
     418    dimension%data_type = TRIM( output_type )
     419!
     420!-- Check dimension bounds and allocate dimension according to bounds
     421    IF ( SIZE( bounds ) == 1 )  THEN
     422!
     423!--    Dimension has only lower bound, which means it changes its size
     424!--    during simulation.
     425!--    Set length to -1 as indicator.
     426       dimension%bounds(:) = bounds(1)
     427       dimension%length    = -1
     428
     429       IF ( PRESENT( mask ) )  THEN
     430          return_value = 1
     431          CALL internal_message( 'error', routine_name //                      &
     432                                 ': unlimited dimensions cannot be masked ' // &
     433                                 '(dimension "' // TRIM( dimension_name ) //   &
     434                                 '", file "' // TRIM( file_name ) // '")!' )
     435       ENDIF
     436
     437    ELSEIF ( SIZE( bounds ) == 2 )  THEN
     438
     439       dimension%bounds = bounds
     440       dimension%length = bounds(2) - bounds(1) + 1
     441!
     442!--    Save dimension values
     443       IF ( PRESENT( values_int8 ) )  THEN
     444          ALLOCATE( dimension%values_int8(dimension%bounds(1):dimension%bounds(2)) )
     445          IF ( SIZE( values_int8 ) == dimension%length )  THEN
     446             dimension%values_int8 = values_int8
     447          ELSEIF ( SIZE( values_int8 ) == 1 )  THEN
     448             dimension%values_int8(:) = values_int8(1)
     449          ELSE
     450             return_value = 2
     451          ENDIF
     452       ELSEIF( PRESENT( values_int16 ) )  THEN
     453          ALLOCATE( dimension%values_int16(dimension%bounds(1):dimension%bounds(2)) )
     454          IF ( SIZE( values_int16 ) == dimension%length )  THEN
     455             dimension%values_int16 = values_int16
     456          ELSEIF ( SIZE( values_int16 ) == 1 )  THEN
     457             dimension%values_int16(:) = values_int16(1)
     458          ELSE
     459             return_value = 2
     460          ENDIF
     461       ELSEIF( PRESENT( values_int32 ) )  THEN
     462          ALLOCATE( dimension%values_int32(dimension%bounds(1):dimension%bounds(2)) )
     463          IF ( SIZE( values_int32 ) == dimension%length )  THEN
     464             dimension%values_int32 = values_int32
     465          ELSEIF ( SIZE( values_int32 ) == 1 )  THEN
     466             dimension%values_int32(:) = values_int32(1)
     467          ELSE
     468             return_value = 2
     469          ENDIF
     470       ELSEIF( PRESENT( values_intwp ) )  THEN
     471          ALLOCATE( dimension%values_intwp(dimension%bounds(1):dimension%bounds(2)) )
     472          IF ( SIZE( values_intwp ) == dimension%length )  THEN
     473             dimension%values_intwp = values_intwp
     474          ELSEIF ( SIZE( values_intwp ) == 1 )  THEN
     475             dimension%values_intwp(:) = values_intwp(1)
     476          ELSE
     477             return_value = 2
     478          ENDIF
     479       ELSEIF( PRESENT( values_real32 ) )  THEN
     480          ALLOCATE( dimension%values_real32(dimension%bounds(1):dimension%bounds(2)) )
     481          IF ( SIZE( values_real32 ) == dimension%length )  THEN
     482             dimension%values_real32 = values_real32
     483          ELSEIF ( SIZE( values_real32 ) == 1 )  THEN
     484             dimension%values_real32(:) = values_real32(1)
     485          ELSE
     486             return_value = 2
     487          ENDIF
     488       ELSEIF( PRESENT( values_real64 ) )  THEN
     489          ALLOCATE( dimension%values_real64(dimension%bounds(1):dimension%bounds(2)) )
     490          IF ( SIZE( values_real64 ) == dimension%length )  THEN
     491             dimension%values_real64 = values_real64
     492          ELSEIF ( SIZE( values_real64 ) == 1 )  THEN
     493             dimension%values_real64(:) = values_real64(1)
     494          ELSE
     495             return_value = 2
     496          ENDIF
     497       ELSEIF( PRESENT( values_realwp ) )  THEN
     498          ALLOCATE( dimension%values_realwp(dimension%bounds(1):dimension%bounds(2)) )
     499          IF ( SIZE( values_realwp ) == dimension%length )  THEN
     500             dimension%values_realwp = values_realwp
     501          ELSEIF ( SIZE( values_realwp ) == 1 )  THEN
     502             dimension%values_realwp(:) = values_realwp(1)
     503          ELSE
     504             return_value = 2
     505          ENDIF
     506       ELSE
     507          return_value = 1
     508          CALL internal_message( 'error', routine_name //                    &
     509                                 ': no values given ' //                     &
     510                                 '(dimension "' // TRIM( dimension_name ) // &
     511                                 '", file "' // TRIM( file_name ) // '")!' )
     512       ENDIF
     513
     514       IF ( return_value == 2 )  THEN
     515          return_value = 1
     516          CALL internal_message( 'error', routine_name //                               &
     517                                 ': number of values and given bounds do not match ' // &
     518                                 '(dimension "' // TRIM( dimension_name ) //            &
     519                                 '", file "' // TRIM( file_name ) // '")!' )
     520       ENDIF
     521!
     522!--    Initialize mask
     523       IF ( PRESENT( mask )  .AND.  return_value == 0 )  THEN
     524
     525          IF ( dimension%length == SIZE( mask ) )  THEN
     526
     527             IF ( ALL( mask ) )  THEN
     528
     529                CALL internal_message( 'debug', routine_name //                              &
     530                                       ': mask contains only TRUE values. Ignoring mask ' // &
     531                                       '(dimension "' // TRIM( dimension_name ) //           &
     532                                       '", file "' // TRIM( file_name ) // '")!' )
     533
     534             ELSE
     535
     536                dimension%is_masked = .TRUE.
     537                dimension%length_mask = COUNT( mask )
     538
     539                ALLOCATE( dimension%mask(dimension%bounds(1):dimension%bounds(2)) )
     540                ALLOCATE( dimension%masked_indices(0:dimension%length_mask-1) )
     541
     542                dimension%mask = mask
     543!
     544!--             Save masked positions and masked values
     545                IF ( ALLOCATED( dimension%values_int8 ) )  THEN
     546
     547                   ALLOCATE( dimension%masked_values_int8(0:dimension%length_mask-1) )
     548                   j = 0
     549                   DO  i = dimension%bounds(1), dimension%bounds(2)
     550                      IF ( dimension%mask(i) )  THEN
     551                         dimension%masked_values_int8(j) = dimension%values_int8(i)
     552                         dimension%masked_indices(j) = i
     553                         j = j + 1
     554                      ENDIF
     555                   ENDDO
     556
     557                ELSEIF ( ALLOCATED( dimension%values_int16 ) )  THEN
     558
     559                   ALLOCATE( dimension%masked_values_int16(0:dimension%length_mask-1) )
     560                   j = 0
     561                   DO  i = dimension%bounds(1), dimension%bounds(2)
     562                      IF ( dimension%mask(i) )  THEN
     563                         dimension%masked_values_int16(j) = dimension%values_int16(i)
     564                         dimension%masked_indices(j) = i
     565                         j = j + 1
     566                      ENDIF
     567                   ENDDO
     568
     569                ELSEIF ( ALLOCATED( dimension%values_int32 ) )  THEN
     570
     571                   ALLOCATE( dimension%masked_values_int32(0:dimension%length_mask-1) )
     572                   j = 0
     573                   DO  i =dimension%bounds(1), dimension%bounds(2)
     574                      IF ( dimension%mask(i) )  THEN
     575                         dimension%masked_values_int32(j) = dimension%values_int32(i)
     576                         dimension%masked_indices(j) = i
     577                         j = j + 1
     578                      ENDIF
     579                   ENDDO
     580
     581                ELSEIF ( ALLOCATED( dimension%values_intwp ) )  THEN
     582
     583                   ALLOCATE( dimension%masked_values_intwp(0:dimension%length_mask-1) )
     584                   j = 0
     585                   DO  i = dimension%bounds(1), dimension%bounds(2)
     586                      IF ( dimension%mask(i) )  THEN
     587                         dimension%masked_values_intwp(j) = dimension%values_intwp(i)
     588                         dimension%masked_indices(j) = i
     589                         j = j + 1
     590                      ENDIF
     591                   ENDDO
     592
     593                ELSEIF ( ALLOCATED( dimension%values_real32 ) )  THEN
     594
     595                   ALLOCATE( dimension%masked_values_real32(0:dimension%length_mask-1) )
     596                   j = 0
     597                   DO  i = dimension%bounds(1), dimension%bounds(2)
     598                      IF ( dimension%mask(i) )  THEN
     599                         dimension%masked_values_real32(j) = dimension%values_real32(i)
     600                         dimension%masked_indices(j) = i
     601                         j = j + 1
     602                      ENDIF
     603                   ENDDO
     604
     605                ELSEIF ( ALLOCATED(dimension%values_real64) )  THEN
     606
     607                   ALLOCATE( dimension%masked_values_real64(0:dimension%length_mask-1) )
     608                   j = 0
     609                   DO  i = dimension%bounds(1), dimension%bounds(2)
     610                      IF ( dimension%mask(i) )  THEN
     611                         dimension%masked_values_real64(j) = dimension%values_real64(i)
     612                         dimension%masked_indices(j) = i
     613                         j = j + 1
     614                      ENDIF
     615                   ENDDO
     616
     617                ELSEIF ( ALLOCATED(dimension%values_realwp) )  THEN
     618
     619                   ALLOCATE( dimension%masked_values_realwp(0:dimension%length_mask-1) )
     620                   j = 0
     621                   DO  i = dimension%bounds(1), dimension%bounds(2)
     622                      IF ( dimension%mask(i) )  THEN
     623                         dimension%masked_values_realwp(j) = dimension%values_realwp(i)
     624                         dimension%masked_indices(j) = i
     625                         j = j + 1
     626                      ENDIF
     627                   ENDDO
     628
     629                ENDIF
     630
     631             ENDIF  ! if not all mask = true
     632
     633          ELSE
     634             return_value = 1
     635             CALL internal_message( 'error', routine_name //                           &
     636                                    ': size of mask and given bounds do not match ' // &
     637                                    '(dimension "' // TRIM( dimension_name ) //        &
     638                                    '", file "' // TRIM( file_name ) // '")!' )
     639          ENDIF
     640
     641       ENDIF
     642
     643    ELSE
     644
     645       return_value = 1
     646       CALL internal_message( 'error', routine_name //                                       &
     647                              ': at least one but no more than two bounds must be given ' // &
     648                              '(dimension "' // TRIM( dimension_name ) //                    &
     649                              '", file "' // TRIM( file_name ) // '")!' )
     650
     651    ENDIF
     652!
     653!-- Add dimension to database
     654    IF ( return_value == 0 )  THEN
     655
     656       DO  f = 1, nfiles
     657
     658          IF ( TRIM( file_name ) == files(f)%name )  THEN
     659
     660             IF ( files(f)%is_init )  THEN
     661
     662                return_value = 1
     663                CALL internal_message( 'error', routine_name //                      &
     664                                       ': file already initialized. ' //             &
     665                                       'No further dimension definition allowed ' // &
     666                                       '(dimension "' // TRIM( dimension_name ) //   &
     667                                       '", file "' // TRIM( file_name ) // '")!' )
     668                EXIT
     669
     670             ELSEIF ( .NOT. ALLOCATED( files(f)%dimensions ) )  THEN
     671
     672                ndims = 1
     673                ALLOCATE( files(f)%dimensions(ndims) )
     674
     675             ELSE
     676!
     677!--             Check if any variable of the same name as the new dimension is already defined
     678                IF ( ALLOCATED( files(f)%variables ) )  THEN
     679                   DO  i = 1, SIZE( files(f)%variables )
     680                      IF ( files(f)%variables(i)%name == dimension%name )  THEN
     681                         return_value = 1
     682                         CALL internal_message( 'error', routine_name //                    &
     683                                 ': file already has a variable of this name defined. ' //  &
     684                                 'Defining a dimension of the same name is not allowed ' // &
     685                                 '(dimension "' // TRIM( dimension_name ) //                &
     686                                 '", file "' // TRIM( file_name ) // '")!' )
     687                         EXIT
     688                      ENDIF
     689                   ENDDO
     690                ENDIF
     691
     692                IF ( return_value == 0 )  THEN
     693!
     694!--                Check if dimension already exists in file
     695                   ndims = SIZE( files(f)%dimensions )
     696
     697                   DO  d = 1, ndims
     698                      IF ( files(f)%dimensions(d)%name == dimension%name )  THEN
     699                         return_value = 1
     700                         CALL internal_message( 'error', routine_name //     &
     701                                 ': dimension already exists in file ' //    &
     702                                 '(dimension "' // TRIM( dimension_name ) // &
     703                                 '", file "' // TRIM( file_name ) // '")!' )
     704                         EXIT
     705                      ENDIF
     706                   ENDDO
     707!
     708!--                Extend dimension list
     709                   IF ( return_value == 0 )  THEN
     710                      ALLOCATE( dimensions_tmp(ndims) )
     711                      dimensions_tmp = files(f)%dimensions
     712                      DEALLOCATE( files(f)%dimensions )
     713                      ndims = ndims + 1
     714                      ALLOCATE( files(f)%dimensions(ndims) )
     715                      files(f)%dimensions(:ndims-1) = dimensions_tmp
     716                      DEALLOCATE( dimensions_tmp )
     717                   ENDIF
     718                ENDIF
     719
     720             ENDIF
     721!
     722!--          Add new dimension to database
     723             IF ( return_value == 0 )  files(f)%dimensions(ndims) = dimension
     724
     725             EXIT
     726
     727          ENDIF
     728       ENDDO
     729
     730       IF ( f > nfiles )  THEN
     731          return_value = 1
     732          CALL internal_message( 'error', routine_name //                                     &
     733                                 ': file not found (dimension "' // TRIM( dimension_name ) // &
     734                                 '", file "' // TRIM( file_name ) // '")!' )
     735       ENDIF
     736
     737    ENDIF
     738
     739 END FUNCTION dom_def_dim
    735740
    736741!--------------------------------------------------------------------------------------------------!
     
    759764!>          ALLOCATE( u(<z>,<y>,<x>) )
    760765!--------------------------------------------------------------------------------------------------!
    761 FUNCTION dom_def_var( file_name, variable_name, dimension_names, output_type, is_global ) &
    762             RESULT( return_value )
    763 
    764    CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< name of file
    765    CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
    766    CHARACTER(LEN=*), INTENT(IN) ::  output_type    !< data type of variable
    767 
    768    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_var'  !< name of this routine
    769 
    770    CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) ::  dimension_names  !< list of dimension names
    771 
    772    INTEGER ::  d             !< loop index
    773    INTEGER ::  f             !< loop index
    774    INTEGER ::  i             !< loop index
    775    INTEGER ::  nvars         !< number of variables in file
    776    INTEGER ::  return_value  !< return value
    777 
    778    LOGICAL                       ::  found      !< true if requested dimension is defined in file
    779    LOGICAL, INTENT(IN), OPTIONAL ::  is_global  !< true if variable is global (same on all PE)
    780 
    781    TYPE(variable_type)                            ::  variable       !< new variable
    782    TYPE(variable_type), DIMENSION(:), ALLOCATABLE ::  variables_tmp  !< temporary variable list
    783 
    784 
    785    return_value = 0
    786    found = .FALSE.
    787 
    788    CALL internal_message( 'debug', routine_name //                                     &
    789                           ': define variable (variable "' // TRIM( variable_name ) //  &
    790                           '", file "' // TRIM( file_name ) // '")' )
    791 
    792    variable%name = TRIM( variable_name )
    793 
    794    ALLOCATE( variable%dimension_names(SIZE( dimension_names )) )
    795    ALLOCATE( variable%dimension_ids(SIZE( dimension_names )) )
    796 
    797    variable%dimension_names = dimension_names
    798    variable%dimension_ids = -1
    799    variable%data_type = TRIM( output_type )
    800 
    801    IF ( PRESENT( is_global ) )  THEN
    802       variable%is_global = is_global
    803    ELSE
    804       variable%is_global = .FALSE.
    805    ENDIF
    806 
    807    !-- Add variable to database
    808    DO  f = 1, nfiles
    809 
    810       IF ( TRIM( file_name ) == files(f)%name )  THEN
    811 
    812          IF ( files(f)%is_init )  THEN
    813 
    814             return_value = 1
    815             CALL internal_message( 'error', routine_name //                                  &
    816                     ': file already initialized. No further variable definition allowed ' // &
    817                     '(variable "' // TRIM( variable_name ) //                                &
    818                     '", file "' // TRIM( file_name ) // '")!' )
    819             EXIT
    820 
    821          ELSEIF ( ALLOCATED( files(f)%dimensions ) )  THEN
    822 
    823             !-- Check if any dimension of the same name as the new variable is already defined
    824             DO  d = 1, SIZE( files(f)%dimensions )
    825                IF ( files(f)%dimensions(d)%name == variable%name )  THEN
    826                   return_value = 1
    827                   CALL internal_message( 'error', routine_name //                    &
    828                           ': file already has a dimension of this name defined. ' // &
    829                           'Defining a variable of the same name is not allowed ' //  &
    830                           '(variable "' // TRIM( variable_name ) //                  &
    831                           '", file "' // TRIM( file_name ) // '")!' )
    832                   EXIT
    833                ENDIF
    834             ENDDO
    835 
    836             !-- Check if dimensions assigned to variable are defined within file
    837             IF ( return_value == 0 )  THEN
    838                DO  i = 1, SIZE( variable%dimension_names )
    839                   found = .FALSE.
    840                   DO  d = 1, SIZE( files(f)%dimensions )
    841                      IF ( files(f)%dimensions(d)%name == variable%dimension_names(i) )  THEN
    842                         found = .TRUE.
    843                         EXIT
    844                      ENDIF
    845                   ENDDO
    846                   IF ( .NOT. found )  THEN
    847                      return_value = 1
    848                      CALL internal_message( 'error', routine_name //                            &
    849                              ': required dimension "'//  TRIM( variable%dimension_names(i) ) // &
    850                              '" for variable is not defined ' //                                &
    851                              '(variable "' // TRIM( variable_name ) //                          &
    852                              '", file "' // TRIM( file_name ) // '")!' )
    853                      EXIT
    854                   ENDIF
    855                ENDDO
    856             ENDIF
    857 
    858          ELSE
    859 
    860             return_value = 1
    861             CALL internal_message( 'error', routine_name //                      &
    862                     ': no dimensions defined in file. Cannot define variable '// &
    863                     '(variable "' // TRIM( variable_name ) //                    &
    864                     '", file "' // TRIM( file_name ) // '")!' )
    865 
    866          ENDIF
    867 
    868          IF ( return_value == 0 )  THEN
    869 
    870             !-- Check if variable already exists
    871             IF ( .NOT. ALLOCATED( files(f)%variables ) )  THEN
    872 
    873                nvars = 1
    874                ALLOCATE( files(f)%variables(nvars) )
    875 
    876             ELSE
    877 
    878                nvars = SIZE( files(f)%variables )
    879                DO  i = 1, nvars
    880                   IF ( files(f)%variables(i)%name == variable%name )  THEN
    881                      return_value = 1
    882                      CALL internal_message( 'error', routine_name //   &
    883                              ': variable already exists '//            &
    884                              '(variable "' // TRIM( variable_name ) // &
    885                              '", file "' // TRIM( file_name ) // '")!' )
    886                      EXIT
    887                   ENDIF
    888                ENDDO
    889 
    890                IF ( return_value == 0 )  THEN
    891                   !-- Extend variable list
    892                   ALLOCATE( variables_tmp(nvars) )
    893                   variables_tmp = files(f)%variables
    894                   DEALLOCATE( files(f)%variables )
    895                   nvars = nvars + 1
    896                   ALLOCATE( files(f)%variables(nvars) )
    897                   files(f)%variables(:nvars-1) = variables_tmp
    898                   DEALLOCATE( variables_tmp )
    899                ENDIF
    900 
    901             ENDIF
    902 
    903             !-- Add new variable to database
    904             IF ( return_value == 0 )  files(f)%variables(nvars) = variable
    905 
    906          ENDIF
    907 
    908          EXIT
    909 
    910       ENDIF
    911 
    912    ENDDO
    913 
    914    IF ( f > nfiles )  THEN
    915       return_value = 1
    916       CALL internal_message( 'error', routine_name //                                   &
    917                              ': file not found (variable "' // TRIM( variable_name ) // &
    918                              '", file "' // TRIM( file_name ) // '")!' )
    919    ENDIF
    920 
    921 END FUNCTION dom_def_var
     766 FUNCTION dom_def_var( file_name, variable_name, dimension_names, output_type, is_global ) &
     767             RESULT( return_value )
     768
     769    CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< name of file
     770    CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
     771    CHARACTER(LEN=*), INTENT(IN) ::  output_type    !< data type of variable
     772
     773    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_var'  !< name of this routine
     774
     775    CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) ::  dimension_names  !< list of dimension names
     776
     777    INTEGER ::  d             !< loop index
     778    INTEGER ::  f             !< loop index
     779    INTEGER ::  i             !< loop index
     780    INTEGER ::  nvars         !< number of variables in file
     781    INTEGER ::  return_value  !< return value
     782
     783    LOGICAL                       ::  found      !< true if requested dimension is defined in file
     784    LOGICAL, INTENT(IN), OPTIONAL ::  is_global  !< true if variable is global (same on all PE)
     785
     786    TYPE(variable_type)                            ::  variable       !< new variable
     787    TYPE(variable_type), DIMENSION(:), ALLOCATABLE ::  variables_tmp  !< temporary variable list
     788
     789
     790    return_value = 0
     791    found = .FALSE.
     792
     793    CALL internal_message( 'debug', routine_name //                                     &
     794                           ': define variable (variable "' // TRIM( variable_name ) //  &
     795                           '", file "' // TRIM( file_name ) // '")' )
     796
     797    variable%name = TRIM( variable_name )
     798
     799    ALLOCATE( variable%dimension_names(SIZE( dimension_names )) )
     800    ALLOCATE( variable%dimension_ids(SIZE( dimension_names )) )
     801
     802    variable%dimension_names = dimension_names
     803    variable%dimension_ids = -1
     804    variable%data_type = TRIM( output_type )
     805
     806    IF ( PRESENT( is_global ) )  THEN
     807       variable%is_global = is_global
     808    ELSE
     809       variable%is_global = .FALSE.
     810    ENDIF
     811!
     812!-- Add variable to database
     813    DO  f = 1, nfiles
     814
     815       IF ( TRIM( file_name ) == files(f)%name )  THEN
     816
     817          IF ( files(f)%is_init )  THEN
     818
     819             return_value = 1
     820             CALL internal_message( 'error', routine_name //                                  &
     821                     ': file already initialized. No further variable definition allowed ' // &
     822                     '(variable "' // TRIM( variable_name ) //                                &
     823                     '", file "' // TRIM( file_name ) // '")!' )
     824             EXIT
     825
     826          ELSEIF ( ALLOCATED( files(f)%dimensions ) )  THEN
     827!
     828!--          Check if any dimension of the same name as the new variable is already defined
     829             DO  d = 1, SIZE( files(f)%dimensions )
     830                IF ( files(f)%dimensions(d)%name == variable%name )  THEN
     831                   return_value = 1
     832                   CALL internal_message( 'error', routine_name //                    &
     833                           ': file already has a dimension of this name defined. ' // &
     834                           'Defining a variable of the same name is not allowed ' //  &
     835                           '(variable "' // TRIM( variable_name ) //                  &
     836                           '", file "' // TRIM( file_name ) // '")!' )
     837                   EXIT
     838                ENDIF
     839             ENDDO
     840!
     841!--          Check if dimensions assigned to variable are defined within file
     842             IF ( return_value == 0 )  THEN
     843                DO  i = 1, SIZE( variable%dimension_names )
     844                   found = .FALSE.
     845                   DO  d = 1, SIZE( files(f)%dimensions )
     846                      IF ( files(f)%dimensions(d)%name == variable%dimension_names(i) )  THEN
     847                         found = .TRUE.
     848                         EXIT
     849                      ENDIF
     850                   ENDDO
     851                   IF ( .NOT. found )  THEN
     852                      return_value = 1
     853                      CALL internal_message( 'error', routine_name //                            &
     854                              ': required dimension "'//  TRIM( variable%dimension_names(i) ) // &
     855                              '" for variable is not defined ' //                                &
     856                              '(variable "' // TRIM( variable_name ) //                          &
     857                              '", file "' // TRIM( file_name ) // '")!' )
     858                      EXIT
     859                   ENDIF
     860                ENDDO
     861             ENDIF
     862
     863          ELSE
     864
     865             return_value = 1
     866             CALL internal_message( 'error', routine_name //                      &
     867                     ': no dimensions defined in file. Cannot define variable '// &
     868                     '(variable "' // TRIM( variable_name ) //                    &
     869                     '", file "' // TRIM( file_name ) // '")!' )
     870
     871          ENDIF
     872
     873          IF ( return_value == 0 )  THEN
     874!
     875!--          Check if variable already exists
     876             IF ( .NOT. ALLOCATED( files(f)%variables ) )  THEN
     877
     878                nvars = 1
     879                ALLOCATE( files(f)%variables(nvars) )
     880
     881             ELSE
     882
     883                nvars = SIZE( files(f)%variables )
     884                DO  i = 1, nvars
     885                   IF ( files(f)%variables(i)%name == variable%name )  THEN
     886                      return_value = 1
     887                      CALL internal_message( 'error', routine_name //   &
     888                              ': variable already exists '//            &
     889                              '(variable "' // TRIM( variable_name ) // &
     890                              '", file "' // TRIM( file_name ) // '")!' )
     891                      EXIT
     892                   ENDIF
     893                ENDDO
     894
     895                IF ( return_value == 0 )  THEN
     896!
     897!--                Extend variable list
     898                   ALLOCATE( variables_tmp(nvars) )
     899                   variables_tmp = files(f)%variables
     900                   DEALLOCATE( files(f)%variables )
     901                   nvars = nvars + 1
     902                   ALLOCATE( files(f)%variables(nvars) )
     903                   files(f)%variables(:nvars-1) = variables_tmp
     904                   DEALLOCATE( variables_tmp )
     905                ENDIF
     906
     907             ENDIF
     908!
     909!--          Add new variable to database
     910             IF ( return_value == 0 )  files(f)%variables(nvars) = variable
     911
     912          ENDIF
     913
     914          EXIT
     915
     916       ENDIF
     917
     918    ENDDO
     919
     920    IF ( f > nfiles )  THEN
     921       return_value = 1
     922       CALL internal_message( 'error', routine_name //                                   &
     923                              ': file not found (variable "' // TRIM( variable_name ) // &
     924                              '", file "' // TRIM( file_name ) // '")!' )
     925    ENDIF
     926
     927 END FUNCTION dom_def_var
    922928
    923929!--------------------------------------------------------------------------------------------------!
     
    946952!>                   value=' and this part was appended', append=.TRUE. )
    947953!--------------------------------------------------------------------------------------------------!
    948 FUNCTION dom_def_att_char( file_name, variable_name, attribute_name, value, append ) &
    949             RESULT( return_value )
    950 
    951    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
    952    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
    953    CHARACTER(LEN=*),      INTENT(IN)           ::  value                   !< attribute value
    954    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
    955    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
    956 
    957    ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_char'  !< name of routine
    958 
    959    INTEGER ::  return_value  !< return value
    960 
    961    LOGICAL                       ::  append_internal  !< same as 'append'
    962    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
    963 
    964    TYPE(attribute_type) ::  attribute  !< new attribute
    965 
    966 
    967    return_value = 0
    968 
    969    IF ( PRESENT( append ) )  THEN
    970       append_internal = append
    971    ELSE
    972       append_internal = .FALSE.
    973    ENDIF
    974 
    975    attribute%name       = TRIM( attribute_name )
    976    attribute%data_type  = 'char'
    977    attribute%value_char = TRIM( value )
    978 
    979    IF ( PRESENT( variable_name ) )  THEN
    980       variable_name_internal = TRIM( variable_name )
    981    ELSE
    982       variable_name_internal = ''
    983    ENDIF
    984 
    985    return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
    986                      variable_name=TRIM( variable_name_internal ),         &
    987                      attribute=attribute, append=append_internal )
    988 
    989 END FUNCTION dom_def_att_char
     954 FUNCTION dom_def_att_char( file_name, variable_name, attribute_name, value, append ) &
     955             RESULT( return_value )
     956
     957    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
     958    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
     959    CHARACTER(LEN=*),      INTENT(IN)           ::  value                   !< attribute value
     960    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
     961    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
     962
     963    ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_char'  !< name of routine
     964
     965    INTEGER ::  return_value  !< return value
     966
     967    LOGICAL                       ::  append_internal  !< same as 'append'
     968    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
     969
     970    TYPE(attribute_type) ::  attribute  !< new attribute
     971
     972
     973    return_value = 0
     974
     975    IF ( PRESENT( append ) )  THEN
     976       append_internal = append
     977    ELSE
     978       append_internal = .FALSE.
     979    ENDIF
     980
     981    attribute%name       = TRIM( attribute_name )
     982    attribute%data_type  = 'char'
     983    attribute%value_char = TRIM( value )
     984
     985    IF ( PRESENT( variable_name ) )  THEN
     986       variable_name_internal = TRIM( variable_name )
     987    ELSE
     988       variable_name_internal = ''
     989    ENDIF
     990
     991    return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
     992                      variable_name=TRIM( variable_name_internal ),         &
     993                      attribute=attribute, append=append_internal )
     994
     995 END FUNCTION dom_def_att_char
    990996
    991997!--------------------------------------------------------------------------------------------------!
     
    10081014!>                   value=1_1 )
    10091015!--------------------------------------------------------------------------------------------------!
    1010 FUNCTION dom_def_att_int8( file_name, variable_name, attribute_name, value, append ) &
    1011             RESULT( return_value )
    1012 
    1013    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
    1014    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
    1015    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
    1016    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
    1017 
    1018    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int8'  !< name of routine
    1019 
    1020    INTEGER(KIND=1), INTENT(IN) ::  value  !< attribute value
    1021 
    1022    INTEGER ::  return_value  !< return value
    1023 
    1024    LOGICAL                       ::  append_internal  !< same as 'append'
    1025    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
    1026 
    1027    TYPE(attribute_type) ::  attribute  !< new attribute
    1028 
    1029 
    1030    return_value = 0
    1031 
    1032    IF ( PRESENT( variable_name ) )  THEN
    1033       variable_name_internal = TRIM( variable_name )
    1034    ELSE
    1035       variable_name_internal = ''
    1036    ENDIF
    1037 
    1038    IF ( PRESENT( append ) )  THEN
    1039       IF ( append )  THEN
    1040          return_value = 1
    1041          CALL internal_message( 'error', routine_name //                             &
    1042                                 ': numeric attribute cannot be appended ' //         &
    1043                                 '(attribute "' // TRIM( attribute_name ) //          &
    1044                                 '", variable "' // TRIM( variable_name_internal ) // &
    1045                                 '", file "' // TRIM( file_name ) // '")!' )
    1046       ENDIF
    1047    ENDIF
    1048 
    1049    IF ( return_value == 0 )  THEN
    1050       append_internal = .FALSE.
    1051 
    1052       attribute%name       = TRIM( attribute_name )
    1053       attribute%data_type  = 'int8'
    1054       attribute%value_int8 = value
    1055 
    1056       return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
    1057                         variable_name=TRIM( variable_name_internal ),         &
    1058                         attribute=attribute, append=append_internal )
    1059    ENDIF
    1060 
    1061 END FUNCTION dom_def_att_int8
     1016 FUNCTION dom_def_att_int8( file_name, variable_name, attribute_name, value, append ) &
     1017             RESULT( return_value )
     1018
     1019    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
     1020    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
     1021    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
     1022    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
     1023
     1024    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int8'  !< name of routine
     1025
     1026    INTEGER(KIND=1), INTENT(IN) ::  value  !< attribute value
     1027
     1028    INTEGER ::  return_value  !< return value
     1029
     1030    LOGICAL                       ::  append_internal  !< same as 'append'
     1031    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
     1032
     1033    TYPE(attribute_type) ::  attribute  !< new attribute
     1034
     1035
     1036    return_value = 0
     1037
     1038    IF ( PRESENT( variable_name ) )  THEN
     1039       variable_name_internal = TRIM( variable_name )
     1040    ELSE
     1041       variable_name_internal = ''
     1042    ENDIF
     1043
     1044    IF ( PRESENT( append ) )  THEN
     1045       IF ( append )  THEN
     1046          return_value = 1
     1047          CALL internal_message( 'error', routine_name //                             &
     1048                                 ': numeric attribute cannot be appended ' //         &
     1049                                 '(attribute "' // TRIM( attribute_name ) //          &
     1050                                 '", variable "' // TRIM( variable_name_internal ) // &
     1051                                 '", file "' // TRIM( file_name ) // '")!' )
     1052       ENDIF
     1053    ENDIF
     1054
     1055    IF ( return_value == 0 )  THEN
     1056       append_internal = .FALSE.
     1057
     1058       attribute%name       = TRIM( attribute_name )
     1059       attribute%data_type  = 'int8'
     1060       attribute%value_int8 = value
     1061
     1062       return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
     1063                         variable_name=TRIM( variable_name_internal ),         &
     1064                         attribute=attribute, append=append_internal )
     1065    ENDIF
     1066
     1067 END FUNCTION dom_def_att_int8
    10621068
    10631069!--------------------------------------------------------------------------------------------------!
     
    10801086!>                   value=1_2 )
    10811087!--------------------------------------------------------------------------------------------------!
    1082 FUNCTION dom_def_att_int16( file_name, variable_name, attribute_name, value, append ) &
    1083             RESULT( return_value )
    1084 
    1085    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
    1086    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
    1087    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
    1088    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
    1089 
    1090    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int16'  !< name of routine
    1091 
    1092    INTEGER(KIND=2), INTENT(IN) ::  value  !< attribute value
    1093 
    1094    INTEGER ::  return_value  !< return value
    1095 
    1096    LOGICAL                       ::  append_internal  !< same as 'append'
    1097    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
    1098 
    1099    TYPE(attribute_type) ::  attribute  !< new attribute
    1100 
    1101 
    1102    return_value = 0
    1103 
    1104    IF ( PRESENT( variable_name ) )  THEN
    1105       variable_name_internal = TRIM( variable_name )
    1106    ELSE
    1107       variable_name_internal = ''
    1108    ENDIF
    1109 
    1110    IF ( PRESENT( append ) )  THEN
    1111       IF ( append )  THEN
    1112          return_value = 1
    1113          CALL internal_message( 'error', routine_name //                             &
    1114                                 ': numeric attribute cannot be appended ' //         &
    1115                                 '(attribute "' // TRIM( attribute_name ) //          &
    1116                                 '", variable "' // TRIM( variable_name_internal ) // &
    1117                                 '", file "' // TRIM( file_name ) // '")!' )
    1118       ENDIF
    1119    ENDIF
    1120 
    1121    IF ( return_value == 0 )  THEN
    1122       append_internal = .FALSE.
    1123 
    1124       attribute%name        = TRIM( attribute_name )
    1125       attribute%data_type   = 'int16'
    1126       attribute%value_int16 = value
    1127 
    1128       return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
    1129                         variable_name=TRIM( variable_name_internal ),         &
    1130                         attribute=attribute, append=append_internal )
    1131    ENDIF
    1132 
    1133 END FUNCTION dom_def_att_int16
     1088 FUNCTION dom_def_att_int16( file_name, variable_name, attribute_name, value, append ) &
     1089             RESULT( return_value )
     1090
     1091    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
     1092    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
     1093    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
     1094    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
     1095
     1096    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int16'  !< name of routine
     1097
     1098    INTEGER(KIND=2), INTENT(IN) ::  value  !< attribute value
     1099
     1100    INTEGER ::  return_value  !< return value
     1101
     1102    LOGICAL                       ::  append_internal  !< same as 'append'
     1103    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
     1104
     1105    TYPE(attribute_type) ::  attribute  !< new attribute
     1106
     1107
     1108    return_value = 0
     1109
     1110    IF ( PRESENT( variable_name ) )  THEN
     1111       variable_name_internal = TRIM( variable_name )
     1112    ELSE
     1113       variable_name_internal = ''
     1114    ENDIF
     1115
     1116    IF ( PRESENT( append ) )  THEN
     1117       IF ( append )  THEN
     1118          return_value = 1
     1119          CALL internal_message( 'error', routine_name //                             &
     1120                                 ': numeric attribute cannot be appended ' //         &
     1121                                 '(attribute "' // TRIM( attribute_name ) //          &
     1122                                 '", variable "' // TRIM( variable_name_internal ) // &
     1123                                 '", file "' // TRIM( file_name ) // '")!' )
     1124       ENDIF
     1125    ENDIF
     1126
     1127    IF ( return_value == 0 )  THEN
     1128       append_internal = .FALSE.
     1129
     1130       attribute%name        = TRIM( attribute_name )
     1131       attribute%data_type   = 'int16'
     1132       attribute%value_int16 = value
     1133
     1134       return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
     1135                         variable_name=TRIM( variable_name_internal ),         &
     1136                         attribute=attribute, append=append_internal )
     1137    ENDIF
     1138
     1139 END FUNCTION dom_def_att_int16
    11341140
    11351141!--------------------------------------------------------------------------------------------------!
     
    11521158!>                   value=1_4 )
    11531159!--------------------------------------------------------------------------------------------------!
    1154 FUNCTION dom_def_att_int32( file_name, variable_name, attribute_name, value, append ) &
    1155             RESULT( return_value )
    1156 
    1157    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
    1158    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
    1159    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
    1160    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
    1161 
    1162    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int32'  !< name of routine
    1163 
    1164    INTEGER(KIND=4), INTENT(IN) ::  value  !< attribute value
    1165 
    1166    INTEGER ::  return_value  !< return value
    1167 
    1168    LOGICAL                       ::  append_internal  !< same as 'append'
    1169    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
    1170 
    1171    TYPE(attribute_type) ::  attribute  !< new attribute
    1172 
    1173 
    1174    return_value = 0
    1175 
    1176    IF ( PRESENT( variable_name ) )  THEN
    1177       variable_name_internal = TRIM( variable_name )
    1178    ELSE
    1179       variable_name_internal = ''
    1180    ENDIF
    1181 
    1182    IF ( PRESENT( append ) )  THEN
    1183       IF ( append )  THEN
    1184          return_value = 1
    1185          CALL internal_message( 'error', routine_name //                             &
    1186                                 ': numeric attribute cannot be appended ' //         &
    1187                                 '(attribute "' // TRIM( attribute_name ) //          &
    1188                                 '", variable "' // TRIM( variable_name_internal ) // &
    1189                                 '", file "' // TRIM( file_name ) // '")!' )
    1190       ENDIF
    1191    ENDIF
    1192 
    1193    IF ( return_value == 0 )  THEN
    1194       append_internal = .FALSE.
    1195 
    1196       attribute%name        = TRIM( attribute_name )
    1197       attribute%data_type   = 'int32'
    1198       attribute%value_int32 = value
    1199 
    1200       return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
    1201                         variable_name=TRIM( variable_name_internal ),         &
    1202                         attribute=attribute, append=append_internal )
    1203    ENDIF
    1204 
    1205 END FUNCTION dom_def_att_int32
     1160 FUNCTION dom_def_att_int32( file_name, variable_name, attribute_name, value, append ) &
     1161             RESULT( return_value )
     1162
     1163    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
     1164    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
     1165    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
     1166    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
     1167
     1168    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_int32'  !< name of routine
     1169
     1170    INTEGER(KIND=4), INTENT(IN) ::  value  !< attribute value
     1171
     1172    INTEGER ::  return_value  !< return value
     1173
     1174    LOGICAL                       ::  append_internal  !< same as 'append'
     1175    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
     1176
     1177    TYPE(attribute_type) ::  attribute  !< new attribute
     1178
     1179
     1180    return_value = 0
     1181
     1182    IF ( PRESENT( variable_name ) )  THEN
     1183       variable_name_internal = TRIM( variable_name )
     1184    ELSE
     1185       variable_name_internal = ''
     1186    ENDIF
     1187
     1188    IF ( PRESENT( append ) )  THEN
     1189       IF ( append )  THEN
     1190          return_value = 1
     1191          CALL internal_message( 'error', routine_name //                             &
     1192                                 ': numeric attribute cannot be appended ' //         &
     1193                                 '(attribute "' // TRIM( attribute_name ) //          &
     1194                                 '", variable "' // TRIM( variable_name_internal ) // &
     1195                                 '", file "' // TRIM( file_name ) // '")!' )
     1196       ENDIF
     1197    ENDIF
     1198
     1199    IF ( return_value == 0 )  THEN
     1200       append_internal = .FALSE.
     1201
     1202       attribute%name        = TRIM( attribute_name )
     1203       attribute%data_type   = 'int32'
     1204       attribute%value_int32 = value
     1205
     1206       return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
     1207                         variable_name=TRIM( variable_name_internal ),         &
     1208                         attribute=attribute, append=append_internal )
     1209    ENDIF
     1210
     1211 END FUNCTION dom_def_att_int32
    12061212
    12071213!--------------------------------------------------------------------------------------------------!
     
    12241230!>                   value=1.0_4 )
    12251231!--------------------------------------------------------------------------------------------------!
    1226 FUNCTION dom_def_att_real32( file_name, variable_name, attribute_name, value, append ) &
    1227             RESULT( return_value )
    1228 
    1229    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
    1230    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
    1231    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
    1232    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
    1233 
    1234    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_real32'  !< name of routine
    1235 
    1236    INTEGER ::  return_value  !< return value
    1237 
    1238    LOGICAL                       ::  append_internal  !< same as 'append'
    1239    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
    1240 
    1241    REAL(KIND=4), INTENT(IN) ::  value  !< attribute value
    1242 
    1243    TYPE(attribute_type) ::  attribute  !< new attribute
    1244 
    1245 
    1246    return_value = 0
    1247 
    1248    IF ( PRESENT( variable_name ) )  THEN
    1249       variable_name_internal = TRIM( variable_name )
    1250    ELSE
    1251       variable_name_internal = ''
    1252    ENDIF
    1253 
    1254    IF ( PRESENT( append ) )  THEN
    1255       IF ( append )  THEN
    1256          return_value = 1
    1257          CALL internal_message( 'error', routine_name //                             &
    1258                                 ': numeric attribute cannot be appended ' //         &
    1259                                 '(attribute "' // TRIM( attribute_name ) //          &
    1260                                 '", variable "' // TRIM( variable_name_internal ) // &
    1261                                 '", file "' // TRIM( file_name ) // '")!' )
    1262       ENDIF
    1263    ENDIF
    1264 
    1265    IF ( return_value == 0 )  THEN
    1266       append_internal = .FALSE.
    1267 
    1268       attribute%name         = TRIM( attribute_name )
    1269       attribute%data_type    = 'real32'
    1270       attribute%value_real32 = value
    1271 
    1272       return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
    1273                         variable_name=TRIM( variable_name_internal ),         &
    1274                         attribute=attribute, append=append_internal )
    1275    ENDIF
    1276 
    1277 END FUNCTION dom_def_att_real32
     1232 FUNCTION dom_def_att_real32( file_name, variable_name, attribute_name, value, append ) &
     1233             RESULT( return_value )
     1234
     1235    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
     1236    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
     1237    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
     1238    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
     1239
     1240    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_real32'  !< name of routine
     1241
     1242    INTEGER ::  return_value  !< return value
     1243
     1244    LOGICAL                       ::  append_internal  !< same as 'append'
     1245    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
     1246
     1247    REAL(KIND=4), INTENT(IN) ::  value  !< attribute value
     1248
     1249    TYPE(attribute_type) ::  attribute  !< new attribute
     1250
     1251
     1252    return_value = 0
     1253
     1254    IF ( PRESENT( variable_name ) )  THEN
     1255       variable_name_internal = TRIM( variable_name )
     1256    ELSE
     1257       variable_name_internal = ''
     1258    ENDIF
     1259
     1260    IF ( PRESENT( append ) )  THEN
     1261       IF ( append )  THEN
     1262          return_value = 1
     1263          CALL internal_message( 'error', routine_name //                             &
     1264                                 ': numeric attribute cannot be appended ' //         &
     1265                                 '(attribute "' // TRIM( attribute_name ) //          &
     1266                                 '", variable "' // TRIM( variable_name_internal ) // &
     1267                                 '", file "' // TRIM( file_name ) // '")!' )
     1268       ENDIF
     1269    ENDIF
     1270
     1271    IF ( return_value == 0 )  THEN
     1272       append_internal = .FALSE.
     1273
     1274       attribute%name         = TRIM( attribute_name )
     1275       attribute%data_type    = 'real32'
     1276       attribute%value_real32 = value
     1277
     1278       return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
     1279                         variable_name=TRIM( variable_name_internal ),         &
     1280                         attribute=attribute, append=append_internal )
     1281    ENDIF
     1282
     1283 END FUNCTION dom_def_att_real32
    12781284
    12791285!--------------------------------------------------------------------------------------------------!
     
    12961302!>                   value=1.0_8 )
    12971303!--------------------------------------------------------------------------------------------------!
    1298 FUNCTION dom_def_att_real64( file_name, variable_name, attribute_name, value, append ) &
    1299             RESULT( return_value )
    1300 
    1301    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
    1302    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
    1303    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
    1304    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
    1305 
    1306    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_real64'  !< name of routine
    1307 
    1308    INTEGER ::  return_value  !< return value
    1309 
    1310    LOGICAL                       ::  append_internal  !< same as 'append'
    1311    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
    1312 
    1313    REAL(KIND=8), INTENT(IN) ::  value  !< attribute value
    1314 
    1315    TYPE(attribute_type) ::  attribute  !< new attribute
    1316 
    1317 
    1318    return_value = 0
    1319 
    1320    IF ( PRESENT( variable_name ) )  THEN
    1321       variable_name_internal = TRIM( variable_name )
    1322    ELSE
    1323       variable_name_internal = ''
    1324    ENDIF
    1325 
    1326    IF ( PRESENT( append ) )  THEN
    1327       IF ( append )  THEN
    1328          return_value = 1
    1329          CALL internal_message( 'error', routine_name //                             &
    1330                                 ': numeric attribute cannot be appended ' //         &
    1331                                 '(attribute "' // TRIM( attribute_name ) //          &
    1332                                 '", variable "' // TRIM( variable_name_internal ) // &
    1333                                 '", file "' // TRIM( file_name ) // '")!' )
    1334       ENDIF
    1335    ENDIF
    1336 
    1337    IF ( return_value == 0 )  THEN
    1338       append_internal = .FALSE.
    1339 
    1340       attribute%name         = TRIM( attribute_name )
    1341       attribute%data_type    = 'real64'
    1342       attribute%value_real64 = value
    1343 
    1344       return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
    1345                         variable_name=TRIM( variable_name_internal ),         &
    1346                         attribute=attribute, append=append_internal )
    1347    ENDIF
    1348 
    1349 END FUNCTION dom_def_att_real64
     1304 FUNCTION dom_def_att_real64( file_name, variable_name, attribute_name, value, append ) &
     1305             RESULT( return_value )
     1306
     1307    CHARACTER(LEN=*),      INTENT(IN)           ::  file_name               !< name of file
     1308    CHARACTER(LEN=*),      INTENT(IN)           ::  attribute_name          !< name of attribute
     1309    CHARACTER(LEN=*),      INTENT(IN), OPTIONAL ::  variable_name           !< name of variable
     1310    CHARACTER(LEN=charlen)                      ::  variable_name_internal  !< internal copy of variable_name
     1311
     1312    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_att_real64'  !< name of routine
     1313
     1314    INTEGER ::  return_value  !< return value
     1315
     1316    LOGICAL                       ::  append_internal  !< same as 'append'
     1317    LOGICAL, INTENT(IN), OPTIONAL ::  append           !< if true, append value to existing value
     1318
     1319    REAL(KIND=8), INTENT(IN) ::  value  !< attribute value
     1320
     1321    TYPE(attribute_type) ::  attribute  !< new attribute
     1322
     1323
     1324    return_value = 0
     1325
     1326    IF ( PRESENT( variable_name ) )  THEN
     1327       variable_name_internal = TRIM( variable_name )
     1328    ELSE
     1329       variable_name_internal = ''
     1330    ENDIF
     1331
     1332    IF ( PRESENT( append ) )  THEN
     1333       IF ( append )  THEN
     1334          return_value = 1
     1335          CALL internal_message( 'error', routine_name //                             &
     1336                                 ': numeric attribute cannot be appended ' //         &
     1337                                 '(attribute "' // TRIM( attribute_name ) //          &
     1338                                 '", variable "' // TRIM( variable_name_internal ) // &
     1339                                 '", file "' // TRIM( file_name ) // '")!' )
     1340       ENDIF
     1341    ENDIF
     1342
     1343    IF ( return_value == 0 )  THEN
     1344       append_internal = .FALSE.
     1345
     1346       attribute%name         = TRIM( attribute_name )
     1347       attribute%data_type    = 'real64'
     1348       attribute%value_real64 = value
     1349
     1350       return_value = save_attribute_in_database( file_name=TRIM( file_name ), &
     1351                         variable_name=TRIM( variable_name_internal ),         &
     1352                         attribute=attribute, append=append_internal )
     1353    ENDIF
     1354
     1355 END FUNCTION dom_def_att_real64
    13501356
    13511357!--------------------------------------------------------------------------------------------------!
     
    13571363!> to the files.
    13581364!--------------------------------------------------------------------------------------------------!
    1359 FUNCTION dom_def_end() RESULT( return_value )
    1360 
    1361    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_end'  !< name of routine
    1362 
    1363    INTEGER ::  d             !< loop index
    1364    INTEGER ::  f             !< loop index
    1365    INTEGER ::  return_value  !< return value
    1366 
    1367    INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE, TARGET ::  values_int8           !< target array for dimension values
    1368    INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE, TARGET ::  values_int16          !< target array for dimension values
    1369    INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET ::  values_int32          !< target array for dimension values
    1370    INTEGER(iwp),    DIMENSION(:), ALLOCATABLE, TARGET ::  values_intwp          !< target array for dimension values
    1371    
    1372    INTEGER(KIND=1), DIMENSION(:), POINTER, CONTIGUOUS ::  values_int8_pointer   !< pointer to target array
    1373    INTEGER(KIND=2), DIMENSION(:), POINTER, CONTIGUOUS ::  values_int16_pointer  !< pointer to target array
    1374    INTEGER(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS ::  values_int32_pointer  !< pointer to target array
    1375    INTEGER(iwp),    DIMENSION(:), POINTER, CONTIGUOUS ::  values_intwp_pointer  !< pointer to target array
    1376 
    1377    REAL(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET ::  values_real32            !< target array for dimension values
    1378    REAL(KIND=8), DIMENSION(:), ALLOCATABLE, TARGET ::  values_real64            !< target array for dimension values
    1379    REAL(wp),     DIMENSION(:), ALLOCATABLE, TARGET ::  values_realwp            !< target array for dimension values
    1380 
    1381    REAL(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS ::  values_real32_pointer    !< pointer to target array
    1382    REAL(KIND=8), DIMENSION(:), POINTER, CONTIGUOUS ::  values_real64_pointer    !< pointer to target array
    1383    REAL(wp),     DIMENSION(:), POINTER, CONTIGUOUS ::  values_realwp_pointer    !< pointer to target array
    1384 
    1385 
    1386    return_value = 0
    1387    CALL internal_message( 'debug', routine_name // ': start' )
    1388 
    1389    !-- Clear database from empty files and unused dimensions
    1390    IF ( nfiles > 0 )  return_value = cleanup_database()
    1391 
    1392    IF ( return_value == 0 )  THEN
    1393       DO  f = 1, nfiles
    1394 
    1395          !-- Skip initialization if file is already initialized
    1396          IF ( files(f)%is_init )  CYCLE
    1397 
    1398          CALL internal_message( 'debug', routine_name // ': initialize file "' // &
    1399                                 TRIM( files(f)%name ) // '"' )
    1400 
    1401          !-- Open file
    1402          CALL open_output_file( files(f)%format, files(f)%name, files(f)%id, &
    1403                                 return_value=return_value )
    1404 
    1405          !-- Initialize file header:
    1406          !-- define dimensions and variables and write attributes
    1407          IF ( return_value == 0 )  &
    1408             CALL init_file_header( files(f), return_value=return_value )
    1409 
    1410          !-- End file definition
    1411          IF ( return_value == 0 )  &
    1412             CALL stop_file_header_definition( files(f)%format, files(f)%id, &
    1413                                               files(f)%name, return_value )
    1414 
    1415          IF ( return_value == 0 )  THEN
    1416 
    1417             !-- Flag file as initialized
    1418             files(f)%is_init = .TRUE.
    1419 
    1420             !-- Write dimension values into file
    1421             DO  d = 1, SIZE( files(f)%dimensions )
    1422                IF ( ALLOCATED( files(f)%dimensions(d)%values_int8 ) )  THEN
    1423                   ALLOCATE( values_int8(files(f)%dimensions(d)%bounds(1): &
    1424                                         files(f)%dimensions(d)%bounds(2)) )
    1425                   values_int8 = files(f)%dimensions(d)%values_int8
    1426                   values_int8_pointer => values_int8
    1427                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
    1428                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
    1429                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
    1430                                     values_int8_1d=values_int8_pointer )
    1431                   DEALLOCATE( values_int8 )
    1432                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int16 ) )  THEN
    1433                   ALLOCATE( values_int16(files(f)%dimensions(d)%bounds(1): &
     1365 FUNCTION dom_def_end() RESULT( return_value )
     1366
     1367    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_def_end'  !< name of routine
     1368
     1369    INTEGER ::  d             !< loop index
     1370    INTEGER ::  f             !< loop index
     1371    INTEGER ::  return_value  !< return value
     1372
     1373    INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE, TARGET ::  values_int8           !< target array for dimension values
     1374    INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE, TARGET ::  values_int16          !< target array for dimension values
     1375    INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET ::  values_int32          !< target array for dimension values
     1376    INTEGER(iwp),    DIMENSION(:), ALLOCATABLE, TARGET ::  values_intwp          !< target array for dimension values
     1377
     1378    INTEGER(KIND=1), DIMENSION(:), POINTER, CONTIGUOUS ::  values_int8_pointer   !< pointer to target array
     1379    INTEGER(KIND=2), DIMENSION(:), POINTER, CONTIGUOUS ::  values_int16_pointer  !< pointer to target array
     1380    INTEGER(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS ::  values_int32_pointer  !< pointer to target array
     1381    INTEGER(iwp),    DIMENSION(:), POINTER, CONTIGUOUS ::  values_intwp_pointer  !< pointer to target array
     1382
     1383    REAL(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET ::  values_real32            !< target array for dimension values
     1384    REAL(KIND=8), DIMENSION(:), ALLOCATABLE, TARGET ::  values_real64            !< target array for dimension values
     1385    REAL(wp),     DIMENSION(:), ALLOCATABLE, TARGET ::  values_realwp            !< target array for dimension values
     1386
     1387    REAL(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS ::  values_real32_pointer    !< pointer to target array
     1388    REAL(KIND=8), DIMENSION(:), POINTER, CONTIGUOUS ::  values_real64_pointer    !< pointer to target array
     1389    REAL(wp),     DIMENSION(:), POINTER, CONTIGUOUS ::  values_realwp_pointer    !< pointer to target array
     1390
     1391
     1392    return_value = 0
     1393    CALL internal_message( 'debug', routine_name // ': start' )
     1394!
     1395!-- Clear database from empty files and unused dimensions
     1396    IF ( nfiles > 0 )  return_value = cleanup_database()
     1397
     1398    IF ( return_value == 0 )  THEN
     1399       DO  f = 1, nfiles
     1400!
     1401!--       Skip initialization if file is already initialized
     1402          IF ( files(f)%is_init )  CYCLE
     1403
     1404          CALL internal_message( 'debug', routine_name // ': initialize file "' // &
     1405                                 TRIM( files(f)%name ) // '"' )
     1406!
     1407!--       Open file
     1408          CALL open_output_file( files(f)%format, files(f)%name, files(f)%id, &
     1409                                 return_value=return_value )
     1410!
     1411!--       Initialize file header:
     1412!--       define dimensions and variables and write attributes
     1413          IF ( return_value == 0 )  &
     1414             CALL init_file_header( files(f), return_value=return_value )
     1415!
     1416!--       End file definition
     1417          IF ( return_value == 0 )  &
     1418             CALL stop_file_header_definition( files(f)%format, files(f)%id, &
     1419                                               files(f)%name, return_value )
     1420
     1421          IF ( return_value == 0 )  THEN
     1422!
     1423!--          Flag file as initialized
     1424             files(f)%is_init = .TRUE.
     1425!
     1426!--          Write dimension values into file
     1427             DO  d = 1, SIZE( files(f)%dimensions )
     1428                IF ( ALLOCATED( files(f)%dimensions(d)%values_int8 ) )  THEN
     1429                   ALLOCATE( values_int8(files(f)%dimensions(d)%bounds(1): &
    14341430                                         files(f)%dimensions(d)%bounds(2)) )
    1435                   values_int16 = files(f)%dimensions(d)%values_int16
    1436                   values_int16_pointer => values_int16
    1437                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
    1438                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
    1439                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
    1440                                     values_int16_1d=values_int16_pointer )
    1441                   DEALLOCATE( values_int16 )
    1442                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int32 ) )  THEN
    1443                   ALLOCATE( values_int32(files(f)%dimensions(d)%bounds(1): &
    1444                                          files(f)%dimensions(d)%bounds(2)) )
    1445                   values_int32 = files(f)%dimensions(d)%values_int32
    1446                   values_int32_pointer => values_int32
    1447                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
    1448                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
    1449                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
    1450                                     values_int32_1d=values_int32_pointer )
    1451                   DEALLOCATE( values_int32 )
    1452                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_intwp ) )  THEN
    1453                   ALLOCATE( values_intwp(files(f)%dimensions(d)%bounds(1): &
    1454                                          files(f)%dimensions(d)%bounds(2)) )
    1455                   values_intwp = files(f)%dimensions(d)%values_intwp
    1456                   values_intwp_pointer => values_intwp
    1457                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
    1458                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
    1459                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
    1460                                     values_intwp_1d=values_intwp_pointer )
    1461                   DEALLOCATE( values_intwp )
    1462                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real32 ) )  THEN
    1463                   ALLOCATE( values_real32(files(f)%dimensions(d)%bounds(1): &
     1431                   values_int8 = files(f)%dimensions(d)%values_int8
     1432                   values_int8_pointer => values_int8
     1433                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
     1434                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
     1435                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
     1436                                     values_int8_1d=values_int8_pointer )
     1437                   DEALLOCATE( values_int8 )
     1438                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int16 ) )  THEN
     1439                   ALLOCATE( values_int16(files(f)%dimensions(d)%bounds(1): &
    14641440                                          files(f)%dimensions(d)%bounds(2)) )
    1465                   values_real32 = files(f)%dimensions(d)%values_real32
    1466                   values_real32_pointer => values_real32
    1467                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
    1468                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
    1469                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
    1470                                     values_real32_1d=values_real32_pointer )
    1471                   DEALLOCATE( values_real32 )
    1472                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real64 ) )  THEN
    1473                   ALLOCATE( values_real64(files(f)%dimensions(d)%bounds(1): &
     1441                   values_int16 = files(f)%dimensions(d)%values_int16
     1442                   values_int16_pointer => values_int16
     1443                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
     1444                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
     1445                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
     1446                                     values_int16_1d=values_int16_pointer )
     1447                   DEALLOCATE( values_int16 )
     1448                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int32 ) )  THEN
     1449                   ALLOCATE( values_int32(files(f)%dimensions(d)%bounds(1): &
    14741450                                          files(f)%dimensions(d)%bounds(2)) )
    1475                   values_real64 = files(f)%dimensions(d)%values_real64
    1476                   values_real64_pointer => values_real64
    1477                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
    1478                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
    1479                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
    1480                                     values_real64_1d=values_real64_pointer )
    1481                   DEALLOCATE( values_real64 )
    1482                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_realwp ) )  THEN
    1483                   ALLOCATE( values_realwp(files(f)%dimensions(d)%bounds(1): &
     1451                   values_int32 = files(f)%dimensions(d)%values_int32
     1452                   values_int32_pointer => values_int32
     1453                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
     1454                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
     1455                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
     1456                                     values_int32_1d=values_int32_pointer )
     1457                   DEALLOCATE( values_int32 )
     1458                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_intwp ) )  THEN
     1459                   ALLOCATE( values_intwp(files(f)%dimensions(d)%bounds(1): &
    14841460                                          files(f)%dimensions(d)%bounds(2)) )
    1485                   values_realwp = files(f)%dimensions(d)%values_realwp
    1486                   values_realwp_pointer => values_realwp
    1487                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
    1488                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
    1489                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
    1490                                     values_realwp_1d=values_realwp_pointer )
    1491                   DEALLOCATE( values_realwp )
    1492                ENDIF
    1493                IF ( return_value /= 0 )  EXIT
    1494             ENDDO
    1495 
    1496          ENDIF
    1497 
    1498          IF ( return_value /= 0 )  EXIT
    1499 
    1500       ENDDO
    1501    ENDIF
    1502 
    1503    CALL internal_message( 'debug', routine_name // ': finished' )
    1504 
    1505 END FUNCTION dom_def_end
     1461                   values_intwp = files(f)%dimensions(d)%values_intwp
     1462                   values_intwp_pointer => values_intwp
     1463                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
     1464                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
     1465                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
     1466                                     values_intwp_1d=values_intwp_pointer )
     1467                   DEALLOCATE( values_intwp )
     1468                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real32 ) )  THEN
     1469                   ALLOCATE( values_real32(files(f)%dimensions(d)%bounds(1): &
     1470                                           files(f)%dimensions(d)%bounds(2)) )
     1471                   values_real32 = files(f)%dimensions(d)%values_real32
     1472                   values_real32_pointer => values_real32
     1473                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
     1474                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
     1475                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
     1476                                     values_real32_1d=values_real32_pointer )
     1477                   DEALLOCATE( values_real32 )
     1478                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real64 ) )  THEN
     1479                   ALLOCATE( values_real64(files(f)%dimensions(d)%bounds(1): &
     1480                                           files(f)%dimensions(d)%bounds(2)) )
     1481                   values_real64 = files(f)%dimensions(d)%values_real64
     1482                   values_real64_pointer => values_real64
     1483                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
     1484                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
     1485                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
     1486                                     values_real64_1d=values_real64_pointer )
     1487                   DEALLOCATE( values_real64 )
     1488                ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_realwp ) )  THEN
     1489                   ALLOCATE( values_realwp(files(f)%dimensions(d)%bounds(1): &
     1490                                           files(f)%dimensions(d)%bounds(2)) )
     1491                   values_realwp = files(f)%dimensions(d)%values_realwp
     1492                   values_realwp_pointer => values_realwp
     1493                   return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &
     1494                                     bounds_start=(/ files(f)%dimensions(d)%bounds(1) /),    &
     1495                                     bounds_end  =(/ files(f)%dimensions(d)%bounds(2) /),    &
     1496                                     values_realwp_1d=values_realwp_pointer )
     1497                   DEALLOCATE( values_realwp )
     1498                ENDIF
     1499                IF ( return_value /= 0 )  EXIT
     1500             ENDDO
     1501
     1502          ENDIF
     1503
     1504          IF ( return_value /= 0 )  EXIT
     1505
     1506       ENDDO
     1507    ENDIF
     1508
     1509    CALL internal_message( 'debug', routine_name // ': finished' )
     1510
     1511 END FUNCTION dom_def_end
    15061512
    15071513!--------------------------------------------------------------------------------------------------!
     
    15261532!>       chosen, the values are written to file as given in the 'dom_write_var' call.
    15271533!--------------------------------------------------------------------------------------------------!
    1528 FUNCTION dom_write_var( file_name, variable_name, bounds_start, bounds_end,         &
    1529             values_int8_0d,   values_int8_1d,   values_int8_2d,   values_int8_3d,   &
    1530             values_int16_0d,  values_int16_1d,  values_int16_2d,  values_int16_3d,  &
    1531             values_int32_0d,  values_int32_1d,  values_int32_2d,  values_int32_3d,  &
    1532             values_intwp_0d,  values_intwp_1d,  values_intwp_2d,  values_intwp_3d,  &
    1533             values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &
    1534             values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &
    1535             values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d  &
    1536             ) RESULT( return_value )
    1537 
    1538    CHARACTER(LEN=charlen)            ::  file_format    !< file format chosen for file
    1539    CHARACTER(LEN=*),      INTENT(IN) ::  file_name      !< name of file
    1540    CHARACTER(LEN=*),      INTENT(IN) ::  variable_name  !< name of variable
    1541 
    1542    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_write_var'  !< name of routine
    1543 
    1544    INTEGER ::  file_id              !< file ID
    1545    INTEGER ::  i                    !< loop index
    1546    INTEGER ::  j                    !< loop index
    1547    INTEGER ::  k                    !< loop index
    1548    INTEGER ::  output_return_value  !< return value of a called output routine
    1549    INTEGER ::  return_value         !< return value
    1550    INTEGER ::  variable_id          !< variable ID
    1551 
    1552    INTEGER, DIMENSION(:),   INTENT(IN)  ::  bounds_end             !< end index per dimension of variable
    1553    INTEGER, DIMENSION(:),   INTENT(IN)  ::  bounds_start           !< start index per dimension of variable
    1554    INTEGER, DIMENSION(:),   ALLOCATABLE ::  bounds_origin          !< first index of each dimension
    1555    INTEGER, DIMENSION(:),   ALLOCATABLE ::  bounds_start_internal  !< start index per dim. for output after masking
    1556    INTEGER, DIMENSION(:),   ALLOCATABLE ::  value_counts           !< count of indices to be written per dimension
    1557    INTEGER, DIMENSION(:,:), ALLOCATABLE ::  masked_indices         !< list containing all output indices along a dimension
    1558 
    1559    LOGICAL ::  do_output  !< true if any data lies within given range of masked dimension
    1560    LOGICAL ::  is_global  !< true if variable is global
    1561 
    1562    INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL                   ::  values_int8_0d             !< output variable
    1563    INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL                   ::  values_int16_0d            !< output variable
    1564    INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL                   ::  values_int32_0d            !< output variable
    1565    INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL                   ::  values_intwp_0d            !< output variable
    1566    INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int8_1d             !< output variable
    1567    INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int16_1d            !< output variable
    1568    INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int32_1d            !< output variable
    1569    INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_intwp_1d            !< output variable
    1570    INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int8_2d             !< output variable
    1571    INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int16_2d            !< output variable
    1572    INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int32_2d            !< output variable
    1573    INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_intwp_2d            !< output variable
    1574    INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int8_3d             !< output variable
    1575    INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int16_3d            !< output variable
    1576    INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int32_3d            !< output variable
    1577    INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_intwp_3d            !< output variable
    1578 
    1579    INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_int8_1d_resorted    !< resorted output variable
    1580    INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_int16_1d_resorted   !< resorted output variable
    1581    INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_int32_1d_resorted   !< resorted output variable
    1582    INTEGER(iwp),    TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_intwp_1d_resorted   !< resorted output variable
    1583    INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_int8_2d_resorted    !< resorted output variable
    1584    INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_int16_2d_resorted   !< resorted output variable
    1585    INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_int32_2d_resorted   !< resorted output variable
    1586    INTEGER(iwp),    TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_intwp_2d_resorted   !< resorted output variable
    1587    INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_int8_3d_resorted    !< resorted output variable
    1588    INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_int16_3d_resorted   !< resorted output variable
    1589    INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_int32_3d_resorted   !< resorted output variable
    1590    INTEGER(iwp),    TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_intwp_3d_resorted   !< resorted output variable
    1591 
    1592    INTEGER(KIND=1), POINTER                                         ::  values_int8_0d_pointer     !< pointer to resortet array
    1593    INTEGER(KIND=2), POINTER                                         ::  values_int16_0d_pointer    !< pointer to resortet array
    1594    INTEGER(KIND=4), POINTER                                         ::  values_int32_0d_pointer    !< pointer to resortet array
    1595    INTEGER(iwp),    POINTER                                         ::  values_intwp_0d_pointer    !< pointer to resortet array
    1596    INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_int8_1d_pointer     !< pointer to resortet array
    1597    INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_int16_1d_pointer    !< pointer to resortet array
    1598    INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_int32_1d_pointer    !< pointer to resortet array
    1599    INTEGER(iwp),    POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_intwp_1d_pointer    !< pointer to resortet array
    1600    INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_int8_2d_pointer     !< pointer to resortet array
    1601    INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_int16_2d_pointer    !< pointer to resortet array
    1602    INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_int32_2d_pointer    !< pointer to resortet array
    1603    INTEGER(iwp),    POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_intwp_2d_pointer    !< pointer to resortet array
    1604    INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_int8_3d_pointer     !< pointer to resortet array
    1605    INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_int16_3d_pointer    !< pointer to resortet array
    1606    INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_int32_3d_pointer    !< pointer to resortet array
    1607    INTEGER(iwp),    POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_intwp_3d_pointer    !< pointer to resortet array
    1608 
    1609    REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL                      ::  values_real32_0d           !< output variable
    1610    REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL                      ::  values_real64_0d           !< output variable
    1611    REAL(wp),     POINTER, INTENT(IN), OPTIONAL                      ::  values_realwp_0d           !< output variable
    1612    REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)        ::  values_real32_1d           !< output variable
    1613    REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)        ::  values_real64_1d           !< output variable
    1614    REAL(wp),     POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)        ::  values_realwp_1d           !< output variable
    1615    REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)      ::  values_real32_2d           !< output variable
    1616    REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)      ::  values_real64_2d           !< output variable
    1617    REAL(wp),     POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)      ::  values_realwp_2d           !< output variable
    1618    REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:)    ::  values_real32_3d           !< output variable
    1619    REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:)    ::  values_real64_3d           !< output variable
    1620    REAL(wp),     POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:)    ::  values_realwp_3d           !< output variable
    1621 
    1622    REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:)                  ::  values_real32_1d_resorted  !< resorted output variable
    1623    REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:)                  ::  values_real64_1d_resorted  !< resorted output variable
    1624    REAL(wp),     TARGET, ALLOCATABLE, DIMENSION(:)                  ::  values_realwp_1d_resorted  !< resorted output variable
    1625    REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:)                ::  values_real32_2d_resorted  !< resorted output variable
    1626    REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:)                ::  values_real64_2d_resorted  !< resorted output variable
    1627    REAL(wp),     TARGET, ALLOCATABLE, DIMENSION(:,:)                ::  values_realwp_2d_resorted  !< resorted output variable
    1628    REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:)              ::  values_real32_3d_resorted  !< resorted output variable
    1629    REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:,:)              ::  values_real64_3d_resorted  !< resorted output variable
    1630    REAL(wp),     TARGET, ALLOCATABLE, DIMENSION(:,:,:)              ::  values_realwp_3d_resorted  !< resorted output variable
    1631 
    1632    REAL(KIND=4), POINTER                                            ::  values_real32_0d_pointer   !< pointer to resortet array
    1633    REAL(KIND=8), POINTER                                            ::  values_real64_0d_pointer   !< pointer to resortet array
    1634    REAL(wp),     POINTER                                            ::  values_realwp_0d_pointer   !< pointer to resortet array
    1635    REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:)                  ::  values_real32_1d_pointer   !< pointer to resortet array
    1636    REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:)                  ::  values_real64_1d_pointer   !< pointer to resortet array
    1637    REAL(wp),     POINTER, CONTIGUOUS, DIMENSION(:)                  ::  values_realwp_1d_pointer   !< pointer to resortet array
    1638    REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:)                ::  values_real32_2d_pointer   !< pointer to resortet array
    1639    REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:)                ::  values_real64_2d_pointer   !< pointer to resortet array
    1640    REAL(wp),     POINTER, CONTIGUOUS, DIMENSION(:,:)                ::  values_realwp_2d_pointer   !< pointer to resortet array
    1641    REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:)              ::  values_real32_3d_pointer   !< pointer to resortet array
    1642    REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:,:)              ::  values_real64_3d_pointer   !< pointer to resortet array
    1643    REAL(wp),     POINTER, CONTIGUOUS, DIMENSION(:,:,:)              ::  values_realwp_3d_pointer   !< pointer to resortet array
    1644 
    1645    TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  dimension_list  !< list of used dimensions of variable
    1646 
    1647 
    1648    return_value = 0
    1649    output_return_value = 0
    1650 
    1651    CALL internal_message( 'debug', routine_name // ': write ' // TRIM( variable_name ) // &
    1652                           ' into file ' // TRIM( file_name ) )
    1653 
    1654    !-- Search for variable within file
    1655    CALL find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, &
    1656                           is_global, dimension_list, return_value=return_value  )
    1657 
    1658    IF ( return_value == 0 )  THEN
    1659 
    1660       !-- Check if the correct amount of variable bounds were given
    1661       IF ( SIZE( bounds_start ) /= SIZE( dimension_list )  .OR.  &
    1662            SIZE( bounds_end ) /= SIZE( dimension_list ) )  THEN
    1663          return_value = 1
    1664          CALL internal_message( 'error', routine_name //                  &
    1665                                 ': number bounds do not match with ' //   &
    1666                                 'number of dimensions of variable ' //    &
    1667                                 '(variable "' // TRIM( variable_name ) // &
    1668                                 '", file "' // TRIM( file_name ) // '")!' )
    1669       ENDIF
    1670 
    1671    ENDIF
    1672 
    1673    IF ( return_value == 0 )  THEN
    1674 
    1675       !-- Save starting index (lower bounds) of each dimension
    1676       ALLOCATE( bounds_origin(SIZE( dimension_list )) )
    1677       ALLOCATE( bounds_start_internal(SIZE( dimension_list )) )
    1678       ALLOCATE( value_counts(SIZE( dimension_list )) )
    1679 
    1680       WRITE( temp_string, * ) bounds_start
    1681       CALL internal_message( 'debug', routine_name //                    &
    1682                              ': file "' // TRIM( file_name ) //          &
    1683                              '", variable "' // TRIM( variable_name ) // &
    1684                              '", bounds_start =' // TRIM( temp_string ) )
    1685       WRITE( temp_string, * ) bounds_end
    1686       CALL internal_message( 'debug', routine_name //                    &
    1687                              ': file "' // TRIM( file_name ) //          &
    1688                              '", variable "' // TRIM( variable_name ) // &
    1689                              '", bounds_end =' // TRIM( temp_string ) )
    1690 
    1691       !-- Get bounds for masking
    1692       CALL get_masked_indices_and_masked_dimension_bounds( dimension_list,                  &
    1693               bounds_start, bounds_end, bounds_start_internal, value_counts, bounds_origin, &
    1694               masked_indices )
    1695 
    1696       do_output = .NOT. ANY( value_counts == 0 )
    1697 
    1698       WRITE( temp_string, * ) bounds_start_internal
    1699       CALL internal_message( 'debug', routine_name //                    &
    1700                              ': file "' // TRIM( file_name ) //          &
    1701                              '", variable "' // TRIM( variable_name ) // &
    1702                              '", bounds_start_internal =' // TRIM( temp_string ) )
    1703       WRITE( temp_string, * ) value_counts
    1704       CALL internal_message( 'debug', routine_name //                    &
    1705                              ': file "' // TRIM( file_name ) //          &
    1706                              '", variable "' // TRIM( variable_name ) // &
    1707                              '", value_counts =' // TRIM( temp_string ) )
    1708 
    1709       !-- Mask and resort variable
    1710       !-- 8bit integer output
    1711       IF ( PRESENT( values_int8_0d ) )  THEN
    1712          values_int8_0d_pointer => values_int8_0d
    1713       ELSEIF ( PRESENT( values_int8_1d ) )  THEN
    1714          IF ( do_output ) THEN
    1715             ALLOCATE( values_int8_1d_resorted(0:value_counts(1)-1) )
    1716             !$OMP PARALLEL PRIVATE (i)
    1717             !$OMP DO
    1718             DO  i = 0, value_counts(1) - 1
    1719                values_int8_1d_resorted(i) = values_int8_1d(masked_indices(1,i))
    1720             ENDDO
    1721             !$OMP END PARALLEL
    1722          ELSE
    1723             ALLOCATE( values_int8_1d_resorted(1) )
    1724             values_int8_1d_resorted = 0_1
    1725          ENDIF
    1726          values_int8_1d_pointer => values_int8_1d_resorted
    1727       ELSEIF ( PRESENT( values_int8_2d ) )  THEN
    1728          IF ( do_output ) THEN
    1729             ALLOCATE( values_int8_2d_resorted(0:value_counts(1)-1, &
    1730                                               0:value_counts(2)-1) )
    1731             !$OMP PARALLEL PRIVATE (i,j)
    1732             !$OMP DO
    1733             DO  i = 0, value_counts(1) - 1
    1734                DO  j = 0, value_counts(2) - 1
    1735                   values_int8_2d_resorted(i,j) = values_int8_2d(masked_indices(2,j), &
    1736                                                                 masked_indices(1,i)  )
    1737                ENDDO
    1738             ENDDO
    1739             !$OMP END PARALLEL
    1740          ELSE
    1741             ALLOCATE( values_int8_2d_resorted(1,1) )
    1742             values_int8_2d_resorted = 0_1
    1743          ENDIF
    1744          values_int8_2d_pointer => values_int8_2d_resorted
    1745       ELSEIF ( PRESENT( values_int8_3d ) )  THEN
    1746          IF ( do_output ) THEN
    1747             ALLOCATE( values_int8_3d_resorted(0:value_counts(1)-1, &
    1748                                               0:value_counts(2)-1, &
    1749                                               0:value_counts(3)-1) )
    1750             !$OMP PARALLEL PRIVATE (i,j,k)
    1751             !$OMP DO
    1752             DO  i = 0, value_counts(1) - 1
    1753                DO  j = 0, value_counts(2) - 1
    1754                   DO  k = 0, value_counts(3) - 1
    1755                      values_int8_3d_resorted(i,j,k) = values_int8_3d(masked_indices(3,k), &
    1756                                                                      masked_indices(2,j), &
    1757                                                                      masked_indices(1,i)  )
    1758                   ENDDO
    1759                ENDDO
    1760             ENDDO
    1761             !$OMP END PARALLEL
    1762          ELSE
    1763             ALLOCATE( values_int8_3d_resorted(1,1,1) )
    1764             values_int8_3d_resorted = 0_1
    1765          ENDIF
    1766          values_int8_3d_pointer => values_int8_3d_resorted
    1767 
    1768       !-- 16bit integer output
    1769       ELSEIF ( PRESENT( values_int16_0d ) )  THEN
    1770          values_int16_0d_pointer => values_int16_0d
    1771       ELSEIF ( PRESENT( values_int16_1d ) )  THEN
    1772          IF ( do_output ) THEN
    1773             ALLOCATE( values_int16_1d_resorted(0:value_counts(1)-1) )
    1774             !$OMP PARALLEL PRIVATE (i)
    1775             !$OMP DO
    1776             DO  i = 0, value_counts(1) - 1
    1777                values_int16_1d_resorted(i) = values_int16_1d(masked_indices(1,i))
    1778             ENDDO
    1779             !$OMP END PARALLEL
    1780          ELSE
    1781             ALLOCATE( values_int16_1d_resorted(1) )
    1782             values_int16_1d_resorted = 0_1
    1783          ENDIF
    1784          values_int16_1d_pointer => values_int16_1d_resorted
    1785       ELSEIF ( PRESENT( values_int16_2d ) )  THEN
    1786          IF ( do_output ) THEN
    1787             ALLOCATE( values_int16_2d_resorted(0:value_counts(1)-1, &
     1534 FUNCTION dom_write_var( file_name, variable_name, bounds_start, bounds_end,         &
     1535             values_int8_0d,   values_int8_1d,   values_int8_2d,   values_int8_3d,   &
     1536             values_int16_0d,  values_int16_1d,  values_int16_2d,  values_int16_3d,  &
     1537             values_int32_0d,  values_int32_1d,  values_int32_2d,  values_int32_3d,  &
     1538             values_intwp_0d,  values_intwp_1d,  values_intwp_2d,  values_intwp_3d,  &
     1539             values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &
     1540             values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &
     1541             values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d  &
     1542             ) RESULT( return_value )
     1543
     1544    CHARACTER(LEN=charlen)            ::  file_format    !< file format chosen for file
     1545    CHARACTER(LEN=*),      INTENT(IN) ::  file_name      !< name of file
     1546    CHARACTER(LEN=*),      INTENT(IN) ::  variable_name  !< name of variable
     1547
     1548    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_write_var'  !< name of routine
     1549
     1550    INTEGER ::  file_id              !< file ID
     1551    INTEGER ::  i                    !< loop index
     1552    INTEGER ::  j                    !< loop index
     1553    INTEGER ::  k                    !< loop index
     1554    INTEGER ::  output_return_value  !< return value of a called output routine
     1555    INTEGER ::  return_value         !< return value
     1556    INTEGER ::  variable_id          !< variable ID
     1557
     1558    INTEGER, DIMENSION(:),   INTENT(IN)  ::  bounds_end             !< end index per dimension of variable
     1559    INTEGER, DIMENSION(:),   INTENT(IN)  ::  bounds_start           !< start index per dimension of variable
     1560    INTEGER, DIMENSION(:),   ALLOCATABLE ::  bounds_origin          !< first index of each dimension
     1561    INTEGER, DIMENSION(:),   ALLOCATABLE ::  bounds_start_internal  !< start index per dim. for output after masking
     1562    INTEGER, DIMENSION(:),   ALLOCATABLE ::  value_counts           !< count of indices to be written per dimension
     1563    INTEGER, DIMENSION(:,:), ALLOCATABLE ::  masked_indices         !< list containing all output indices along a dimension
     1564
     1565    LOGICAL ::  do_output  !< true if any data lies within given range of masked dimension
     1566    LOGICAL ::  is_global  !< true if variable is global
     1567
     1568    INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL                   ::  values_int8_0d             !< output variable
     1569    INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL                   ::  values_int16_0d            !< output variable
     1570    INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL                   ::  values_int32_0d            !< output variable
     1571    INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL                   ::  values_intwp_0d            !< output variable
     1572    INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int8_1d             !< output variable
     1573    INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int16_1d            !< output variable
     1574    INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int32_1d            !< output variable
     1575    INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_intwp_1d            !< output variable
     1576    INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int8_2d             !< output variable
     1577    INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int16_2d            !< output variable
     1578    INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int32_2d            !< output variable
     1579    INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_intwp_2d            !< output variable
     1580    INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int8_3d             !< output variable
     1581    INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int16_3d            !< output variable
     1582    INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int32_3d            !< output variable
     1583    INTEGER(iwp),    POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_intwp_3d            !< output variable
     1584
     1585    INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_int8_1d_resorted    !< resorted output variable
     1586    INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_int16_1d_resorted   !< resorted output variable
     1587    INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_int32_1d_resorted   !< resorted output variable
     1588    INTEGER(iwp),    TARGET, ALLOCATABLE, DIMENSION(:)               ::  values_intwp_1d_resorted   !< resorted output variable
     1589    INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_int8_2d_resorted    !< resorted output variable
     1590    INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_int16_2d_resorted   !< resorted output variable
     1591    INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_int32_2d_resorted   !< resorted output variable
     1592    INTEGER(iwp),    TARGET, ALLOCATABLE, DIMENSION(:,:)             ::  values_intwp_2d_resorted   !< resorted output variable
     1593    INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_int8_3d_resorted    !< resorted output variable
     1594    INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_int16_3d_resorted   !< resorted output variable
     1595    INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_int32_3d_resorted   !< resorted output variable
     1596    INTEGER(iwp),    TARGET, ALLOCATABLE, DIMENSION(:,:,:)           ::  values_intwp_3d_resorted   !< resorted output variable
     1597
     1598    INTEGER(KIND=1), POINTER                                         ::  values_int8_0d_pointer     !< pointer to resortet array
     1599    INTEGER(KIND=2), POINTER                                         ::  values_int16_0d_pointer    !< pointer to resortet array
     1600    INTEGER(KIND=4), POINTER                                         ::  values_int32_0d_pointer    !< pointer to resortet array
     1601    INTEGER(iwp),    POINTER                                         ::  values_intwp_0d_pointer    !< pointer to resortet array
     1602    INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_int8_1d_pointer     !< pointer to resortet array
     1603    INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_int16_1d_pointer    !< pointer to resortet array
     1604    INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_int32_1d_pointer    !< pointer to resortet array
     1605    INTEGER(iwp),    POINTER, CONTIGUOUS, DIMENSION(:)               ::  values_intwp_1d_pointer    !< pointer to resortet array
     1606    INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_int8_2d_pointer     !< pointer to resortet array
     1607    INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_int16_2d_pointer    !< pointer to resortet array
     1608    INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_int32_2d_pointer    !< pointer to resortet array
     1609    INTEGER(iwp),    POINTER, CONTIGUOUS, DIMENSION(:,:)             ::  values_intwp_2d_pointer    !< pointer to resortet array
     1610    INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_int8_3d_pointer     !< pointer to resortet array
     1611    INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_int16_3d_pointer    !< pointer to resortet array
     1612    INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_int32_3d_pointer    !< pointer to resortet array
     1613    INTEGER(iwp),    POINTER, CONTIGUOUS, DIMENSION(:,:,:)           ::  values_intwp_3d_pointer    !< pointer to resortet array
     1614
     1615    REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL                      ::  values_real32_0d           !< output variable
     1616    REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL                      ::  values_real64_0d           !< output variable
     1617    REAL(wp),     POINTER, INTENT(IN), OPTIONAL                      ::  values_realwp_0d           !< output variable
     1618    REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)        ::  values_real32_1d           !< output variable
     1619    REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)        ::  values_real64_1d           !< output variable
     1620    REAL(wp),     POINTER, INTENT(IN), OPTIONAL, DIMENSION(:)        ::  values_realwp_1d           !< output variable
     1621    REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)      ::  values_real32_2d           !< output variable
     1622    REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)      ::  values_real64_2d           !< output variable
     1623    REAL(wp),     POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:)      ::  values_realwp_2d           !< output variable
     1624    REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:)    ::  values_real32_3d           !< output variable
     1625    REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:)    ::  values_real64_3d           !< output variable
     1626    REAL(wp),     POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:)    ::  values_realwp_3d           !< output variable
     1627
     1628    REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:)                  ::  values_real32_1d_resorted  !< resorted output variable
     1629    REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:)                  ::  values_real64_1d_resorted  !< resorted output variable
     1630    REAL(wp),     TARGET, ALLOCATABLE, DIMENSION(:)                  ::  values_realwp_1d_resorted  !< resorted output variable
     1631    REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:)                ::  values_real32_2d_resorted  !< resorted output variable
     1632    REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:)                ::  values_real64_2d_resorted  !< resorted output variable
     1633    REAL(wp),     TARGET, ALLOCATABLE, DIMENSION(:,:)                ::  values_realwp_2d_resorted  !< resorted output variable
     1634    REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:)              ::  values_real32_3d_resorted  !< resorted output variable
     1635    REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:,:)              ::  values_real64_3d_resorted  !< resorted output variable
     1636    REAL(wp),     TARGET, ALLOCATABLE, DIMENSION(:,:,:)              ::  values_realwp_3d_resorted  !< resorted output variable
     1637
     1638    REAL(KIND=4), POINTER                                            ::  values_real32_0d_pointer   !< pointer to resortet array
     1639    REAL(KIND=8), POINTER                                            ::  values_real64_0d_pointer   !< pointer to resortet array
     1640    REAL(wp),     POINTER                                            ::  values_realwp_0d_pointer   !< pointer to resortet array
     1641    REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:)                  ::  values_real32_1d_pointer   !< pointer to resortet array
     1642    REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:)                  ::  values_real64_1d_pointer   !< pointer to resortet array
     1643    REAL(wp),     POINTER, CONTIGUOUS, DIMENSION(:)                  ::  values_realwp_1d_pointer   !< pointer to resortet array
     1644    REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:)                ::  values_real32_2d_pointer   !< pointer to resortet array
     1645    REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:)                ::  values_real64_2d_pointer   !< pointer to resortet array
     1646    REAL(wp),     POINTER, CONTIGUOUS, DIMENSION(:,:)                ::  values_realwp_2d_pointer   !< pointer to resortet array
     1647    REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:)              ::  values_real32_3d_pointer   !< pointer to resortet array
     1648    REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:,:)              ::  values_real64_3d_pointer   !< pointer to resortet array
     1649    REAL(wp),     POINTER, CONTIGUOUS, DIMENSION(:,:,:)              ::  values_realwp_3d_pointer   !< pointer to resortet array
     1650
     1651    TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  dimension_list  !< list of used dimensions of variable
     1652
     1653
     1654    return_value = 0
     1655    output_return_value = 0
     1656
     1657    CALL internal_message( 'debug', routine_name // ': write ' // TRIM( variable_name ) // &
     1658                           ' into file ' // TRIM( file_name ) )
     1659!
     1660!-- Search for variable within file
     1661    CALL find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, &
     1662                           is_global, dimension_list, return_value=return_value  )
     1663
     1664    IF ( return_value == 0 )  THEN
     1665!
     1666!--    Check if the correct amount of variable bounds were given
     1667       IF ( SIZE( bounds_start ) /= SIZE( dimension_list )  .OR.  &
     1668            SIZE( bounds_end ) /= SIZE( dimension_list ) )  THEN
     1669          return_value = 1
     1670          CALL internal_message( 'error', routine_name //                  &
     1671                                 ': number bounds do not match with ' //   &
     1672                                 'number of dimensions of variable ' //    &
     1673                                 '(variable "' // TRIM( variable_name ) // &
     1674                                 '", file "' // TRIM( file_name ) // '")!' )
     1675       ENDIF
     1676
     1677    ENDIF
     1678
     1679    IF ( return_value == 0 )  THEN
     1680!
     1681!--    Save starting index (lower bounds) of each dimension
     1682       ALLOCATE( bounds_origin(SIZE( dimension_list )) )
     1683       ALLOCATE( bounds_start_internal(SIZE( dimension_list )) )
     1684       ALLOCATE( value_counts(SIZE( dimension_list )) )
     1685
     1686       WRITE( temp_string, * ) bounds_start
     1687       CALL internal_message( 'debug', routine_name //                    &
     1688                              ': file "' // TRIM( file_name ) //          &
     1689                              '", variable "' // TRIM( variable_name ) // &
     1690                              '", bounds_start =' // TRIM( temp_string ) )
     1691       WRITE( temp_string, * ) bounds_end
     1692       CALL internal_message( 'debug', routine_name //                    &
     1693                              ': file "' // TRIM( file_name ) //          &
     1694                              '", variable "' // TRIM( variable_name ) // &
     1695                              '", bounds_end =' // TRIM( temp_string ) )
     1696!
     1697!--    Get bounds for masking
     1698       CALL get_masked_indices_and_masked_dimension_bounds( dimension_list,                  &
     1699               bounds_start, bounds_end, bounds_start_internal, value_counts, bounds_origin, &
     1700               masked_indices )
     1701
     1702       do_output = .NOT. ANY( value_counts == 0 )
     1703
     1704       WRITE( temp_string, * ) bounds_start_internal
     1705       CALL internal_message( 'debug', routine_name //                    &
     1706                              ': file "' // TRIM( file_name ) //          &
     1707                              '", variable "' // TRIM( variable_name ) // &
     1708                              '", bounds_start_internal =' // TRIM( temp_string ) )
     1709       WRITE( temp_string, * ) value_counts
     1710       CALL internal_message( 'debug', routine_name //                    &
     1711                              ': file "' // TRIM( file_name ) //          &
     1712                              '", variable "' // TRIM( variable_name ) // &
     1713                              '", value_counts =' // TRIM( temp_string ) )
     1714!
     1715!--    Mask and resort variable
     1716!--    8bit integer output
     1717       IF ( PRESENT( values_int8_0d ) )  THEN
     1718          values_int8_0d_pointer => values_int8_0d
     1719       ELSEIF ( PRESENT( values_int8_1d ) )  THEN
     1720          IF ( do_output ) THEN
     1721             ALLOCATE( values_int8_1d_resorted(0:value_counts(1)-1) )
     1722             !$OMP PARALLEL PRIVATE (i)
     1723             !$OMP DO
     1724             DO  i = 0, value_counts(1) - 1
     1725                values_int8_1d_resorted(i) = values_int8_1d(masked_indices(1,i))
     1726             ENDDO
     1727             !$OMP END PARALLEL
     1728          ELSE
     1729             ALLOCATE( values_int8_1d_resorted(1) )
     1730             values_int8_1d_resorted = 0_1
     1731          ENDIF
     1732          values_int8_1d_pointer => values_int8_1d_resorted
     1733       ELSEIF ( PRESENT( values_int8_2d ) )  THEN
     1734          IF ( do_output ) THEN
     1735             ALLOCATE( values_int8_2d_resorted(0:value_counts(1)-1, &
    17881736                                               0:value_counts(2)-1) )
    1789             !$OMP PARALLEL PRIVATE (i,j)
    1790             !$OMP DO
    1791             DO  i = 0, value_counts(1) - 1
    1792                DO  j = 0, value_counts(2) - 1
    1793                   values_int16_2d_resorted(i,j) = values_int16_2d(masked_indices(2,j), &
    1794                                                                   masked_indices(1,i))
    1795                ENDDO
    1796             ENDDO
    1797             !$OMP END PARALLEL
    1798          ELSE
    1799             ALLOCATE( values_int16_2d_resorted(1,1) )
    1800             values_int16_2d_resorted = 0_1
    1801          ENDIF
    1802          values_int16_2d_pointer => values_int16_2d_resorted
    1803       ELSEIF ( PRESENT( values_int16_3d ) )  THEN
    1804          IF ( do_output ) THEN
    1805             ALLOCATE( values_int16_3d_resorted(0:value_counts(1)-1, &
     1737             !$OMP PARALLEL PRIVATE (i,j)
     1738             !$OMP DO
     1739             DO  i = 0, value_counts(1) - 1
     1740                DO  j = 0, value_counts(2) - 1
     1741                   values_int8_2d_resorted(i,j) = values_int8_2d(masked_indices(2,j), &
     1742                                                                 masked_indices(1,i)  )
     1743                ENDDO
     1744             ENDDO
     1745             !$OMP END PARALLEL
     1746          ELSE
     1747             ALLOCATE( values_int8_2d_resorted(1,1) )
     1748             values_int8_2d_resorted = 0_1
     1749          ENDIF
     1750          values_int8_2d_pointer => values_int8_2d_resorted
     1751       ELSEIF ( PRESENT( values_int8_3d ) )  THEN
     1752          IF ( do_output ) THEN
     1753             ALLOCATE( values_int8_3d_resorted(0:value_counts(1)-1, &
    18061754                                               0:value_counts(2)-1, &
    18071755                                               0:value_counts(3)-1) )
    1808             !$OMP PARALLEL PRIVATE (i,j,k)
    1809             !$OMP DO
    1810             DO  i = 0, value_counts(1) - 1
    1811                DO  j = 0, value_counts(2) - 1
    1812                   DO  k = 0, value_counts(3) - 1
    1813                      values_int16_3d_resorted(i,j,k) = values_int16_3d(masked_indices(3,k), &
    1814                                                                        masked_indices(2,j), &
    1815                                                                        masked_indices(1,i)  )
    1816                   ENDDO
    1817                ENDDO
    1818             ENDDO
    1819             !$OMP END PARALLEL
    1820          ELSE
    1821             ALLOCATE( values_int16_3d_resorted(1,1,1) )
    1822             values_int16_3d_resorted = 0_1
    1823          ENDIF
    1824          values_int16_3d_pointer => values_int16_3d_resorted
    1825 
    1826       !-- 32bit integer output
    1827       ELSEIF ( PRESENT( values_int32_0d ) )  THEN
    1828          values_int32_0d_pointer => values_int32_0d
    1829       ELSEIF ( PRESENT( values_int32_1d ) )  THEN
    1830          IF ( do_output ) THEN
    1831             ALLOCATE( values_int32_1d_resorted(0:value_counts(1)-1) )
    1832             !$OMP PARALLEL PRIVATE (i)
    1833             !$OMP DO
    1834             DO  i = 0, value_counts(1) - 1
    1835                values_int32_1d_resorted(i) = values_int32_1d(masked_indices(1,i))
    1836             ENDDO
    1837             !$OMP END PARALLEL
    1838          ELSE
    1839             ALLOCATE( values_int32_1d_resorted(1) )
    1840             values_int32_1d_resorted = 0_1
    1841          ENDIF
    1842          values_int32_1d_pointer => values_int32_1d_resorted
    1843       ELSEIF ( PRESENT( values_int32_2d ) )  THEN
    1844          IF ( do_output ) THEN
    1845             ALLOCATE( values_int32_2d_resorted(0:value_counts(1)-1, &
    1846                                                0:value_counts(2)-1) )
    1847             !$OMP PARALLEL PRIVATE (i,j)
    1848             !$OMP DO
    1849             DO  i = 0, value_counts(1) - 1
    1850                DO  j = 0, value_counts(2) - 1
    1851                   values_int32_2d_resorted(i,j) = values_int32_2d(masked_indices(2,j), &
    1852                                                                   masked_indices(1,i)  )
    1853                ENDDO
    1854             ENDDO
    1855             !$OMP END PARALLEL
    1856          ELSE
    1857             ALLOCATE( values_int32_2d_resorted(1,1) )
    1858             values_int32_2d_resorted = 0_1
    1859          ENDIF
    1860          values_int32_2d_pointer => values_int32_2d_resorted
    1861       ELSEIF ( PRESENT( values_int32_3d ) )  THEN
    1862          IF ( do_output ) THEN
    1863             ALLOCATE( values_int32_3d_resorted(0:value_counts(1)-1, &
    1864                                                0:value_counts(2)-1, &
    1865                                                0:value_counts(3)-1) )
    1866             !$OMP PARALLEL PRIVATE (i,j,k)
    1867             !$OMP DO
    1868             DO  i = 0, value_counts(1) - 1
    1869                DO  j = 0, value_counts(2) - 1
    1870                   DO  k = 0, value_counts(3) - 1
    1871                      values_int32_3d_resorted(i,j,k) = values_int32_3d(masked_indices(3,k), &
    1872                                                                        masked_indices(2,j), &
    1873                                                                        masked_indices(1,i)  )
    1874                   ENDDO
    1875                ENDDO
    1876             ENDDO
    1877             !$OMP END PARALLEL
    1878          ELSE
    1879             ALLOCATE( values_int32_3d_resorted(1,1,1) )
    1880             values_int32_3d_resorted = 0_1
    1881          ENDIF
    1882          values_int32_3d_pointer => values_int32_3d_resorted
    1883 
    1884       !-- working-precision integer output
    1885       ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
    1886          values_intwp_0d_pointer => values_intwp_0d
    1887       ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
    1888          IF ( do_output ) THEN
    1889             ALLOCATE( values_intwp_1d_resorted(0:value_counts(1)-1) )
    1890             !$OMP PARALLEL PRIVATE (i)
    1891             !$OMP DO
    1892             DO  i = 0, value_counts(1) - 1
    1893                values_intwp_1d_resorted(i) = values_intwp_1d(masked_indices(1,i))
    1894             ENDDO
    1895             !$OMP END PARALLEL
    1896          ELSE
    1897             ALLOCATE( values_intwp_1d_resorted(1) )
    1898             values_intwp_1d_resorted = 0_1
    1899          ENDIF
    1900          values_intwp_1d_pointer => values_intwp_1d_resorted
    1901       ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
    1902          IF ( do_output ) THEN
    1903             ALLOCATE( values_intwp_2d_resorted(0:value_counts(1)-1, &
    1904                                                0:value_counts(2)-1) )
    1905             !$OMP PARALLEL PRIVATE (i,j)
    1906             !$OMP DO
    1907             DO  i = 0, value_counts(1) - 1
    1908                DO  j = 0, value_counts(2) - 1
    1909                   values_intwp_2d_resorted(i,j) = values_intwp_2d(masked_indices(2,j), &
    1910                                                                   masked_indices(1,i)  )
    1911                ENDDO
    1912             ENDDO
    1913             !$OMP END PARALLEL
    1914          ELSE
    1915             ALLOCATE( values_intwp_2d_resorted(1,1) )
    1916             values_intwp_2d_resorted = 0_1
    1917          ENDIF
    1918          values_intwp_2d_pointer => values_intwp_2d_resorted
    1919       ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
    1920          IF ( do_output ) THEN
    1921             ALLOCATE( values_intwp_3d_resorted(0:value_counts(1)-1, &
    1922                                                0:value_counts(2)-1, &
    1923                                                0:value_counts(3)-1) )
    1924             !$OMP PARALLEL PRIVATE (i,j,k)
    1925             !$OMP DO
    1926             DO  i = 0, value_counts(1) - 1
    1927                DO  j = 0, value_counts(2) - 1
    1928                   DO  k = 0, value_counts(3) - 1
    1929                      values_intwp_3d_resorted(i,j,k) = values_intwp_3d(masked_indices(3,k), &
    1930                                                                        masked_indices(2,j), &
    1931                                                                        masked_indices(1,i)  )
    1932                   ENDDO
    1933                ENDDO
    1934             ENDDO
    1935             !$OMP END PARALLEL
    1936          ELSE
    1937             ALLOCATE( values_intwp_3d_resorted(1,1,1) )
    1938             values_intwp_3d_resorted = 0_1
    1939          ENDIF
    1940          values_intwp_3d_pointer => values_intwp_3d_resorted
    1941 
    1942       !-- 32bit real output
    1943       ELSEIF ( PRESENT( values_real32_0d ) )  THEN
    1944          values_real32_0d_pointer => values_real32_0d
    1945       ELSEIF ( PRESENT( values_real32_1d ) )  THEN
    1946          IF ( do_output ) THEN
    1947             ALLOCATE( values_real32_1d_resorted(0:value_counts(1)-1) )
    1948             !$OMP PARALLEL PRIVATE (i)
    1949             !$OMP DO
    1950             DO  i = 0, value_counts(1) - 1
    1951                values_real32_1d_resorted(i) = values_real32_1d(masked_indices(1,i))
    1952             ENDDO
    1953             !$OMP END PARALLEL
    1954          ELSE
    1955             ALLOCATE( values_real32_1d_resorted(1) )
    1956             values_real32_1d_resorted = 0_1
    1957          ENDIF
    1958          values_real32_1d_pointer => values_real32_1d_resorted
    1959       ELSEIF ( PRESENT( values_real32_2d ) )  THEN
    1960          IF ( do_output ) THEN
    1961             ALLOCATE( values_real32_2d_resorted(0:value_counts(1)-1, &
     1756             !$OMP PARALLEL PRIVATE (i,j,k)
     1757             !$OMP DO
     1758             DO  i = 0, value_counts(1) - 1
     1759                DO  j = 0, value_counts(2) - 1
     1760                   DO  k = 0, value_counts(3) - 1
     1761                      values_int8_3d_resorted(i,j,k) = values_int8_3d(masked_indices(3,k), &
     1762                                                                      masked_indices(2,j), &
     1763                                                                      masked_indices(1,i)  )
     1764                   ENDDO
     1765                ENDDO
     1766             ENDDO
     1767             !$OMP END PARALLEL
     1768          ELSE
     1769             ALLOCATE( values_int8_3d_resorted(1,1,1) )
     1770             values_int8_3d_resorted = 0_1
     1771          ENDIF
     1772          values_int8_3d_pointer => values_int8_3d_resorted
     1773!
     1774!--    16bit integer output
     1775       ELSEIF ( PRESENT( values_int16_0d ) )  THEN
     1776          values_int16_0d_pointer => values_int16_0d
     1777       ELSEIF ( PRESENT( values_int16_1d ) )  THEN
     1778          IF ( do_output ) THEN
     1779             ALLOCATE( values_int16_1d_resorted(0:value_counts(1)-1) )
     1780             !$OMP PARALLEL PRIVATE (i)
     1781             !$OMP DO
     1782             DO  i = 0, value_counts(1) - 1
     1783                values_int16_1d_resorted(i) = values_int16_1d(masked_indices(1,i))
     1784             ENDDO
     1785             !$OMP END PARALLEL
     1786          ELSE
     1787             ALLOCATE( values_int16_1d_resorted(1) )
     1788             values_int16_1d_resorted = 0_1
     1789          ENDIF
     1790          values_int16_1d_pointer => values_int16_1d_resorted
     1791       ELSEIF ( PRESENT( values_int16_2d ) )  THEN
     1792          IF ( do_output ) THEN
     1793             ALLOCATE( values_int16_2d_resorted(0:value_counts(1)-1, &
    19621794                                                0:value_counts(2)-1) )
    1963             !$OMP PARALLEL PRIVATE (i,j)
    1964             !$OMP DO
    1965             DO  i = 0, value_counts(1) - 1
    1966                DO  j = 0, value_counts(2) - 1
    1967                   values_real32_2d_resorted(i,j) = values_real32_2d(masked_indices(2,j), &
    1968                                                                     masked_indices(1,i)  )
    1969                ENDDO
    1970             ENDDO
    1971             !$OMP END PARALLEL
    1972          ELSE
    1973             ALLOCATE( values_real32_2d_resorted(1,1) )
    1974             values_real32_2d_resorted = 0_1
    1975          ENDIF
    1976          values_real32_2d_pointer => values_real32_2d_resorted
    1977       ELSEIF ( PRESENT( values_real32_3d ) )  THEN
    1978          IF ( do_output ) THEN
    1979             ALLOCATE( values_real32_3d_resorted(0:value_counts(1)-1, &
     1795             !$OMP PARALLEL PRIVATE (i,j)
     1796             !$OMP DO
     1797             DO  i = 0, value_counts(1) - 1
     1798                DO  j = 0, value_counts(2) - 1
     1799                   values_int16_2d_resorted(i,j) = values_int16_2d(masked_indices(2,j), &
     1800                                                                   masked_indices(1,i))
     1801                ENDDO
     1802             ENDDO
     1803             !$OMP END PARALLEL
     1804          ELSE
     1805             ALLOCATE( values_int16_2d_resorted(1,1) )
     1806             values_int16_2d_resorted = 0_1
     1807          ENDIF
     1808          values_int16_2d_pointer => values_int16_2d_resorted
     1809       ELSEIF ( PRESENT( values_int16_3d ) )  THEN
     1810          IF ( do_output ) THEN
     1811             ALLOCATE( values_int16_3d_resorted(0:value_counts(1)-1, &
    19801812                                                0:value_counts(2)-1, &
    19811813                                                0:value_counts(3)-1) )
    1982             !$OMP PARALLEL PRIVATE (i,j,k)
    1983             !$OMP DO
    1984             DO  i = 0, value_counts(1) - 1
    1985                DO  j = 0, value_counts(2) - 1
    1986                   DO  k = 0, value_counts(3) - 1
    1987                      values_real32_3d_resorted(i,j,k) = values_real32_3d(masked_indices(3,k), &
    1988                                                                          masked_indices(2,j), &
    1989                                                                          masked_indices(1,i)  )
    1990                   ENDDO
    1991                ENDDO
    1992             ENDDO
    1993             !$OMP END PARALLEL
    1994          ELSE
    1995             ALLOCATE( values_real32_3d_resorted(1,1,1) )
    1996             values_real32_3d_resorted = 0_1
    1997          ENDIF
    1998          values_real32_3d_pointer => values_real32_3d_resorted
    1999 
    2000       !-- 64bit real output
    2001       ELSEIF ( PRESENT( values_real64_0d ) )  THEN
    2002          values_real64_0d_pointer => values_real64_0d
    2003       ELSEIF ( PRESENT( values_real64_1d ) )  THEN
    2004          IF ( do_output ) THEN
    2005             ALLOCATE( values_real64_1d_resorted(0:value_counts(1)-1) )
    2006             !$OMP PARALLEL PRIVATE (i)
    2007             !$OMP DO
    2008             DO  i = 0, value_counts(1) - 1
    2009                values_real64_1d_resorted(i) = values_real64_1d(masked_indices(1,i))
    2010             ENDDO
    2011             !$OMP END PARALLEL
    2012          ELSE
    2013             ALLOCATE( values_real64_1d_resorted(1) )
    2014             values_real64_1d_resorted = 0_1
    2015          ENDIF
    2016          values_real64_1d_pointer => values_real64_1d_resorted
    2017       ELSEIF ( PRESENT( values_real64_2d ) )  THEN
    2018          IF ( do_output ) THEN
    2019             ALLOCATE( values_real64_2d_resorted(0:value_counts(1)-1, &
     1814             !$OMP PARALLEL PRIVATE (i,j,k)
     1815             !$OMP DO
     1816             DO  i = 0, value_counts(1) - 1
     1817                DO  j = 0, value_counts(2) - 1
     1818                   DO  k = 0, value_counts(3) - 1
     1819                      values_int16_3d_resorted(i,j,k) = values_int16_3d(masked_indices(3,k), &
     1820                                                                        masked_indices(2,j), &
     1821                                                                        masked_indices(1,i)  )
     1822                   ENDDO
     1823                ENDDO
     1824             ENDDO
     1825             !$OMP END PARALLEL
     1826          ELSE
     1827             ALLOCATE( values_int16_3d_resorted(1,1,1) )
     1828             values_int16_3d_resorted = 0_1
     1829          ENDIF
     1830          values_int16_3d_pointer => values_int16_3d_resorted
     1831!
     1832!--    32bit integer output
     1833       ELSEIF ( PRESENT( values_int32_0d ) )  THEN
     1834          values_int32_0d_pointer => values_int32_0d
     1835       ELSEIF ( PRESENT( values_int32_1d ) )  THEN
     1836          IF ( do_output ) THEN
     1837             ALLOCATE( values_int32_1d_resorted(0:value_counts(1)-1) )
     1838             !$OMP PARALLEL PRIVATE (i)
     1839             !$OMP DO
     1840             DO  i = 0, value_counts(1) - 1
     1841                values_int32_1d_resorted(i) = values_int32_1d(masked_indices(1,i))
     1842             ENDDO
     1843             !$OMP END PARALLEL
     1844          ELSE
     1845             ALLOCATE( values_int32_1d_resorted(1) )
     1846             values_int32_1d_resorted = 0_1
     1847          ENDIF
     1848          values_int32_1d_pointer => values_int32_1d_resorted
     1849       ELSEIF ( PRESENT( values_int32_2d ) )  THEN
     1850          IF ( do_output ) THEN
     1851             ALLOCATE( values_int32_2d_resorted(0:value_counts(1)-1, &
    20201852                                                0:value_counts(2)-1) )
    2021             !$OMP PARALLEL PRIVATE (i,j)
    2022             !$OMP DO
    2023             DO  i = 0, value_counts(1) - 1
    2024                DO  j = 0, value_counts(2) - 1
    2025                   values_real64_2d_resorted(i,j) = values_real64_2d(masked_indices(2,j), &
    2026                                                                     masked_indices(1,i)  )
    2027                ENDDO
    2028             ENDDO
    2029             !$OMP END PARALLEL
    2030          ELSE
    2031             ALLOCATE( values_real64_2d_resorted(1,1) )
    2032             values_real64_2d_resorted = 0_1
    2033          ENDIF
    2034          values_real64_2d_pointer => values_real64_2d_resorted
    2035       ELSEIF ( PRESENT( values_real64_3d ) )  THEN
    2036          IF ( do_output ) THEN
    2037             ALLOCATE( values_real64_3d_resorted(0:value_counts(1)-1, &
     1853             !$OMP PARALLEL PRIVATE (i,j)
     1854             !$OMP DO
     1855             DO  i = 0, value_counts(1) - 1
     1856                DO  j = 0, value_counts(2) - 1
     1857                   values_int32_2d_resorted(i,j) = values_int32_2d(masked_indices(2,j), &
     1858                                                                   masked_indices(1,i)  )
     1859                ENDDO
     1860             ENDDO
     1861             !$OMP END PARALLEL
     1862          ELSE
     1863             ALLOCATE( values_int32_2d_resorted(1,1) )
     1864             values_int32_2d_resorted = 0_1
     1865          ENDIF
     1866          values_int32_2d_pointer => values_int32_2d_resorted
     1867       ELSEIF ( PRESENT( values_int32_3d ) )  THEN
     1868          IF ( do_output ) THEN
     1869             ALLOCATE( values_int32_3d_resorted(0:value_counts(1)-1, &
    20381870                                                0:value_counts(2)-1, &
    20391871                                                0:value_counts(3)-1) )
    2040             !$OMP PARALLEL PRIVATE (i,j,k)
    2041             !$OMP DO
    2042             DO  i = 0, value_counts(1) - 1
    2043                DO  j = 0, value_counts(2) - 1
    2044                   DO  k = 0, value_counts(3) - 1
    2045                      values_real64_3d_resorted(i,j,k) = values_real64_3d(masked_indices(3,k), &
    2046                                                                          masked_indices(2,j), &
    2047                                                                          masked_indices(1,i)  )
    2048                   ENDDO
    2049                ENDDO
    2050             ENDDO
    2051             !$OMP END PARALLEL
    2052          ELSE
    2053             ALLOCATE( values_real64_3d_resorted(1,1,1) )
    2054             values_real64_3d_resorted = 0_1
    2055          ENDIF
    2056          values_real64_3d_pointer => values_real64_3d_resorted
    2057 
    2058       !-- working-precision real output
    2059       ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
    2060          values_realwp_0d_pointer => values_realwp_0d
    2061       ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
    2062          IF ( do_output ) THEN
    2063             ALLOCATE( values_realwp_1d_resorted(0:value_counts(1)-1) )
    2064             !$OMP PARALLEL PRIVATE (i)
    2065             !$OMP DO
    2066             DO  i = 0, value_counts(1) - 1
    2067                values_realwp_1d_resorted(i) = values_realwp_1d(masked_indices(1,i))
    2068             ENDDO
    2069             !$OMP END PARALLEL
    2070          ELSE
    2071             ALLOCATE( values_realwp_1d_resorted(1) )
    2072             values_realwp_1d_resorted = 0_1
    2073          ENDIF
    2074          values_realwp_1d_pointer => values_realwp_1d_resorted
    2075       ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
    2076          IF ( do_output ) THEN
    2077             ALLOCATE( values_realwp_2d_resorted(0:value_counts(1)-1, &
     1872             !$OMP PARALLEL PRIVATE (i,j,k)
     1873             !$OMP DO
     1874             DO  i = 0, value_counts(1) - 1
     1875                DO  j = 0, value_counts(2) - 1
     1876                   DO  k = 0, value_counts(3) - 1
     1877                      values_int32_3d_resorted(i,j,k) = values_int32_3d(masked_indices(3,k), &
     1878                                                                        masked_indices(2,j), &
     1879                                                                        masked_indices(1,i)  )
     1880                   ENDDO
     1881                ENDDO
     1882             ENDDO
     1883             !$OMP END PARALLEL
     1884          ELSE
     1885             ALLOCATE( values_int32_3d_resorted(1,1,1) )
     1886             values_int32_3d_resorted = 0_1
     1887          ENDIF
     1888          values_int32_3d_pointer => values_int32_3d_resorted
     1889!
     1890!--    working-precision integer output
     1891       ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
     1892          values_intwp_0d_pointer => values_intwp_0d
     1893       ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
     1894          IF ( do_output ) THEN
     1895             ALLOCATE( values_intwp_1d_resorted(0:value_counts(1)-1) )
     1896             !$OMP PARALLEL PRIVATE (i)
     1897             !$OMP DO
     1898             DO  i = 0, value_counts(1) - 1
     1899                values_intwp_1d_resorted(i) = values_intwp_1d(masked_indices(1,i))
     1900             ENDDO
     1901             !$OMP END PARALLEL
     1902          ELSE
     1903             ALLOCATE( values_intwp_1d_resorted(1) )
     1904             values_intwp_1d_resorted = 0_1
     1905          ENDIF
     1906          values_intwp_1d_pointer => values_intwp_1d_resorted
     1907       ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
     1908          IF ( do_output ) THEN
     1909             ALLOCATE( values_intwp_2d_resorted(0:value_counts(1)-1, &
    20781910                                                0:value_counts(2)-1) )
    2079             !$OMP PARALLEL PRIVATE (i,j)
    2080             !$OMP DO
    2081             DO  i = 0, value_counts(1) - 1
    2082                DO  j = 0, value_counts(2) - 1
    2083                   values_realwp_2d_resorted(i,j) = values_realwp_2d(masked_indices(2,j), &
    2084                                                                     masked_indices(1,i)  )
    2085                ENDDO
    2086             ENDDO
    2087             !$OMP END PARALLEL
    2088          ELSE
    2089             ALLOCATE( values_realwp_2d_resorted(1,1) )
    2090             values_realwp_2d_resorted = 0_1
    2091          ENDIF
    2092          values_realwp_2d_pointer => values_realwp_2d_resorted
    2093       ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
    2094          IF ( do_output ) THEN
    2095             ALLOCATE( values_realwp_3d_resorted(0:value_counts(1)-1, &
     1911             !$OMP PARALLEL PRIVATE (i,j)
     1912             !$OMP DO
     1913             DO  i = 0, value_counts(1) - 1
     1914                DO  j = 0, value_counts(2) - 1
     1915                   values_intwp_2d_resorted(i,j) = values_intwp_2d(masked_indices(2,j), &
     1916                                                                   masked_indices(1,i)  )
     1917                ENDDO
     1918             ENDDO
     1919             !$OMP END PARALLEL
     1920          ELSE
     1921             ALLOCATE( values_intwp_2d_resorted(1,1) )
     1922             values_intwp_2d_resorted = 0_1
     1923          ENDIF
     1924          values_intwp_2d_pointer => values_intwp_2d_resorted
     1925       ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
     1926          IF ( do_output ) THEN
     1927             ALLOCATE( values_intwp_3d_resorted(0:value_counts(1)-1, &
    20961928                                                0:value_counts(2)-1, &
    20971929                                                0:value_counts(3)-1) )
    2098             !$OMP PARALLEL PRIVATE (i,j,k)
    2099             !$OMP DO
    2100             DO  i = 0, value_counts(1) - 1
    2101                DO  j = 0, value_counts(2) - 1
    2102                   DO  k = 0, value_counts(3) - 1
    2103                      values_realwp_3d_resorted(i,j,k) = values_realwp_3d(masked_indices(3,k), &
    2104                                                                          masked_indices(2,j), &
    2105                                                                          masked_indices(1,i)  )
    2106                   ENDDO
    2107                ENDDO
    2108             ENDDO
    2109             !$OMP END PARALLEL
    2110          ELSE
    2111             ALLOCATE( values_realwp_3d_resorted(1,1,1) )
    2112             values_realwp_3d_resorted = 0_1
    2113          ENDIF
    2114          values_realwp_3d_pointer => values_realwp_3d_resorted
    2115 
    2116       ELSE
    2117          return_value = 1
    2118          CALL internal_message( 'error', routine_name //                  &
    2119                                 ': no output values given ' //            &
    2120                                 '(variable "' // TRIM( variable_name ) // &
    2121                                 '", file "' // TRIM( file_name ) // '")!'  )
    2122       ENDIF
    2123 
    2124       DEALLOCATE( masked_indices )
    2125 
    2126    ENDIF  ! Check for error
    2127 
    2128    IF ( return_value == 0 )  THEN
    2129 
    2130       !-- Write variable into file
    2131       SELECT CASE ( TRIM( file_format ) )
    2132 
    2133          CASE ( 'binary' )
    2134             !-- 8bit integer output
    2135             IF ( PRESENT( values_int8_0d ) )  THEN
    2136                CALL binary_write_variable( file_id, variable_id,                      &
    2137                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2138                        values_int8_0d=values_int8_0d_pointer, return_value=output_return_value )
    2139             ELSEIF ( PRESENT( values_int8_1d ) )  THEN
    2140                CALL binary_write_variable( file_id, variable_id,                      &
    2141                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2142                        values_int8_1d=values_int8_1d_pointer, return_value=output_return_value )
    2143             ELSEIF ( PRESENT( values_int8_2d ) )  THEN
    2144                CALL binary_write_variable( file_id, variable_id,                      &
    2145                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2146                        values_int8_2d=values_int8_2d_pointer, return_value=output_return_value )
    2147             ELSEIF ( PRESENT( values_int8_3d ) )  THEN
    2148                CALL binary_write_variable( file_id, variable_id,                      &
    2149                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2150                        values_int8_3d=values_int8_3d_pointer, return_value=output_return_value )
    2151             !-- 16bit integer output
    2152             ELSEIF ( PRESENT( values_int16_0d ) )  THEN
    2153                CALL binary_write_variable( file_id, variable_id,                      &
    2154                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2155                        values_int16_0d=values_int16_0d_pointer, return_value=output_return_value )
    2156             ELSEIF ( PRESENT( values_int16_1d ) )  THEN
    2157                CALL binary_write_variable( file_id, variable_id,                      &
    2158                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2159                        values_int16_1d=values_int16_1d_pointer, return_value=output_return_value )
    2160             ELSEIF ( PRESENT( values_int16_2d ) )  THEN
    2161                CALL binary_write_variable( file_id, variable_id,                      &
    2162                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2163                        values_int16_2d=values_int16_2d_pointer, return_value=output_return_value )
    2164             ELSEIF ( PRESENT( values_int16_3d ) )  THEN
    2165                CALL binary_write_variable( file_id, variable_id,                      &
    2166                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2167                        values_int16_3d=values_int16_3d_pointer, return_value=output_return_value )
    2168             !-- 32bit integer output
    2169             ELSEIF ( PRESENT( values_int32_0d ) )  THEN
    2170                CALL binary_write_variable( file_id, variable_id,                      &
    2171                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2172                        values_int32_0d=values_int32_0d_pointer, return_value=output_return_value )
    2173             ELSEIF ( PRESENT( values_int32_1d ) )  THEN
    2174                CALL binary_write_variable( file_id, variable_id,                      &
    2175                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2176                        values_int32_1d=values_int32_1d_pointer, return_value=output_return_value )
    2177             ELSEIF ( PRESENT( values_int32_2d ) )  THEN
    2178                CALL binary_write_variable( file_id, variable_id,                      &
    2179                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2180                        values_int32_2d=values_int32_2d_pointer, return_value=output_return_value )
    2181             ELSEIF ( PRESENT( values_int32_3d ) )  THEN
    2182                CALL binary_write_variable( file_id, variable_id,                      &
    2183                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2184                        values_int32_3d=values_int32_3d_pointer, return_value=output_return_value )
    2185             !-- working-precision integer output
    2186             ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
    2187                CALL binary_write_variable( file_id, variable_id,                      &
    2188                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2189                        values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value )
    2190             ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
    2191                CALL binary_write_variable( file_id, variable_id,                      &
    2192                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2193                        values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value )
    2194             ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
    2195                CALL binary_write_variable( file_id, variable_id,                      &
    2196                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2197                        values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value )
    2198             ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
    2199                CALL binary_write_variable( file_id, variable_id,                      &
    2200                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2201                        values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value )
    2202             !-- 32bit real output
    2203             ELSEIF ( PRESENT( values_real32_0d ) )  THEN
    2204                CALL binary_write_variable( file_id, variable_id,                      &
    2205                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2206                        values_real32_0d=values_real32_0d_pointer, return_value=output_return_value )
    2207             ELSEIF ( PRESENT( values_real32_1d ) )  THEN
    2208                CALL binary_write_variable( file_id, variable_id,                      &
    2209                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2210                        values_real32_1d=values_real32_1d_pointer, return_value=output_return_value )
    2211             ELSEIF ( PRESENT( values_real32_2d ) )  THEN
    2212                CALL binary_write_variable( file_id, variable_id,                      &
    2213                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2214                        values_real32_2d=values_real32_2d_pointer, return_value=output_return_value )
    2215             ELSEIF ( PRESENT( values_real32_3d ) )  THEN
    2216                CALL binary_write_variable( file_id, variable_id,                      &
    2217                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2218                        values_real32_3d=values_real32_3d_pointer, return_value=output_return_value )
    2219             !-- 64bit real output
    2220             ELSEIF ( PRESENT( values_real64_0d ) )  THEN
    2221                CALL binary_write_variable( file_id, variable_id,                      &
    2222                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2223                        values_real64_0d=values_real64_0d_pointer, return_value=output_return_value )
    2224             ELSEIF ( PRESENT( values_real64_1d ) )  THEN
    2225                CALL binary_write_variable( file_id, variable_id,                      &
    2226                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2227                        values_real64_1d=values_real64_1d_pointer, return_value=output_return_value )
    2228             ELSEIF ( PRESENT( values_real64_2d ) )  THEN
    2229                CALL binary_write_variable( file_id, variable_id,                      &
    2230                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2231                        values_real64_2d=values_real64_2d_pointer, return_value=output_return_value )
    2232             ELSEIF ( PRESENT( values_real64_3d ) )  THEN
    2233                CALL binary_write_variable( file_id, variable_id,                      &
    2234                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2235                        values_real64_3d=values_real64_3d_pointer, return_value=output_return_value )
    2236             !-- working-precision real output
    2237             ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
    2238                CALL binary_write_variable( file_id, variable_id,                      &
    2239                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2240                        values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value )
    2241             ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
    2242                CALL binary_write_variable( file_id, variable_id,                      &
    2243                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2244                        values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value )
    2245             ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
    2246                CALL binary_write_variable( file_id, variable_id,                      &
    2247                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2248                        values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value )
    2249             ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
    2250                CALL binary_write_variable( file_id, variable_id,                      &
    2251                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2252                        values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value )
    2253             ELSE
    2254                return_value = 1
    2255                CALL internal_message( 'error', routine_name //                          &
    2256                                       ': output_type not supported by file format "' // &
    2257                                       TRIM( file_format ) // '" ' //                    &
    2258                                       '(variable "' // TRIM( variable_name ) //         &
    2259                                       '", file "' // TRIM( file_name ) // '")!' )
    2260             ENDIF
    2261 
    2262          CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
    2263             !-- 8bit integer output
    2264             IF ( PRESENT( values_int8_0d ) )  THEN
    2265                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2266                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2267                        values_int8_0d=values_int8_0d_pointer, return_value=output_return_value )
    2268             ELSEIF ( PRESENT( values_int8_1d ) )  THEN
    2269                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2270                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2271                        values_int8_1d=values_int8_1d_pointer, return_value=output_return_value )
    2272             ELSEIF ( PRESENT( values_int8_2d ) )  THEN
    2273                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2274                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2275                        values_int8_2d=values_int8_2d_pointer, return_value=output_return_value )
    2276             ELSEIF ( PRESENT( values_int8_3d ) )  THEN
    2277                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2278                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2279                        values_int8_3d=values_int8_3d_pointer, return_value=output_return_value )
    2280             !-- 16bit integer output
    2281             ELSEIF ( PRESENT( values_int16_0d ) )  THEN
    2282                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2283                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2284                        values_int16_0d=values_int16_0d_pointer, return_value=output_return_value )
    2285             ELSEIF ( PRESENT( values_int16_1d ) )  THEN
    2286                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2287                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2288                        values_int16_1d=values_int16_1d_pointer, return_value=output_return_value )
    2289             ELSEIF ( PRESENT( values_int16_2d ) )  THEN
    2290                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2291                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2292                        values_int16_2d=values_int16_2d_pointer, return_value=output_return_value )
    2293             ELSEIF ( PRESENT( values_int16_3d ) )  THEN
    2294                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2295                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2296                        values_int16_3d=values_int16_3d_pointer, return_value=output_return_value )
    2297             !-- 32bit integer output
    2298             ELSEIF ( PRESENT( values_int32_0d ) )  THEN
    2299                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2300                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2301                        values_int32_0d=values_int32_0d_pointer, return_value=output_return_value )
    2302             ELSEIF ( PRESENT( values_int32_1d ) )  THEN
    2303                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2304                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2305                        values_int32_1d=values_int32_1d_pointer, return_value=output_return_value )
    2306             ELSEIF ( PRESENT( values_int32_2d ) )  THEN
    2307                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2308                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2309                        values_int32_2d=values_int32_2d_pointer, return_value=output_return_value )
    2310             ELSEIF ( PRESENT( values_int32_3d ) )  THEN
    2311                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2312                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2313                        values_int32_3d=values_int32_3d_pointer, return_value=output_return_value )
    2314             !-- working-precision integer output
    2315             ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
    2316                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2317                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2318                        values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value )
    2319             ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
    2320                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2321                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2322                        values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value )
    2323             ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
    2324                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2325                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2326                        values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value )
    2327             ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
    2328                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2329                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2330                        values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value )
    2331             !-- 32bit real output
    2332             ELSEIF ( PRESENT( values_real32_0d ) )  THEN
    2333                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2334                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2335                        values_real32_0d=values_real32_0d_pointer, return_value=output_return_value )
    2336             ELSEIF ( PRESENT( values_real32_1d ) )  THEN
    2337                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2338                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2339                        values_real32_1d=values_real32_1d_pointer, return_value=output_return_value )
    2340             ELSEIF ( PRESENT( values_real32_2d ) )  THEN
    2341                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2342                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2343                        values_real32_2d=values_real32_2d_pointer, return_value=output_return_value )
    2344             ELSEIF ( PRESENT( values_real32_3d ) )  THEN
    2345                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2346                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2347                        values_real32_3d=values_real32_3d_pointer, return_value=output_return_value )
    2348             !-- 64bit real output
    2349             ELSEIF ( PRESENT( values_real64_0d ) )  THEN
    2350                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2351                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2352                        values_real64_0d=values_real64_0d_pointer, return_value=output_return_value )
    2353             ELSEIF ( PRESENT( values_real64_1d ) )  THEN
    2354                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2355                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2356                        values_real64_1d=values_real64_1d_pointer, return_value=output_return_value )
    2357             ELSEIF ( PRESENT( values_real64_2d ) )  THEN
    2358                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2359                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2360                        values_real64_2d=values_real64_2d_pointer, return_value=output_return_value )
    2361             ELSEIF ( PRESENT( values_real64_3d ) )  THEN
    2362                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2363                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2364                        values_real64_3d=values_real64_3d_pointer, return_value=output_return_value )
    2365             !-- working-precision real output
    2366             ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
    2367                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2368                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2369                        values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value )
    2370             ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
    2371                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2372                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2373                        values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value )
    2374             ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
    2375                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2376                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2377                        values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value )
    2378             ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
    2379                CALL netcdf4_write_variable( file_id, variable_id,                     &
    2380                        bounds_start_internal, value_counts, bounds_origin, is_global, &
    2381                        values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value )
    2382             ELSE
    2383                return_value = 1
    2384                CALL internal_message( 'error', routine_name //                          &
    2385                                       ': output_type not supported by file format "' // &
    2386                                       TRIM( file_format ) // '" ' //                    &
    2387                                       '(variable "' // TRIM( variable_name ) //         &
    2388                                       '", file "' // TRIM( file_name ) // '")!' )
    2389             ENDIF
    2390 
    2391          CASE DEFAULT
    2392             return_value = 1
    2393             CALL internal_message( 'error', routine_name //                    &
    2394                                    ': file format "' // TRIM( file_format ) // &
    2395                                    '" not supported ' //                       &
    2396                                    '(variable "' // TRIM( variable_name ) //   &
    2397                                    '", file "' // TRIM( file_name ) // '")!' )
    2398 
    2399       END SELECT
    2400 
    2401       IF ( return_value == 0  .AND.  output_return_value /= 0 )  THEN
    2402          return_value = 1
    2403          CALL internal_message( 'error', routine_name //                  &
    2404                                 ': error while writing variable ' //      &
    2405                                 '(variable "' // TRIM( variable_name ) // &
    2406                                 '", file "' // TRIM( file_name ) // '")!' )
    2407       ENDIF
    2408 
    2409    ENDIF
    2410 
    2411 END FUNCTION dom_write_var
     1930             !$OMP PARALLEL PRIVATE (i,j,k)
     1931             !$OMP DO
     1932             DO  i = 0, value_counts(1) - 1
     1933                DO  j = 0, value_counts(2) - 1
     1934                   DO  k = 0, value_counts(3) - 1
     1935                      values_intwp_3d_resorted(i,j,k) = values_intwp_3d(masked_indices(3,k), &
     1936                                                                        masked_indices(2,j), &
     1937                                                                        masked_indices(1,i)  )
     1938                   ENDDO
     1939                ENDDO
     1940             ENDDO
     1941             !$OMP END PARALLEL
     1942          ELSE
     1943             ALLOCATE( values_intwp_3d_resorted(1,1,1) )
     1944             values_intwp_3d_resorted = 0_1
     1945          ENDIF
     1946          values_intwp_3d_pointer => values_intwp_3d_resorted
     1947!
     1948!--    32bit real output
     1949       ELSEIF ( PRESENT( values_real32_0d ) )  THEN
     1950          values_real32_0d_pointer => values_real32_0d
     1951       ELSEIF ( PRESENT( values_real32_1d ) )  THEN
     1952          IF ( do_output ) THEN
     1953             ALLOCATE( values_real32_1d_resorted(0:value_counts(1)-1) )
     1954             !$OMP PARALLEL PRIVATE (i)
     1955             !$OMP DO
     1956             DO  i = 0, value_counts(1) - 1
     1957                values_real32_1d_resorted(i) = values_real32_1d(masked_indices(1,i))
     1958             ENDDO
     1959             !$OMP END PARALLEL
     1960          ELSE
     1961             ALLOCATE( values_real32_1d_resorted(1) )
     1962             values_real32_1d_resorted = 0_1
     1963          ENDIF
     1964          values_real32_1d_pointer => values_real32_1d_resorted
     1965       ELSEIF ( PRESENT( values_real32_2d ) )  THEN
     1966          IF ( do_output ) THEN
     1967             ALLOCATE( values_real32_2d_resorted(0:value_counts(1)-1, &
     1968                                                 0:value_counts(2)-1) )
     1969             !$OMP PARALLEL PRIVATE (i,j)
     1970             !$OMP DO
     1971             DO  i = 0, value_counts(1) - 1
     1972                DO  j = 0, value_counts(2) - 1
     1973                   values_real32_2d_resorted(i,j) = values_real32_2d(masked_indices(2,j), &
     1974                                                                     masked_indices(1,i)  )
     1975                ENDDO
     1976             ENDDO
     1977             !$OMP END PARALLEL
     1978          ELSE
     1979             ALLOCATE( values_real32_2d_resorted(1,1) )
     1980             values_real32_2d_resorted = 0_1
     1981          ENDIF
     1982          values_real32_2d_pointer => values_real32_2d_resorted
     1983       ELSEIF ( PRESENT( values_real32_3d ) )  THEN
     1984          IF ( do_output ) THEN
     1985             ALLOCATE( values_real32_3d_resorted(0:value_counts(1)-1, &
     1986                                                 0:value_counts(2)-1, &
     1987                                                 0:value_counts(3)-1) )
     1988             !$OMP PARALLEL PRIVATE (i,j,k)
     1989             !$OMP DO
     1990             DO  i = 0, value_counts(1) - 1
     1991                DO  j = 0, value_counts(2) - 1
     1992                   DO  k = 0, value_counts(3) - 1
     1993                      values_real32_3d_resorted(i,j,k) = values_real32_3d(masked_indices(3,k), &
     1994                                                                          masked_indices(2,j), &
     1995                                                                          masked_indices(1,i)  )
     1996                   ENDDO
     1997                ENDDO
     1998             ENDDO
     1999             !$OMP END PARALLEL
     2000          ELSE
     2001             ALLOCATE( values_real32_3d_resorted(1,1,1) )
     2002             values_real32_3d_resorted = 0_1
     2003          ENDIF
     2004          values_real32_3d_pointer => values_real32_3d_resorted
     2005!
     2006!--    64bit real output
     2007       ELSEIF ( PRESENT( values_real64_0d ) )  THEN
     2008          values_real64_0d_pointer => values_real64_0d
     2009       ELSEIF ( PRESENT( values_real64_1d ) )  THEN
     2010          IF ( do_output ) THEN
     2011             ALLOCATE( values_real64_1d_resorted(0:value_counts(1)-1) )
     2012             !$OMP PARALLEL PRIVATE (i)
     2013             !$OMP DO
     2014             DO  i = 0, value_counts(1) - 1
     2015                values_real64_1d_resorted(i) = values_real64_1d(masked_indices(1,i))
     2016             ENDDO
     2017             !$OMP END PARALLEL
     2018          ELSE
     2019             ALLOCATE( values_real64_1d_resorted(1) )
     2020             values_real64_1d_resorted = 0_1
     2021          ENDIF
     2022          values_real64_1d_pointer => values_real64_1d_resorted
     2023       ELSEIF ( PRESENT( values_real64_2d ) )  THEN
     2024          IF ( do_output ) THEN
     2025             ALLOCATE( values_real64_2d_resorted(0:value_counts(1)-1, &
     2026                                                 0:value_counts(2)-1) )
     2027             !$OMP PARALLEL PRIVATE (i,j)
     2028             !$OMP DO
     2029             DO  i = 0, value_counts(1) - 1
     2030                DO  j = 0, value_counts(2) - 1
     2031                   values_real64_2d_resorted(i,j) = values_real64_2d(masked_indices(2,j), &
     2032                                                                     masked_indices(1,i)  )
     2033                ENDDO
     2034             ENDDO
     2035             !$OMP END PARALLEL
     2036          ELSE
     2037             ALLOCATE( values_real64_2d_resorted(1,1) )
     2038             values_real64_2d_resorted = 0_1
     2039          ENDIF
     2040          values_real64_2d_pointer => values_real64_2d_resorted
     2041       ELSEIF ( PRESENT( values_real64_3d ) )  THEN
     2042          IF ( do_output ) THEN
     2043             ALLOCATE( values_real64_3d_resorted(0:value_counts(1)-1, &
     2044                                                 0:value_counts(2)-1, &
     2045                                                 0:value_counts(3)-1) )
     2046             !$OMP PARALLEL PRIVATE (i,j,k)
     2047             !$OMP DO
     2048             DO  i = 0, value_counts(1) - 1
     2049                DO  j = 0, value_counts(2) - 1
     2050                   DO  k = 0, value_counts(3) - 1
     2051                      values_real64_3d_resorted(i,j,k) = values_real64_3d(masked_indices(3,k), &
     2052                                                                          masked_indices(2,j), &
     2053                                                                          masked_indices(1,i)  )
     2054                   ENDDO
     2055                ENDDO
     2056             ENDDO
     2057             !$OMP END PARALLEL
     2058          ELSE
     2059             ALLOCATE( values_real64_3d_resorted(1,1,1) )
     2060             values_real64_3d_resorted = 0_1
     2061          ENDIF
     2062          values_real64_3d_pointer => values_real64_3d_resorted
     2063!
     2064!--    working-precision real output
     2065       ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
     2066          values_realwp_0d_pointer => values_realwp_0d
     2067       ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
     2068          IF ( do_output ) THEN
     2069             ALLOCATE( values_realwp_1d_resorted(0:value_counts(1)-1) )
     2070             !$OMP PARALLEL PRIVATE (i)
     2071             !$OMP DO
     2072             DO  i = 0, value_counts(1) - 1
     2073                values_realwp_1d_resorted(i) = values_realwp_1d(masked_indices(1,i))
     2074             ENDDO
     2075             !$OMP END PARALLEL
     2076          ELSE
     2077             ALLOCATE( values_realwp_1d_resorted(1) )
     2078             values_realwp_1d_resorted = 0_1
     2079          ENDIF
     2080          values_realwp_1d_pointer => values_realwp_1d_resorted
     2081       ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
     2082          IF ( do_output ) THEN
     2083             ALLOCATE( values_realwp_2d_resorted(0:value_counts(1)-1, &
     2084                                                 0:value_counts(2)-1) )
     2085             !$OMP PARALLEL PRIVATE (i,j)
     2086             !$OMP DO
     2087             DO  i = 0, value_counts(1) - 1
     2088                DO  j = 0, value_counts(2) - 1
     2089                   values_realwp_2d_resorted(i,j) = values_realwp_2d(masked_indices(2,j), &
     2090                                                                     masked_indices(1,i)  )
     2091                ENDDO
     2092             ENDDO
     2093             !$OMP END PARALLEL
     2094          ELSE
     2095             ALLOCATE( values_realwp_2d_resorted(1,1) )
     2096             values_realwp_2d_resorted = 0_1
     2097          ENDIF
     2098          values_realwp_2d_pointer => values_realwp_2d_resorted
     2099       ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
     2100          IF ( do_output ) THEN
     2101             ALLOCATE( values_realwp_3d_resorted(0:value_counts(1)-1, &
     2102                                                 0:value_counts(2)-1, &
     2103                                                 0:value_counts(3)-1) )
     2104             !$OMP PARALLEL PRIVATE (i,j,k)
     2105             !$OMP DO
     2106             DO  i = 0, value_counts(1) - 1
     2107                DO  j = 0, value_counts(2) - 1
     2108                   DO  k = 0, value_counts(3) - 1
     2109                      values_realwp_3d_resorted(i,j,k) = values_realwp_3d(masked_indices(3,k), &
     2110                                                                          masked_indices(2,j), &
     2111                                                                          masked_indices(1,i)  )
     2112                   ENDDO
     2113                ENDDO
     2114             ENDDO
     2115             !$OMP END PARALLEL
     2116          ELSE
     2117             ALLOCATE( values_realwp_3d_resorted(1,1,1) )
     2118             values_realwp_3d_resorted = 0_1
     2119          ENDIF
     2120          values_realwp_3d_pointer => values_realwp_3d_resorted
     2121
     2122       ELSE
     2123          return_value = 1
     2124          CALL internal_message( 'error', routine_name //                  &
     2125                                 ': no output values given ' //            &
     2126                                 '(variable "' // TRIM( variable_name ) // &
     2127                                 '", file "' // TRIM( file_name ) // '")!'  )
     2128       ENDIF
     2129
     2130       DEALLOCATE( masked_indices )
     2131
     2132    ENDIF  ! Check for error
     2133
     2134    IF ( return_value == 0 )  THEN
     2135!
     2136!--    Write variable into file
     2137       SELECT CASE ( TRIM( file_format ) )
     2138
     2139          CASE ( 'binary' )
     2140!
     2141!--          8bit integer output
     2142             IF ( PRESENT( values_int8_0d ) )  THEN
     2143                CALL binary_write_variable( file_id, variable_id,                      &
     2144                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2145                        values_int8_0d=values_int8_0d_pointer, return_value=output_return_value )
     2146             ELSEIF ( PRESENT( values_int8_1d ) )  THEN
     2147                CALL binary_write_variable( file_id, variable_id,                      &
     2148                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2149                        values_int8_1d=values_int8_1d_pointer, return_value=output_return_value )
     2150             ELSEIF ( PRESENT( values_int8_2d ) )  THEN
     2151                CALL binary_write_variable( file_id, variable_id,                      &
     2152                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2153                        values_int8_2d=values_int8_2d_pointer, return_value=output_return_value )
     2154             ELSEIF ( PRESENT( values_int8_3d ) )  THEN
     2155                CALL binary_write_variable( file_id, variable_id,                      &
     2156                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2157                        values_int8_3d=values_int8_3d_pointer, return_value=output_return_value )
     2158!
     2159!--          16bit integer output
     2160             ELSEIF ( PRESENT( values_int16_0d ) )  THEN
     2161                CALL binary_write_variable( file_id, variable_id,                      &
     2162                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2163                        values_int16_0d=values_int16_0d_pointer, return_value=output_return_value )
     2164             ELSEIF ( PRESENT( values_int16_1d ) )  THEN
     2165                CALL binary_write_variable( file_id, variable_id,                      &
     2166                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2167                        values_int16_1d=values_int16_1d_pointer, return_value=output_return_value )
     2168             ELSEIF ( PRESENT( values_int16_2d ) )  THEN
     2169                CALL binary_write_variable( file_id, variable_id,                      &
     2170                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2171                        values_int16_2d=values_int16_2d_pointer, return_value=output_return_value )
     2172             ELSEIF ( PRESENT( values_int16_3d ) )  THEN
     2173                CALL binary_write_variable( file_id, variable_id,                      &
     2174                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2175                        values_int16_3d=values_int16_3d_pointer, return_value=output_return_value )
     2176!
     2177!--          32bit integer output
     2178             ELSEIF ( PRESENT( values_int32_0d ) )  THEN
     2179                CALL binary_write_variable( file_id, variable_id,                      &
     2180                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2181                        values_int32_0d=values_int32_0d_pointer, return_value=output_return_value )
     2182             ELSEIF ( PRESENT( values_int32_1d ) )  THEN
     2183                CALL binary_write_variable( file_id, variable_id,                      &
     2184                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2185                        values_int32_1d=values_int32_1d_pointer, return_value=output_return_value )
     2186             ELSEIF ( PRESENT( values_int32_2d ) )  THEN
     2187                CALL binary_write_variable( file_id, variable_id,                      &
     2188                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2189                        values_int32_2d=values_int32_2d_pointer, return_value=output_return_value )
     2190             ELSEIF ( PRESENT( values_int32_3d ) )  THEN
     2191                CALL binary_write_variable( file_id, variable_id,                      &
     2192                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2193                        values_int32_3d=values_int32_3d_pointer, return_value=output_return_value )
     2194!
     2195!--          working-precision integer output
     2196             ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
     2197                CALL binary_write_variable( file_id, variable_id,                      &
     2198                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2199                        values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value )
     2200             ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
     2201                CALL binary_write_variable( file_id, variable_id,                      &
     2202                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2203                        values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value )
     2204             ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
     2205                CALL binary_write_variable( file_id, variable_id,                      &
     2206                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2207                        values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value )
     2208             ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
     2209                CALL binary_write_variable( file_id, variable_id,                      &
     2210                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2211                        values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value )
     2212!
     2213!--          32bit real output
     2214             ELSEIF ( PRESENT( values_real32_0d ) )  THEN
     2215                CALL binary_write_variable( file_id, variable_id,                      &
     2216                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2217                        values_real32_0d=values_real32_0d_pointer, return_value=output_return_value )
     2218             ELSEIF ( PRESENT( values_real32_1d ) )  THEN
     2219                CALL binary_write_variable( file_id, variable_id,                      &
     2220                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2221                        values_real32_1d=values_real32_1d_pointer, return_value=output_return_value )
     2222             ELSEIF ( PRESENT( values_real32_2d ) )  THEN
     2223                CALL binary_write_variable( file_id, variable_id,                      &
     2224                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2225                        values_real32_2d=values_real32_2d_pointer, return_value=output_return_value )
     2226             ELSEIF ( PRESENT( values_real32_3d ) )  THEN
     2227                CALL binary_write_variable( file_id, variable_id,                      &
     2228                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2229                        values_real32_3d=values_real32_3d_pointer, return_value=output_return_value )
     2230!
     2231!--          64bit real output
     2232             ELSEIF ( PRESENT( values_real64_0d ) )  THEN
     2233                CALL binary_write_variable( file_id, variable_id,                      &
     2234                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2235                        values_real64_0d=values_real64_0d_pointer, return_value=output_return_value )
     2236             ELSEIF ( PRESENT( values_real64_1d ) )  THEN
     2237                CALL binary_write_variable( file_id, variable_id,                      &
     2238                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2239                        values_real64_1d=values_real64_1d_pointer, return_value=output_return_value )
     2240             ELSEIF ( PRESENT( values_real64_2d ) )  THEN
     2241                CALL binary_write_variable( file_id, variable_id,                      &
     2242                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2243                        values_real64_2d=values_real64_2d_pointer, return_value=output_return_value )
     2244             ELSEIF ( PRESENT( values_real64_3d ) )  THEN
     2245                CALL binary_write_variable( file_id, variable_id,                      &
     2246                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2247                        values_real64_3d=values_real64_3d_pointer, return_value=output_return_value )
     2248!
     2249!--          working-precision real output
     2250             ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
     2251                CALL binary_write_variable( file_id, variable_id,                      &
     2252                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2253                        values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value )
     2254             ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
     2255                CALL binary_write_variable( file_id, variable_id,                      &
     2256                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2257                        values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value )
     2258             ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
     2259                CALL binary_write_variable( file_id, variable_id,                      &
     2260                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2261                        values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value )
     2262             ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
     2263                CALL binary_write_variable( file_id, variable_id,                      &
     2264                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2265                        values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value )
     2266             ELSE
     2267                return_value = 1
     2268                CALL internal_message( 'error', routine_name //                          &
     2269                                       ': output_type not supported by file format "' // &
     2270                                       TRIM( file_format ) // '" ' //                    &
     2271                                       '(variable "' // TRIM( variable_name ) //         &
     2272                                       '", file "' // TRIM( file_name ) // '")!' )
     2273             ENDIF
     2274
     2275          CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
     2276!
     2277!--          8bit integer output
     2278             IF ( PRESENT( values_int8_0d ) )  THEN
     2279                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2280                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2281                        values_int8_0d=values_int8_0d_pointer, return_value=output_return_value )
     2282             ELSEIF ( PRESENT( values_int8_1d ) )  THEN
     2283                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2284                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2285                        values_int8_1d=values_int8_1d_pointer, return_value=output_return_value )
     2286             ELSEIF ( PRESENT( values_int8_2d ) )  THEN
     2287                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2288                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2289                        values_int8_2d=values_int8_2d_pointer, return_value=output_return_value )
     2290             ELSEIF ( PRESENT( values_int8_3d ) )  THEN
     2291                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2292                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2293                        values_int8_3d=values_int8_3d_pointer, return_value=output_return_value )
     2294!
     2295!--          16bit integer output
     2296             ELSEIF ( PRESENT( values_int16_0d ) )  THEN
     2297                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2298                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2299                        values_int16_0d=values_int16_0d_pointer, return_value=output_return_value )
     2300             ELSEIF ( PRESENT( values_int16_1d ) )  THEN
     2301                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2302                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2303                        values_int16_1d=values_int16_1d_pointer, return_value=output_return_value )
     2304             ELSEIF ( PRESENT( values_int16_2d ) )  THEN
     2305                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2306                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2307                        values_int16_2d=values_int16_2d_pointer, return_value=output_return_value )
     2308             ELSEIF ( PRESENT( values_int16_3d ) )  THEN
     2309                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2310                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2311                        values_int16_3d=values_int16_3d_pointer, return_value=output_return_value )
     2312!
     2313!--          32bit integer output
     2314             ELSEIF ( PRESENT( values_int32_0d ) )  THEN
     2315                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2316                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2317                        values_int32_0d=values_int32_0d_pointer, return_value=output_return_value )
     2318             ELSEIF ( PRESENT( values_int32_1d ) )  THEN
     2319                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2320                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2321                        values_int32_1d=values_int32_1d_pointer, return_value=output_return_value )
     2322             ELSEIF ( PRESENT( values_int32_2d ) )  THEN
     2323                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2324                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2325                        values_int32_2d=values_int32_2d_pointer, return_value=output_return_value )
     2326             ELSEIF ( PRESENT( values_int32_3d ) )  THEN
     2327                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2328                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2329                        values_int32_3d=values_int32_3d_pointer, return_value=output_return_value )
     2330!
     2331!--          working-precision integer output
     2332             ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
     2333                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2334                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2335                        values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value )
     2336             ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
     2337                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2338                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2339                        values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value )
     2340             ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
     2341                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2342                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2343                        values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value )
     2344             ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
     2345                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2346                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2347                        values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value )
     2348!
     2349!--          32bit real output
     2350             ELSEIF ( PRESENT( values_real32_0d ) )  THEN
     2351                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2352                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2353                        values_real32_0d=values_real32_0d_pointer, return_value=output_return_value )
     2354             ELSEIF ( PRESENT( values_real32_1d ) )  THEN
     2355                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2356                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2357                        values_real32_1d=values_real32_1d_pointer, return_value=output_return_value )
     2358             ELSEIF ( PRESENT( values_real32_2d ) )  THEN
     2359                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2360                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2361                        values_real32_2d=values_real32_2d_pointer, return_value=output_return_value )
     2362             ELSEIF ( PRESENT( values_real32_3d ) )  THEN
     2363                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2364                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2365                        values_real32_3d=values_real32_3d_pointer, return_value=output_return_value )
     2366!
     2367!--          64bit real output
     2368             ELSEIF ( PRESENT( values_real64_0d ) )  THEN
     2369                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2370                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2371                        values_real64_0d=values_real64_0d_pointer, return_value=output_return_value )
     2372             ELSEIF ( PRESENT( values_real64_1d ) )  THEN
     2373                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2374                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2375                        values_real64_1d=values_real64_1d_pointer, return_value=output_return_value )
     2376             ELSEIF ( PRESENT( values_real64_2d ) )  THEN
     2377                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2378                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2379                        values_real64_2d=values_real64_2d_pointer, return_value=output_return_value )
     2380             ELSEIF ( PRESENT( values_real64_3d ) )  THEN
     2381                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2382                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2383                        values_real64_3d=values_real64_3d_pointer, return_value=output_return_value )
     2384!
     2385!--          working-precision real output
     2386             ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
     2387                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2388                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2389                        values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value )
     2390             ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
     2391                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2392                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2393                        values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value )
     2394             ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
     2395                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2396                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2397                        values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value )
     2398             ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
     2399                CALL netcdf4_write_variable( file_id, variable_id,                     &
     2400                        bounds_start_internal, value_counts, bounds_origin, is_global, &
     2401                        values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value )
     2402             ELSE
     2403                return_value = 1
     2404                CALL internal_message( 'error', routine_name //                          &
     2405                                       ': output_type not supported by file format "' // &
     2406                                       TRIM( file_format ) // '" ' //                    &
     2407                                       '(variable "' // TRIM( variable_name ) //         &
     2408                                       '", file "' // TRIM( file_name ) // '")!' )
     2409             ENDIF
     2410
     2411          CASE DEFAULT
     2412             return_value = 1
     2413             CALL internal_message( 'error', routine_name //                    &
     2414                                    ': file format "' // TRIM( file_format ) // &
     2415                                    '" not supported ' //                       &
     2416                                    '(variable "' // TRIM( variable_name ) //   &
     2417                                    '", file "' // TRIM( file_name ) // '")!' )
     2418
     2419       END SELECT
     2420
     2421       IF ( return_value == 0  .AND.  output_return_value /= 0 )  THEN
     2422          return_value = 1
     2423          CALL internal_message( 'error', routine_name //                  &
     2424                                 ': error while writing variable ' //      &
     2425                                 '(variable "' // TRIM( variable_name ) // &
     2426                                 '", file "' // TRIM( file_name ) // '")!' )
     2427       ENDIF
     2428
     2429    ENDIF
     2430
     2431 END FUNCTION dom_write_var
    24122432
    24132433!--------------------------------------------------------------------------------------------------!
     
    24202440!> @bug if multiple files failed to be closed, only the last failure is given in the error message.
    24212441!--------------------------------------------------------------------------------------------------!
    2422 FUNCTION dom_finalize_output() RESULT( return_value )
    2423 
    2424    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_finalize_output'  !< name of routine
    2425 
    2426    INTEGER ::  f                      !< loop index
    2427    INTEGER ::  output_return_value    !< return value from called routines
    2428    INTEGER ::  return_value           !< return value
    2429    INTEGER ::  return_value_internal  !< error code after closing a single file
    2430 
    2431 
    2432    return_value = 0
    2433 
    2434    DO  f = 1, nfiles
    2435 
    2436       IF ( files(f)%is_init )  THEN
    2437 
    2438          output_return_value = 0
    2439          return_value_internal = 0
    2440 
    2441          SELECT CASE ( TRIM( files(f)%format ) )
    2442 
    2443             CASE ( 'binary' )
    2444                CALL binary_finalize( files(f)%id, output_return_value )
    2445 
    2446             CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
    2447                CALL netcdf4_finalize( files(f)%id, output_return_value )
    2448 
    2449             CASE DEFAULT
    2450                return_value_internal = 1
    2451 
    2452          END SELECT
    2453 
    2454          IF ( output_return_value /= 0 )  THEN
    2455             return_value = output_return_value
    2456             CALL internal_message( 'error', routine_name //             &
    2457                                    ': error while finalizing file "' // &
    2458                                    TRIM( files(f)%name ) // '"' )
    2459          ELSEIF ( return_value_internal /= 0 )  THEN
    2460             return_value = return_value_internal
    2461             CALL internal_message( 'error', routine_name //                     &
    2462                                    ': unsupported file format "' //             &
    2463                                    TRIM( files(f)%format ) // '" for file "' // &
    2464                                    TRIM( files(f)%name ) // '"' )
    2465          ENDIF
    2466 
    2467       ENDIF
    2468 
    2469    ENDDO
    2470 
    2471 END FUNCTION dom_finalize_output
     2442 FUNCTION dom_finalize_output() RESULT( return_value )
     2443
     2444    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_finalize_output'  !< name of routine
     2445
     2446    INTEGER ::  f                      !< loop index
     2447    INTEGER ::  output_return_value    !< return value from called routines
     2448    INTEGER ::  return_value           !< return value
     2449    INTEGER ::  return_value_internal  !< error code after closing a single file
     2450
     2451
     2452    return_value = 0
     2453
     2454    DO  f = 1, nfiles
     2455
     2456       IF ( files(f)%is_init )  THEN
     2457
     2458          output_return_value = 0
     2459          return_value_internal = 0
     2460
     2461          SELECT CASE ( TRIM( files(f)%format ) )
     2462
     2463             CASE ( 'binary' )
     2464                CALL binary_finalize( files(f)%id, output_return_value )
     2465
     2466             CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
     2467                CALL netcdf4_finalize( files(f)%id, output_return_value )
     2468
     2469             CASE DEFAULT
     2470                return_value_internal = 1
     2471
     2472          END SELECT
     2473
     2474          IF ( output_return_value /= 0 )  THEN
     2475             return_value = output_return_value
     2476             CALL internal_message( 'error', routine_name //             &
     2477                                    ': error while finalizing file "' // &
     2478                                    TRIM( files(f)%name ) // '"' )
     2479          ELSEIF ( return_value_internal /= 0 )  THEN
     2480             return_value = return_value_internal
     2481             CALL internal_message( 'error', routine_name //                     &
     2482                                    ': unsupported file format "' //             &
     2483                                    TRIM( files(f)%format ) // '" for file "' // &
     2484                                    TRIM( files(f)%name ) // '"' )
     2485          ENDIF
     2486
     2487       ENDIF
     2488
     2489    ENDDO
     2490
     2491 END FUNCTION dom_finalize_output
    24722492
    24732493!--------------------------------------------------------------------------------------------------!
     
    24762496!> Return the last created error message.
    24772497!--------------------------------------------------------------------------------------------------!
    2478 FUNCTION dom_get_error_message() RESULT( error_message )
    2479 
    2480    CHARACTER(LEN=800) ::  error_message  !< return error message to main program
    2481 
    2482 
    2483    error_message = TRIM( internal_error_message )
    2484 
    2485    error_message = TRIM( error_message ) // TRIM( binary_get_error_message() )
    2486    
    2487    error_message = TRIM( error_message ) // TRIM( netcdf4_get_error_message() )
    2488    
    2489    internal_error_message = ''
    2490 
    2491 END FUNCTION dom_get_error_message
     2498 FUNCTION dom_get_error_message() RESULT( error_message )
     2499
     2500    CHARACTER(LEN=800) ::  error_message  !< return error message to main program
     2501
     2502
     2503    error_message = TRIM( internal_error_message )
     2504
     2505    error_message = TRIM( error_message ) // TRIM( binary_get_error_message() )
     2506
     2507    error_message = TRIM( error_message ) // TRIM( netcdf4_get_error_message() )
     2508
     2509    internal_error_message = ''
     2510
     2511 END FUNCTION dom_get_error_message
    24922512
    24932513!--------------------------------------------------------------------------------------------------!
     
    24982518!> @todo Try to combine similar code parts and shorten routine.
    24992519!--------------------------------------------------------------------------------------------------!
    2500 FUNCTION save_attribute_in_database( file_name, variable_name, attribute, append ) &
    2501             RESULT( return_value )
    2502 
    2503    CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< name of file
    2504    CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
    2505 
    2506    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'save_attribute_in_database'  !< name of routine
    2507 
    2508    INTEGER ::  a             !< loop index
    2509    INTEGER ::  d             !< loop index
    2510    INTEGER ::  f             !< loop index
    2511    INTEGER ::  natts         !< number of attributes
    2512    INTEGER ::  return_value  !< return value
    2513 
    2514    LOGICAL             ::  found   !< true if variable or dimension of name 'variable_name' found
    2515    LOGICAL, INTENT(IN) ::  append  !< if true, append value to existing value
    2516 
    2517    TYPE(attribute_type), INTENT(IN) ::  attribute  !< new attribute
    2518 
    2519    TYPE(attribute_type), DIMENSION(:), ALLOCATABLE ::  atts_tmp  !< temporary attribute list
    2520 
    2521 
    2522    return_value = 0
    2523    found = .FALSE.
    2524 
    2525    CALL internal_message( 'debug', routine_name //                            &
    2526                           ': define attribute "' // TRIM( attribute%name ) // &
    2527                           '" of variable "' // TRIM( variable_name ) //       &
    2528                           '" in file "' // TRIM( file_name ) // '"' )
    2529 
    2530    DO  f = 1, nfiles
    2531 
    2532       IF ( TRIM( file_name ) == files(f)%name )  THEN
    2533 
    2534          IF ( files(f)%is_init )  THEN
    2535             return_value = 1
    2536             CALL internal_message( 'error', routine_name // ': file "' // TRIM( file_name ) // &
    2537                     '" is already initialized. No further attribute definition allowed!' )
    2538             EXIT
    2539          ENDIF
    2540 
    2541          !-- Add attribute to file
    2542          IF ( TRIM( variable_name ) == '' )  THEN
    2543 
    2544             !-- Initialize first file attribute
    2545             IF ( .NOT. ALLOCATED( files(f)%attributes ) )  THEN
    2546                natts = 1
    2547                ALLOCATE( files(f)%attributes(natts) )
    2548             ELSE
    2549                natts = SIZE( files(f)%attributes )
    2550 
    2551                !-- Check if attribute already exists
    2552                DO  a = 1, natts
    2553                   IF ( files(f)%attributes(a)%name == attribute%name )  THEN
    2554                      IF ( append )  THEN
    2555                         !-- Append existing string attribute
    2556                         files(f)%attributes(a)%value_char =             &
    2557                            TRIM( files(f)%attributes(a)%value_char ) // &
    2558                            TRIM( attribute%value_char )
    2559                      ELSE
    2560                         files(f)%attributes(a) = attribute
    2561                      ENDIF
    2562                      found = .TRUE.
    2563                      EXIT
    2564                   ENDIF
    2565                ENDDO
    2566 
    2567                !-- Extend attribute list by 1
    2568                IF ( .NOT. found )  THEN
    2569                   ALLOCATE( atts_tmp(natts) )
    2570                   atts_tmp = files(f)%attributes
    2571                   DEALLOCATE( files(f)%attributes )
    2572                   natts = natts + 1
    2573                   ALLOCATE( files(f)%attributes(natts) )
    2574                   files(f)%attributes(:natts-1) = atts_tmp
    2575                   DEALLOCATE( atts_tmp )
    2576                ENDIF
    2577             ENDIF
    2578 
    2579             !-- Save new attribute to the end of the attribute list
    2580             IF ( .NOT. found )  THEN
    2581                files(f)%attributes(natts) = attribute
    2582                found = .TRUE.
    2583             ENDIF
    2584 
    2585             EXIT
    2586 
    2587          ELSE
    2588 
    2589             !-- Add attribute to dimension
    2590             IF ( ALLOCATED( files(f)%dimensions ) )  THEN
    2591 
    2592                DO  d = 1, SIZE( files(f)%dimensions )
    2593 
    2594                   IF ( files(f)%dimensions(d)%name == TRIM( variable_name ) )  THEN
    2595 
    2596                      IF ( .NOT. ALLOCATED( files(f)%dimensions(d)%attributes ) )  THEN
    2597                         !-- Initialize first attribute
    2598                         natts = 1
    2599                         ALLOCATE( files(f)%dimensions(d)%attributes(natts) )
    2600                      ELSE
    2601                         natts = SIZE( files(f)%dimensions(d)%attributes )
    2602 
    2603                         !-- Check if attribute already exists
    2604                         DO  a = 1, natts
    2605                            IF ( files(f)%dimensions(d)%attributes(a)%name == attribute%name ) &
    2606                            THEN
    2607                               IF ( append )  THEN
    2608                                  !-- Append existing character attribute
    2609                                  files(f)%dimensions(d)%attributes(a)%value_char =             &
    2610                                     TRIM( files(f)%dimensions(d)%attributes(a)%value_char ) // &
    2611                                     TRIM( attribute%value_char )
    2612                               ELSE
    2613                                  !-- Update existing attribute
    2614                                  files(f)%dimensions(d)%attributes(a) = attribute
    2615                               ENDIF
    2616                               found = .TRUE.
    2617                               EXIT
    2618                            ENDIF
    2619                         ENDDO
    2620 
    2621                         !-- Extend attribute list
    2622                         IF ( .NOT. found )  THEN
    2623                            ALLOCATE( atts_tmp(natts) )
    2624                            atts_tmp = files(f)%dimensions(d)%attributes
    2625                            DEALLOCATE( files(f)%dimensions(d)%attributes )
    2626                            natts = natts + 1
    2627                            ALLOCATE( files(f)%dimensions(d)%attributes(natts) )
    2628                            files(f)%dimensions(d)%attributes(:natts-1) = atts_tmp
    2629                            DEALLOCATE( atts_tmp )
    2630                         ENDIF
    2631                      ENDIF
    2632 
    2633                      !-- Add new attribute to database
    2634                      IF ( .NOT. found )  THEN
    2635                         files(f)%dimensions(d)%attributes(natts) = attribute
    2636                         found = .TRUE.
    2637                      ENDIF
    2638 
    2639                      EXIT
    2640 
    2641                   ENDIF  ! dimension found
    2642 
    2643                ENDDO  ! loop over dimensions
    2644 
    2645             ENDIF  ! dimensions exist in file
    2646 
    2647             !-- Add attribute to variable
    2648             IF ( .NOT. found  .AND.  ALLOCATED( files(f)%variables) )  THEN
    2649 
    2650                DO  d = 1, SIZE( files(f)%variables )
    2651 
    2652                   IF ( files(f)%variables(d)%name == TRIM( variable_name ) )  THEN
    2653 
    2654                      IF ( .NOT. ALLOCATED( files(f)%variables(d)%attributes ) )  THEN
    2655                         !-- Initialize first attribute
    2656                         natts = 1
    2657                         ALLOCATE( files(f)%variables(d)%attributes(natts) )
    2658                      ELSE
    2659                         natts = SIZE( files(f)%variables(d)%attributes )
    2660 
    2661                         !-- Check if attribute already exists
    2662                         DO  a = 1, natts
    2663                            IF ( files(f)%variables(d)%attributes(a)%name == attribute%name )  &
    2664                            THEN
    2665                               IF ( append )  THEN
    2666                                  !-- Append existing character attribute
    2667                                  files(f)%variables(d)%attributes(a)%value_char =             &
    2668                                     TRIM( files(f)%variables(d)%attributes(a)%value_char ) // &
    2669                                     TRIM( attribute%value_char )
    2670                               ELSE
    2671                                  !-- Update existing attribute
    2672                                  files(f)%variables(d)%attributes(a) = attribute
    2673                               ENDIF
    2674                               found = .TRUE.
    2675                               EXIT
    2676                            ENDIF
    2677                         ENDDO
    2678 
    2679                         !-- Extend attribute list
    2680                         IF ( .NOT. found )  THEN
    2681                            ALLOCATE( atts_tmp(natts) )
    2682                            atts_tmp = files(f)%variables(d)%attributes
    2683                            DEALLOCATE( files(f)%variables(d)%attributes )
    2684                            natts = natts + 1
    2685                            ALLOCATE( files(f)%variables(d)%attributes(natts) )
    2686                            files(f)%variables(d)%attributes(:natts-1) = atts_tmp
    2687                            DEALLOCATE( atts_tmp )
    2688                         ENDIF
    2689 
    2690                      ENDIF
    2691 
    2692                      !-- Add new attribute to database
    2693                      IF ( .NOT. found )  THEN
    2694                         files(f)%variables(d)%attributes(natts) = attribute
    2695                         found = .TRUE.
    2696                      ENDIF
    2697 
    2698                      EXIT
    2699 
    2700                   ENDIF  ! variable found
    2701 
    2702                ENDDO  ! loop over variables
    2703 
    2704             ENDIF  ! variables exist in file
    2705 
    2706             IF ( .NOT. found )  THEN
    2707                return_value = 1
    2708                CALL internal_message( 'error',                                        &
    2709                        routine_name //                                                &
    2710                        ': requested dimension/variable "' // TRIM( variable_name ) // &
    2711                        '" for attribute "' // TRIM( attribute%name ) //               &
    2712                        '" does not exist in file "' // TRIM( file_name ) // '"' )
    2713             ENDIF
    2714 
    2715             EXIT
    2716 
    2717          ENDIF  ! variable_name not empty
    2718 
    2719       ENDIF  ! check file_name
    2720 
    2721    ENDDO  ! loop over files
    2722 
    2723    IF ( .NOT. found  .AND.  return_value == 0 )  THEN
    2724       return_value = 1
    2725       CALL internal_message( 'error',                                         &
    2726                              routine_name //                                  &
    2727                              ': requested file "' // TRIM( file_name ) //     &
    2728                              '" for attribute "' // TRIM( attribute%name ) // &
    2729                              '" does not exist' )
    2730    ENDIF
    2731 
    2732 END FUNCTION save_attribute_in_database
     2520 FUNCTION save_attribute_in_database( file_name, variable_name, attribute, append ) &
     2521             RESULT( return_value )
     2522
     2523    CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< name of file
     2524    CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
     2525
     2526    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'save_attribute_in_database'  !< name of routine
     2527
     2528    INTEGER ::  a             !< loop index
     2529    INTEGER ::  d             !< loop index
     2530    INTEGER ::  f             !< loop index
     2531    INTEGER ::  natts         !< number of attributes
     2532    INTEGER ::  return_value  !< return value
     2533
     2534    LOGICAL             ::  found   !< true if variable or dimension of name 'variable_name' found
     2535    LOGICAL, INTENT(IN) ::  append  !< if true, append value to existing value
     2536
     2537    TYPE(attribute_type), INTENT(IN) ::  attribute  !< new attribute
     2538
     2539    TYPE(attribute_type), DIMENSION(:), ALLOCATABLE ::  atts_tmp  !< temporary attribute list
     2540
     2541
     2542    return_value = 0
     2543    found = .FALSE.
     2544
     2545    CALL internal_message( 'debug', routine_name //                            &
     2546                           ': define attribute "' // TRIM( attribute%name ) // &
     2547                           '" of variable "' // TRIM( variable_name ) //       &
     2548                           '" in file "' // TRIM( file_name ) // '"' )
     2549
     2550    DO  f = 1, nfiles
     2551
     2552       IF ( TRIM( file_name ) == files(f)%name )  THEN
     2553
     2554          IF ( files(f)%is_init )  THEN
     2555             return_value = 1
     2556             CALL internal_message( 'error', routine_name // ': file "' // TRIM( file_name ) // &
     2557                     '" is already initialized. No further attribute definition allowed!' )
     2558             EXIT
     2559          ENDIF
     2560!
     2561!--       Add attribute to file
     2562          IF ( TRIM( variable_name ) == '' )  THEN
     2563!
     2564!--          Initialize first file attribute
     2565             IF ( .NOT. ALLOCATED( files(f)%attributes ) )  THEN
     2566                natts = 1
     2567                ALLOCATE( files(f)%attributes(natts) )
     2568             ELSE
     2569                natts = SIZE( files(f)%attributes )
     2570!
     2571!--             Check if attribute already exists
     2572                DO  a = 1, natts
     2573                   IF ( files(f)%attributes(a)%name == attribute%name )  THEN
     2574                      IF ( append )  THEN
     2575!
     2576!--                      Append existing string attribute
     2577                         files(f)%attributes(a)%value_char =             &
     2578                            TRIM( files(f)%attributes(a)%value_char ) // &
     2579                            TRIM( attribute%value_char )
     2580                      ELSE
     2581                         files(f)%attributes(a) = attribute
     2582                      ENDIF
     2583                      found = .TRUE.
     2584                      EXIT
     2585                   ENDIF
     2586                ENDDO
     2587!
     2588!--             Extend attribute list by 1
     2589                IF ( .NOT. found )  THEN
     2590                   ALLOCATE( atts_tmp(natts) )
     2591                   atts_tmp = files(f)%attributes
     2592                   DEALLOCATE( files(f)%attributes )
     2593                   natts = natts + 1
     2594                   ALLOCATE( files(f)%attributes(natts) )
     2595                   files(f)%attributes(:natts-1) = atts_tmp
     2596                   DEALLOCATE( atts_tmp )
     2597                ENDIF
     2598             ENDIF
     2599!
     2600!--          Save new attribute to the end of the attribute list
     2601             IF ( .NOT. found )  THEN
     2602                files(f)%attributes(natts) = attribute
     2603                found = .TRUE.
     2604             ENDIF
     2605
     2606             EXIT
     2607
     2608          ELSE
     2609!
     2610!--          Add attribute to dimension
     2611             IF ( ALLOCATED( files(f)%dimensions ) )  THEN
     2612
     2613                DO  d = 1, SIZE( files(f)%dimensions )
     2614
     2615                   IF ( files(f)%dimensions(d)%name == TRIM( variable_name ) )  THEN
     2616
     2617                      IF ( .NOT. ALLOCATED( files(f)%dimensions(d)%attributes ) )  THEN
     2618!
     2619!--                      Initialize first attribute
     2620                         natts = 1
     2621                         ALLOCATE( files(f)%dimensions(d)%attributes(natts) )
     2622                      ELSE
     2623                         natts = SIZE( files(f)%dimensions(d)%attributes )
     2624!
     2625!--                      Check if attribute already exists
     2626                         DO  a = 1, natts
     2627                            IF ( files(f)%dimensions(d)%attributes(a)%name == attribute%name ) &
     2628                            THEN
     2629                               IF ( append )  THEN
     2630!
     2631!--                               Append existing character attribute
     2632                                  files(f)%dimensions(d)%attributes(a)%value_char =             &
     2633                                     TRIM( files(f)%dimensions(d)%attributes(a)%value_char ) // &
     2634                                     TRIM( attribute%value_char )
     2635                               ELSE
     2636!
     2637!--                               Update existing attribute
     2638                                  files(f)%dimensions(d)%attributes(a) = attribute
     2639                               ENDIF
     2640                               found = .TRUE.
     2641                               EXIT
     2642                            ENDIF
     2643                         ENDDO
     2644!
     2645!--                      Extend attribute list
     2646                         IF ( .NOT. found )  THEN
     2647                            ALLOCATE( atts_tmp(natts) )
     2648                            atts_tmp = files(f)%dimensions(d)%attributes
     2649                            DEALLOCATE( files(f)%dimensions(d)%attributes )
     2650                            natts = natts + 1
     2651                            ALLOCATE( files(f)%dimensions(d)%attributes(natts) )
     2652                            files(f)%dimensions(d)%attributes(:natts-1) = atts_tmp
     2653                            DEALLOCATE( atts_tmp )
     2654                         ENDIF
     2655                      ENDIF
     2656!
     2657!--                   Add new attribute to database
     2658                      IF ( .NOT. found )  THEN
     2659                         files(f)%dimensions(d)%attributes(natts) = attribute
     2660                         found = .TRUE.
     2661                      ENDIF
     2662
     2663                      EXIT
     2664
     2665                   ENDIF  ! dimension found
     2666
     2667                ENDDO  ! loop over dimensions
     2668
     2669             ENDIF  ! dimensions exist in file
     2670!
     2671!--          Add attribute to variable
     2672             IF ( .NOT. found  .AND.  ALLOCATED( files(f)%variables) )  THEN
     2673
     2674                DO  d = 1, SIZE( files(f)%variables )
     2675
     2676                   IF ( files(f)%variables(d)%name == TRIM( variable_name ) )  THEN
     2677
     2678                      IF ( .NOT. ALLOCATED( files(f)%variables(d)%attributes ) )  THEN
     2679!
     2680!--                      Initialize first attribute
     2681                         natts = 1
     2682                         ALLOCATE( files(f)%variables(d)%attributes(natts) )
     2683                      ELSE
     2684                         natts = SIZE( files(f)%variables(d)%attributes )
     2685!
     2686!--                      Check if attribute already exists
     2687                         DO  a = 1, natts
     2688                            IF ( files(f)%variables(d)%attributes(a)%name == attribute%name )  &
     2689                            THEN
     2690                               IF ( append )  THEN
     2691!
     2692!--                               Append existing character attribute
     2693                                  files(f)%variables(d)%attributes(a)%value_char =             &
     2694                                     TRIM( files(f)%variables(d)%attributes(a)%value_char ) // &
     2695                                     TRIM( attribute%value_char )
     2696                               ELSE
     2697!
     2698!--                               Update existing attribute
     2699                                  files(f)%variables(d)%attributes(a) = attribute
     2700                               ENDIF
     2701                               found = .TRUE.
     2702                               EXIT
     2703                            ENDIF
     2704                         ENDDO
     2705!
     2706!--                      Extend attribute list
     2707                         IF ( .NOT. found )  THEN
     2708                            ALLOCATE( atts_tmp(natts) )
     2709                            atts_tmp = files(f)%variables(d)%attributes
     2710                            DEALLOCATE( files(f)%variables(d)%attributes )
     2711                            natts = natts + 1
     2712                            ALLOCATE( files(f)%variables(d)%attributes(natts) )
     2713                            files(f)%variables(d)%attributes(:natts-1) = atts_tmp
     2714                            DEALLOCATE( atts_tmp )
     2715                         ENDIF
     2716
     2717                      ENDIF
     2718!
     2719!--                   Add new attribute to database
     2720                      IF ( .NOT. found )  THEN
     2721                         files(f)%variables(d)%attributes(natts) = attribute
     2722                         found = .TRUE.
     2723                      ENDIF
     2724
     2725                      EXIT
     2726
     2727                   ENDIF  ! variable found
     2728
     2729                ENDDO  ! loop over variables
     2730
     2731             ENDIF  ! variables exist in file
     2732
     2733             IF ( .NOT. found )  THEN
     2734                return_value = 1
     2735                CALL internal_message( 'error',                                        &
     2736                        routine_name //                                                &
     2737                        ': requested dimension/variable "' // TRIM( variable_name ) // &
     2738                        '" for attribute "' // TRIM( attribute%name ) //               &
     2739                        '" does not exist in file "' // TRIM( file_name ) // '"' )
     2740             ENDIF
     2741
     2742             EXIT
     2743
     2744          ENDIF  ! variable_name not empty
     2745
     2746       ENDIF  ! check file_name
     2747
     2748    ENDDO  ! loop over files
     2749
     2750    IF ( .NOT. found  .AND.  return_value == 0 )  THEN
     2751       return_value = 1
     2752       CALL internal_message( 'error',                                         &
     2753                              routine_name //                                  &
     2754                              ': requested file "' // TRIM( file_name ) //     &
     2755                              '" for attribute "' // TRIM( attribute%name ) // &
     2756                              '" does not exist' )
     2757    ENDIF
     2758
     2759 END FUNCTION save_attribute_in_database
    27332760
    27342761!--------------------------------------------------------------------------------------------------!
     
    27382765!> without variables).
    27392766!--------------------------------------------------------------------------------------------------!
    2740 FUNCTION cleanup_database() RESULT( return_value )
    2741 
    2742    ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'cleanup_database'  !< name of routine
    2743 
    2744    INTEGER ::  d             !< loop index
    2745    INTEGER ::  f             !< loop index
    2746    INTEGER ::  i             !< loop index
    2747    INTEGER ::  ndims         !< number of dimensions in a file
    2748    INTEGER ::  ndims_used    !< number of used dimensions in a file
    2749    INTEGER ::  nfiles_used   !< number of used files
    2750    INTEGER ::  nvars         !< number of variables in a file
    2751    INTEGER ::  return_value  !< return value
    2752 
    2753    LOGICAL, DIMENSION(1:nfiles)             ::  file_is_used       !< true if file contains variables
    2754    LOGICAL, DIMENSION(:),       ALLOCATABLE ::  dimension_is_used  !< true if dimension is used by any variable
    2755 
    2756    TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  used_dimensions  !< list of used dimensions
    2757 
    2758    TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  used_files  !< list of used files
    2759 
    2760 
    2761    return_value = 0
    2762 
    2763    !-- Flag files which contain output variables as used
    2764    file_is_used(:) = .FALSE.
    2765    DO  f = 1, nfiles
    2766       IF ( ALLOCATED( files(f)%variables ) )  THEN
    2767          file_is_used(f) = .TRUE.
    2768       ENDIF
    2769    ENDDO
    2770 
    2771    !-- Copy flagged files into temporary list
    2772    nfiles_used = COUNT( file_is_used )
    2773    ALLOCATE( used_files(nfiles_used) )
    2774    i = 0
    2775    DO  f = 1, nfiles
    2776       IF ( file_is_used(f) )  THEN
    2777          i = i + 1
    2778          used_files(i) = files(f)
    2779       ENDIF
    2780    ENDDO
    2781 
    2782    !-- Replace file list with list of used files
    2783    DEALLOCATE( files )
    2784    nfiles = nfiles_used
    2785    ALLOCATE( files(nfiles) )
    2786    files = used_files
    2787    DEALLOCATE( used_files )
    2788 
    2789    !-- Check every file for unused dimensions
    2790    DO  f = 1, nfiles
    2791 
    2792       !-- If a file is already initialized, it was already checked previously
    2793       IF ( files(f)%is_init )  CYCLE
    2794 
    2795       !-- Get number of defined dimensions
    2796       ndims = SIZE( files(f)%dimensions )
    2797       ALLOCATE( dimension_is_used(ndims) )
    2798 
    2799       !-- Go through all variables and flag all used dimensions
    2800       nvars = SIZE( files(f)%variables )
    2801       DO  d = 1, ndims
    2802          DO  i = 1, nvars
    2803             dimension_is_used(d) = &
    2804                ANY( files(f)%dimensions(d)%name == files(f)%variables(i)%dimension_names )
    2805             IF ( dimension_is_used(d) )  EXIT
    2806          ENDDO
    2807       ENDDO
    2808 
    2809       !-- Copy used dimensions to temporary list
    2810       ndims_used = COUNT( dimension_is_used )
    2811       ALLOCATE( used_dimensions(ndims_used) )
    2812       i = 0
    2813       DO  d = 1, ndims
    2814          IF ( dimension_is_used(d) )  THEN
    2815             i = i + 1
    2816             used_dimensions(i) = files(f)%dimensions(d)
    2817          ENDIF
    2818       ENDDO
    2819 
    2820       !-- Replace dimension list with list of used dimensions
    2821       DEALLOCATE( files(f)%dimensions )
    2822       ndims = ndims_used
    2823       ALLOCATE( files(f)%dimensions(ndims) )
    2824       files(f)%dimensions = used_dimensions
    2825       DEALLOCATE( used_dimensions )
    2826       DEALLOCATE( dimension_is_used )
    2827 
    2828    ENDDO
    2829 
    2830 END FUNCTION cleanup_database
     2767 FUNCTION cleanup_database() RESULT( return_value )
     2768
     2769    ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'cleanup_database'  !< name of routine
     2770
     2771    INTEGER ::  d             !< loop index
     2772    INTEGER ::  f             !< loop index
     2773    INTEGER ::  i             !< loop index
     2774    INTEGER ::  ndims         !< number of dimensions in a file
     2775    INTEGER ::  ndims_used    !< number of used dimensions in a file
     2776    INTEGER ::  nfiles_used   !< number of used files
     2777    INTEGER ::  nvars         !< number of variables in a file
     2778    INTEGER ::  return_value  !< return value
     2779
     2780    LOGICAL, DIMENSION(1:nfiles)             ::  file_is_used       !< true if file contains variables
     2781    LOGICAL, DIMENSION(:),       ALLOCATABLE ::  dimension_is_used  !< true if dimension is used by any variable
     2782
     2783    TYPE(dimension_type), DIMENSION(:), ALLOCATABLE ::  used_dimensions  !< list of used dimensions
     2784
     2785    TYPE(file_type), DIMENSION(:), ALLOCATABLE ::  used_files  !< list of used files
     2786
     2787
     2788    return_value = 0
     2789!
     2790!-- Flag files which contain output variables as used
     2791    file_is_used(:) = .FALSE.
     2792    DO  f = 1, nfiles
     2793       IF ( ALLOCATED( files(f)%variables ) )  THEN
     2794          file_is_used(f) = .TRUE.
     2795       ENDIF
     2796    ENDDO
     2797!
     2798!-- Copy flagged files into temporary list
     2799    nfiles_used = COUNT( file_is_used )
     2800    ALLOCATE( used_files(nfiles_used) )
     2801    i = 0
     2802    DO  f = 1, nfiles
     2803       IF ( file_is_used(f) )  THEN
     2804          i = i + 1
     2805          used_files(i) = files(f)
     2806       ENDIF
     2807    ENDDO
     2808!
     2809!-- Replace file list with list of used files
     2810    DEALLOCATE( files )
     2811    nfiles = nfiles_used
     2812    ALLOCATE( files(nfiles) )
     2813    files = used_files
     2814    DEALLOCATE( used_files )
     2815!
     2816!-- Check every file for unused dimensions
     2817    DO  f = 1, nfiles
     2818!
     2819!--    If a file is already initialized, it was already checked previously
     2820       IF ( files(f)%is_init )  CYCLE
     2821!
     2822!--    Get number of defined dimensions
     2823       ndims = SIZE( files(f)%dimensions )
     2824       ALLOCATE( dimension_is_used(ndims) )
     2825!
     2826!--    Go through all variables and flag all used dimensions
     2827       nvars = SIZE( files(f)%variables )
     2828       DO  d = 1, ndims
     2829          DO  i = 1, nvars
     2830             dimension_is_used(d) = &
     2831                ANY( files(f)%dimensions(d)%name == files(f)%variables(i)%dimension_names )
     2832             IF ( dimension_is_used(d) )  EXIT
     2833          ENDDO
     2834       ENDDO
     2835!
     2836!--    Copy used dimensions to temporary list
     2837       ndims_used = COUNT( dimension_is_used )
     2838       ALLOCATE( used_dimensions(ndims_used) )
     2839       i = 0
     2840       DO  d = 1, ndims
     2841          IF ( dimension_is_used(d) )  THEN
     2842             i = i + 1
     2843             used_dimensions(i) = files(f)%dimensions(d)
     2844          ENDIF
     2845       ENDDO
     2846!
     2847!--    Replace dimension list with list of used dimensions
     2848       DEALLOCATE( files(f)%dimensions )
     2849       ndims = ndims_used
     2850       ALLOCATE( files(f)%dimensions(ndims) )
     2851       files(f)%dimensions = used_dimensions
     2852       DEALLOCATE( used_dimensions )
     2853       DEALLOCATE( dimension_is_used )
     2854
     2855    ENDDO
     2856
     2857 END FUNCTION cleanup_database
    28312858
    28322859!--------------------------------------------------------------------------------------------------!
     
    28352862!> Open requested output file.
    28362863!--------------------------------------------------------------------------------------------------!
    2837 SUBROUTINE open_output_file( file_format, file_name, file_id, return_value )
    2838 
    2839    CHARACTER(LEN=*), INTENT(IN) ::  file_format  !< file format chosen for file
    2840    CHARACTER(LEN=*), INTENT(IN) ::  file_name    !< name of file to be checked
    2841 
    2842    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'open_output_file'  !< name of routine
    2843 
    2844    INTEGER, INTENT(OUT) ::  file_id              !< file ID
    2845    INTEGER              ::  output_return_value  !< return value of a called output routine
    2846    INTEGER, INTENT(OUT) ::  return_value         !< return value
    2847 
    2848 
    2849    return_value = 0
    2850    output_return_value = 0
    2851 
    2852    SELECT CASE ( TRIM( file_format ) )
    2853 
    2854       CASE ( 'binary' )
    2855          CALL binary_open_file( 'binary', file_name, file_id, output_return_value )
    2856 
    2857       CASE ( 'netcdf4-serial' )
    2858          CALL netcdf4_open_file( 'serial', file_name, file_id, output_return_value )
    2859 
    2860       CASE ( 'netcdf4-parallel' )
    2861          CALL netcdf4_open_file( 'parallel', file_name, file_id, output_return_value )
    2862 
    2863       CASE DEFAULT
    2864          return_value = 1
    2865 
    2866    END SELECT
    2867 
    2868    IF ( output_return_value /= 0 )  THEN
    2869       return_value = output_return_value
    2870       CALL internal_message( 'error', routine_name // &
    2871                              ': error while opening file "' // TRIM( file_name ) // '"' )
    2872    ELSEIF ( return_value /= 0 )  THEN
    2873       CALL internal_message( 'error', routine_name //                     &
    2874                              ': file "' // TRIM( file_name ) //           &
    2875                              '": file format "' // TRIM( file_format ) // &
    2876                              '" not supported' )
    2877    ENDIF
    2878 
    2879 END SUBROUTINE open_output_file
     2864 SUBROUTINE open_output_file( file_format, file_name, file_id, return_value )
     2865
     2866    CHARACTER(LEN=*), INTENT(IN) ::  file_format  !< file format chosen for file
     2867    CHARACTER(LEN=*), INTENT(IN) ::  file_name    !< name of file to be checked
     2868
     2869    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'open_output_file'  !< name of routine
     2870
     2871    INTEGER, INTENT(OUT) ::  file_id              !< file ID
     2872    INTEGER              ::  output_return_value  !< return value of a called output routine
     2873    INTEGER, INTENT(OUT) ::  return_value         !< return value
     2874
     2875
     2876    return_value = 0
     2877    output_return_value = 0
     2878
     2879    SELECT CASE ( TRIM( file_format ) )
     2880
     2881       CASE ( 'binary' )
     2882          CALL binary_open_file( 'binary', file_name, file_id, output_return_value )
     2883
     2884       CASE ( 'netcdf4-serial' )
     2885          CALL netcdf4_open_file( 'serial', file_name, file_id, output_return_value )
     2886
     2887       CASE ( 'netcdf4-parallel' )
     2888          CALL netcdf4_open_file( 'parallel', file_name, file_id, output_return_value )
     2889
     2890       CASE DEFAULT
     2891          return_value = 1
     2892
     2893    END SELECT
     2894
     2895    IF ( output_return_value /= 0 )  THEN
     2896       return_value = output_return_value
     2897       CALL internal_message( 'error', routine_name // &
     2898                              ': error while opening file "' // TRIM( file_name ) // '"' )
     2899    ELSEIF ( return_value /= 0 )  THEN
     2900       CALL internal_message( 'error', routine_name //                     &
     2901                              ': file "' // TRIM( file_name ) //           &
     2902                              '": file format "' // TRIM( file_format ) // &
     2903                              '" not supported' )
     2904    ENDIF
     2905
     2906 END SUBROUTINE open_output_file
    28802907
    28812908!--------------------------------------------------------------------------------------------------!
     
    28842911!> Initialize attributes, dimensions and variables in a file.
    28852912!--------------------------------------------------------------------------------------------------!
    2886 SUBROUTINE init_file_header( file, return_value )
    2887 
    2888    ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'init_file_header'  !< name of routine
    2889 
    2890    INTEGER              ::  a             !< loop index
    2891    INTEGER              ::  d             !< loop index
    2892    INTEGER, INTENT(OUT) ::  return_value  !< return value
    2893 
    2894    TYPE(file_type), INTENT(INOUT) ::  file  !< initialize header of this file
    2895 
    2896 
    2897    return_value  = 0
    2898 
    2899    !-- Write file attributes
    2900    IF ( ALLOCATED( file%attributes ) )  THEN
    2901       DO  a = 1, SIZE( file%attributes )
    2902          return_value = write_attribute( file%format, file%id, file%name,     &
    2903                                          variable_id=no_id, variable_name='', &
    2904                                          attribute=file%attributes(a) )
    2905          IF ( return_value /= 0 )  EXIT
    2906       ENDDO
    2907    ENDIF
    2908 
    2909    IF ( return_value == 0 )  THEN
    2910 
    2911       !-- Initialize file dimensions
    2912       DO  d = 1, SIZE( file%dimensions )
    2913 
    2914          IF ( .NOT. file%dimensions(d)%is_masked )  THEN
    2915 
    2916             !-- Initialize non-masked dimension
    2917             CALL init_file_dimension( file%format, file%id, file%name,       &
    2918                     file%dimensions(d)%id, file%dimensions(d)%name,          &
    2919                     file%dimensions(d)%data_type, file%dimensions(d)%length, &
    2920                     file%dimensions(d)%variable_id, return_value )
    2921 
    2922          ELSE
    2923 
    2924             !-- Initialize masked dimension
    2925             CALL init_file_dimension( file%format, file%id, file%name,            &
    2926                     file%dimensions(d)%id, file%dimensions(d)%name,               &
    2927                     file%dimensions(d)%data_type, file%dimensions(d)%length_mask, &
    2928                     file%dimensions(d)%variable_id, return_value )
    2929 
    2930          ENDIF
    2931 
    2932          IF ( return_value == 0  .AND.  ALLOCATED( file%dimensions(d)%attributes ) )  THEN
    2933             !-- Write dimension attributes
    2934             DO  a = 1, SIZE( file%dimensions(d)%attributes )
    2935                return_value = write_attribute( file%format, file%id, file%name, &
    2936                                  variable_id=file%dimensions(d)%variable_id,    &
    2937                                  variable_name=file%dimensions(d)%name,         &
    2938                                  attribute=file%dimensions(d)%attributes(a) )
    2939                IF ( return_value /= 0 )  EXIT
    2940             ENDDO
    2941          ENDIF
    2942 
    2943          IF ( return_value /= 0 )  EXIT
    2944 
    2945       ENDDO
    2946 
    2947       !-- Save dimension IDs for variables wihtin database
    2948       IF ( return_value == 0 )  &
    2949          CALL collect_dimesion_ids_for_variables( file%name, file%variables, file%dimensions, &
    2950                                                   return_value )
    2951 
    2952       !-- Initialize file variables
    2953       IF ( return_value == 0 )  THEN
    2954          DO  d = 1, SIZE( file%variables )
    2955 
    2956             CALL init_file_variable( file%format, file%id, file%name,                          &
    2957                     file%variables(d)%id, file%variables(d)%name, file%variables(d)%data_type, &
    2958                     file%variables(d)%dimension_ids,                                           &
    2959                     file%variables(d)%is_global, return_value )
    2960 
    2961             IF ( return_value == 0  .AND.  ALLOCATED( file%variables(d)%attributes ) )  THEN
    2962                !-- Write variable attributes
    2963                DO  a = 1, SIZE( file%variables(d)%attributes )
    2964                   return_value = write_attribute( file%format, file%id, file%name, &
    2965                                     variable_id=file%variables(d)%id,              &
    2966                                     variable_name=file%variables(d)%name,          &
    2967                                     attribute=file%variables(d)%attributes(a) )
    2968                   IF ( return_value /= 0 )  EXIT
    2969                ENDDO
    2970             ENDIF
    2971 
    2972             IF ( return_value /= 0 )  EXIT
    2973 
    2974          ENDDO
    2975       ENDIF
    2976 
    2977    ENDIF
    2978 
    2979 END SUBROUTINE init_file_header
     2913 SUBROUTINE init_file_header( file, return_value )
     2914
     2915    ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'init_file_header'  !< name of routine
     2916
     2917    INTEGER              ::  a             !< loop index
     2918    INTEGER              ::  d             !< loop index
     2919    INTEGER, INTENT(OUT) ::  return_value  !< return value
     2920
     2921    TYPE(file_type), INTENT(INOUT) ::  file  !< initialize header of this file
     2922
     2923
     2924    return_value  = 0
     2925!
     2926!-- Write file attributes
     2927    IF ( ALLOCATED( file%attributes ) )  THEN
     2928       DO  a = 1, SIZE( file%attributes )
     2929          return_value = write_attribute( file%format, file%id, file%name,     &
     2930                                          variable_id=no_id, variable_name='', &
     2931                                          attribute=file%attributes(a) )
     2932          IF ( return_value /= 0 )  EXIT
     2933       ENDDO
     2934    ENDIF
     2935
     2936    IF ( return_value == 0 )  THEN
     2937!
     2938!--    Initialize file dimensions
     2939       DO  d = 1, SIZE( file%dimensions )
     2940
     2941          IF ( .NOT. file%dimensions(d)%is_masked )  THEN
     2942!
     2943!--          Initialize non-masked dimension
     2944             CALL init_file_dimension( file%format, file%id, file%name,       &
     2945                     file%dimensions(d)%id, file%dimensions(d)%name,          &
     2946                     file%dimensions(d)%data_type, file%dimensions(d)%length, &
     2947                     file%dimensions(d)%variable_id, return_value )
     2948
     2949          ELSE
     2950!
     2951!--          Initialize masked dimension
     2952             CALL init_file_dimension( file%format, file%id, file%name,            &
     2953                     file%dimensions(d)%id, file%dimensions(d)%name,               &
     2954                     file%dimensions(d)%data_type, file%dimensions(d)%length_mask, &
     2955                     file%dimensions(d)%variable_id, return_value )
     2956
     2957          ENDIF
     2958
     2959          IF ( return_value == 0  .AND.  ALLOCATED( file%dimensions(d)%attributes ) )  THEN
     2960!
     2961!--          Write dimension attributes
     2962             DO  a = 1, SIZE( file%dimensions(d)%attributes )
     2963                return_value = write_attribute( file%format, file%id, file%name, &
     2964                                  variable_id=file%dimensions(d)%variable_id,    &
     2965                                  variable_name=file%dimensions(d)%name,         &
     2966                                  attribute=file%dimensions(d)%attributes(a) )
     2967                IF ( return_value /= 0 )  EXIT
     2968             ENDDO
     2969          ENDIF
     2970
     2971          IF ( return_value /= 0 )  EXIT
     2972
     2973       ENDDO
     2974!
     2975!--    Save dimension IDs for variables wihtin database
     2976       IF ( return_value == 0 )  &
     2977          CALL collect_dimesion_ids_for_variables( file%name, file%variables, file%dimensions, &
     2978                                                   return_value )
     2979!
     2980!--    Initialize file variables
     2981       IF ( return_value == 0 )  THEN
     2982          DO  d = 1, SIZE( file%variables )
     2983
     2984             CALL init_file_variable( file%format, file%id, file%name,                          &
     2985                     file%variables(d)%id, file%variables(d)%name, file%variables(d)%data_type, &
     2986                     file%variables(d)%dimension_ids,                                           &
     2987                     file%variables(d)%is_global, return_value )
     2988
     2989             IF ( return_value == 0  .AND.  ALLOCATED( file%variables(d)%attributes ) )  THEN
     2990!
     2991!--             Write variable attributes
     2992                DO  a = 1, SIZE( file%variables(d)%attributes )
     2993                   return_value = write_attribute( file%format, file%id, file%name, &
     2994                                     variable_id=file%variables(d)%id,              &
     2995                                     variable_name=file%variables(d)%name,          &
     2996                                     attribute=file%variables(d)%attributes(a) )
     2997                   IF ( return_value /= 0 )  EXIT
     2998                ENDDO
     2999             ENDIF
     3000
     3001             IF ( return_value /= 0 )  EXIT
     3002
     3003          ENDDO
     3004       ENDIF
     3005
     3006    ENDIF
     3007
     3008 END SUBROUTINE init_file_header
    29803009
    29813010!--------------------------------------------------------------------------------------------------!
     
    29843013!> Initialize dimension in file.
    29853014!--------------------------------------------------------------------------------------------------!
    2986 SUBROUTINE init_file_dimension( file_format, file_id, file_name,              &
    2987               dimension_id, dimension_name, dimension_type, dimension_length, &
    2988               variable_id, return_value )
    2989 
    2990    CHARACTER(LEN=*), INTENT(IN) ::  dimension_name  !< name of dimension
    2991    CHARACTER(LEN=*), INTENT(IN) ::  dimension_type  !< data type of dimension
    2992    CHARACTER(LEN=*), INTENT(IN) ::  file_format     !< file format chosen for file
    2993    CHARACTER(LEN=*), INTENT(IN) ::  file_name       !< name of file
    2994 
    2995    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'init_file_dimension'  !< file format chosen for file
    2996 
    2997    INTEGER, INTENT(OUT) ::  dimension_id         !< dimension ID
    2998    INTEGER, INTENT(IN)  ::  dimension_length     !< length of dimension
    2999    INTEGER, INTENT(IN)  ::  file_id              !< file ID
    3000    INTEGER              ::  output_return_value  !< return value of a called output routine
    3001    INTEGER, INTENT(OUT) ::  return_value         !< return value
    3002    INTEGER, INTENT(OUT) ::  variable_id          !< associated variable ID
    3003 
    3004 
    3005    return_value = 0
    3006    output_return_value = 0
    3007 
    3008    temp_string = '(file "' // TRIM( file_name ) // &
    3009                  '", dimension "' // TRIM( dimension_name ) // '")'
    3010 
    3011    SELECT CASE ( TRIM( file_format ) )
    3012 
    3013       CASE ( 'binary' )
    3014          CALL binary_init_dimension( 'binary', file_id, dimension_id, variable_id, &
    3015                  dimension_name, dimension_type, dimension_length,                 &
    3016                  return_value=output_return_value )
    3017 
    3018       CASE ( 'netcdf4-serial' )
    3019          CALL netcdf4_init_dimension( 'serial', file_id, dimension_id, variable_id, &
    3020                  dimension_name, dimension_type, dimension_length,                  &
    3021                  return_value=output_return_value )
    3022 
    3023       CASE ( 'netcdf4-parallel' )
    3024          CALL netcdf4_init_dimension( 'parallel', file_id, dimension_id, variable_id, &
    3025                  dimension_name, dimension_type, dimension_length,                    &
    3026                  return_value=output_return_value )
    3027 
    3028       CASE DEFAULT
    3029          return_value = 1
    3030          CALL internal_message( 'error', routine_name //                    &
    3031                                 ': file format "' // TRIM( file_format ) // &
    3032                                 '" not supported ' // TRIM( temp_string ) )
    3033 
    3034    END SELECT
    3035 
    3036    IF ( output_return_value /= 0 )  THEN
    3037       return_value = output_return_value
    3038       CALL internal_message( 'error', routine_name // &
    3039                              ': error while defining dimension ' // TRIM( temp_string ) )
    3040    ENDIF
    3041 
    3042 END SUBROUTINE init_file_dimension
     3015 SUBROUTINE init_file_dimension( file_format, file_id, file_name,              &
     3016               dimension_id, dimension_name, dimension_type, dimension_length, &
     3017               variable_id, return_value )
     3018
     3019    CHARACTER(LEN=*), INTENT(IN) ::  dimension_name  !< name of dimension
     3020    CHARACTER(LEN=*), INTENT(IN) ::  dimension_type  !< data type of dimension
     3021    CHARACTER(LEN=*), INTENT(IN) ::  file_format     !< file format chosen for file
     3022    CHARACTER(LEN=*), INTENT(IN) ::  file_name       !< name of file
     3023
     3024    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'init_file_dimension'  !< file format chosen for file
     3025
     3026    INTEGER, INTENT(OUT) ::  dimension_id         !< dimension ID
     3027    INTEGER, INTENT(IN)  ::  dimension_length     !< length of dimension
     3028    INTEGER, INTENT(IN)  ::  file_id              !< file ID
     3029    INTEGER              ::  output_return_value  !< return value of a called output routine
     3030    INTEGER, INTENT(OUT) ::  return_value         !< return value
     3031    INTEGER, INTENT(OUT) ::  variable_id          !< associated variable ID
     3032
     3033
     3034    return_value = 0
     3035    output_return_value = 0
     3036
     3037    temp_string = '(file "' // TRIM( file_name ) // &
     3038                  '", dimension "' // TRIM( dimension_name ) // '")'
     3039
     3040    SELECT CASE ( TRIM( file_format ) )
     3041
     3042       CASE ( 'binary' )
     3043          CALL binary_init_dimension( 'binary', file_id, dimension_id, variable_id, &
     3044                  dimension_name, dimension_type, dimension_length,                 &
     3045                  return_value=output_return_value )
     3046
     3047       CASE ( 'netcdf4-serial' )
     3048          CALL netcdf4_init_dimension( 'serial', file_id, dimension_id, variable_id, &
     3049                  dimension_name, dimension_type, dimension_length,                  &
     3050                  return_value=output_return_value )
     3051
     3052       CASE ( 'netcdf4-parallel' )
     3053          CALL netcdf4_init_dimension( 'parallel', file_id, dimension_id, variable_id, &
     3054                  dimension_name, dimension_type, dimension_length,                    &
     3055                  return_value=output_return_value )
     3056
     3057       CASE DEFAULT
     3058          return_value = 1
     3059          CALL internal_message( 'error', routine_name //                    &
     3060                                 ': file format "' // TRIM( file_format ) // &
     3061                                 '" not supported ' // TRIM( temp_string ) )
     3062
     3063    END SELECT
     3064
     3065    IF ( output_return_value /= 0 )  THEN
     3066       return_value = output_return_value
     3067       CALL internal_message( 'error', routine_name // &
     3068                              ': error while defining dimension ' // TRIM( temp_string ) )
     3069    ENDIF
     3070
     3071 END SUBROUTINE init_file_dimension
    30433072
    30443073!--------------------------------------------------------------------------------------------------!
     
    30473076!> Initialize variable.
    30483077!--------------------------------------------------------------------------------------------------!
    3049 SUBROUTINE init_file_variable( file_format, file_id, file_name,        &
    3050                                variable_id, variable_name, variable_type, dimension_ids, &
    3051                                is_global, return_value )
    3052 
    3053    CHARACTER(LEN=*), INTENT(IN) ::  file_format    !< file format chosen for file
    3054    CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< file name
    3055    CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
    3056    CHARACTER(LEN=*), INTENT(IN) ::  variable_type  !< data type of variable
    3057 
    3058    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'init_file_variable'  !< file format chosen for file
    3059 
    3060    INTEGER, INTENT(IN)  ::  file_id              !< file ID
    3061    INTEGER              ::  output_return_value  !< return value of a called output routine
    3062    INTEGER, INTENT(OUT) ::  return_value         !< return value
    3063    INTEGER, INTENT(OUT) ::  variable_id          !< variable ID
    3064 
    3065    INTEGER, DIMENSION(:), INTENT(IN) ::  dimension_ids  !< list of dimension IDs used by variable
    3066 
    3067    LOGICAL, INTENT(IN)  ::  is_global  !< true if variable is global
    3068 
    3069 
    3070    return_value = 0
    3071    output_return_value = 0
    3072 
    3073    temp_string = '(file "' // TRIM( file_name ) // &
    3074                  '", variable "' // TRIM( variable_name ) // '")'
    3075 
    3076    SELECT CASE ( TRIM( file_format ) )
    3077 
    3078       CASE ( 'binary' )
    3079          CALL binary_init_variable( 'binary', file_id, variable_id, variable_name, &
    3080                  variable_type, dimension_ids, is_global, return_value=output_return_value )
    3081 
    3082       CASE ( 'netcdf4-serial' )
    3083          CALL netcdf4_init_variable( 'serial', file_id, variable_id, variable_name, &
    3084                  variable_type, dimension_ids, is_global, return_value=output_return_value )
    3085 
    3086       CASE ( 'netcdf4-parallel' )
    3087          CALL netcdf4_init_variable( 'parallel', file_id, variable_id, variable_name, &
    3088                  variable_type, dimension_ids, is_global, return_value=output_return_value )
    3089 
    3090       CASE DEFAULT
    3091          return_value = 1
    3092          CALL internal_message( 'error', routine_name //                    &
    3093                                 ': file format "' // TRIM( file_format ) // &
    3094                                 '" not supported ' // TRIM( temp_string ) )
    3095 
    3096    END SELECT
    3097 
    3098    IF ( output_return_value /= 0 )  THEN
    3099       return_value = output_return_value
    3100       CALL internal_message( 'error', routine_name // &
    3101                              ': error while defining variable ' // TRIM( temp_string ) )
    3102    ENDIF
    3103 
    3104 END SUBROUTINE init_file_variable
     3078 SUBROUTINE init_file_variable( file_format, file_id, file_name,        &
     3079                                variable_id, variable_name, variable_type, dimension_ids, &
     3080                                is_global, return_value )
     3081
     3082    CHARACTER(LEN=*), INTENT(IN) ::  file_format    !< file format chosen for file
     3083    CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< file name
     3084    CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
     3085    CHARACTER(LEN=*), INTENT(IN) ::  variable_type  !< data type of variable
     3086
     3087    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'init_file_variable'  !< file format chosen for file
     3088
     3089    INTEGER, INTENT(IN)  ::  file_id              !< file ID
     3090    INTEGER              ::  output_return_value  !< return value of a called output routine
     3091    INTEGER, INTENT(OUT) ::  return_value         !< return value
     3092    INTEGER, INTENT(OUT) ::  variable_id          !< variable ID
     3093
     3094    INTEGER, DIMENSION(:), INTENT(IN) ::  dimension_ids  !< list of dimension IDs used by variable
     3095
     3096    LOGICAL, INTENT(IN)  ::  is_global  !< true if variable is global
     3097
     3098
     3099    return_value = 0
     3100    output_return_value = 0
     3101
     3102    temp_string = '(file "' // TRIM( file_name ) // &
     3103                  '", variable "' // TRIM( variable_name ) // '")'
     3104
     3105    SELECT CASE ( TRIM( file_format ) )
     3106
     3107       CASE ( 'binary' )
     3108          CALL binary_init_variable( 'binary', file_id, variable_id, variable_name, &
     3109                  variable_type, dimension_ids, is_global, return_value=output_return_value )
     3110
     3111       CASE ( 'netcdf4-serial' )
     3112          CALL netcdf4_init_variable( 'serial', file_id, variable_id, variable_name, &
     3113                  variable_type, dimension_ids, is_global, return_value=output_return_value )
     3114
     3115       CASE ( 'netcdf4-parallel' )
     3116          CALL netcdf4_init_variable( 'parallel', file_id, variable_id, variable_name, &
     3117                  variable_type, dimension_ids, is_global, return_value=output_return_value )
     3118
     3119       CASE DEFAULT
     3120          return_value = 1
     3121          CALL internal_message( 'error', routine_name //                    &
     3122                                 ': file format "' // TRIM( file_format ) // &
     3123                                 '" not supported ' // TRIM( temp_string ) )
     3124
     3125    END SELECT
     3126
     3127    IF ( output_return_value /= 0 )  THEN
     3128       return_value = output_return_value
     3129       CALL internal_message( 'error', routine_name // &
     3130                              ': error while defining variable ' // TRIM( temp_string ) )
     3131    ENDIF
     3132
     3133 END SUBROUTINE init_file_variable
    31053134
    31063135!--------------------------------------------------------------------------------------------------!
     
    31093138!> Write attribute to file.
    31103139!--------------------------------------------------------------------------------------------------!
    3111 FUNCTION write_attribute( file_format, file_id, file_name,        &
    3112                           variable_id, variable_name, attribute ) RESULT( return_value )
    3113 
    3114    CHARACTER(LEN=*), INTENT(IN) ::  file_format    !< file format chosen for file
    3115    CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< file name
    3116    CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< variable name
    3117 
    3118    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'write_attribute'  !< file format chosen for file
    3119 
    3120    INTEGER, INTENT(IN) ::  file_id              !< file ID
    3121    INTEGER             ::  return_value         !< return value
    3122    INTEGER             ::  output_return_value  !< return value of a called output routine
    3123    INTEGER, INTENT(IN) ::  variable_id          !< variable ID
    3124 
    3125    TYPE(attribute_type), INTENT(IN) ::  attribute  !< attribute to be written
    3126 
    3127 
    3128    return_value = 0
    3129    output_return_value = 0
    3130 
    3131    !-- Prepare for possible error message
    3132    temp_string = '(file "' // TRIM( file_name ) //           &
    3133                  '", variable "' // TRIM( variable_name ) // &
    3134                  '", attribute "' // TRIM( attribute%name ) // '")'
    3135 
    3136    !-- Write attribute to file
    3137    SELECT CASE ( TRIM( file_format ) )
    3138 
    3139       CASE ( 'binary' )
    3140 
    3141          SELECT CASE ( TRIM( attribute%data_type ) )
    3142 
    3143             CASE( 'char' )
    3144                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,  &
    3145                        attribute_name=attribute%name, value_char=attribute%value_char, &
    3146                        return_value=output_return_value )
    3147 
    3148             CASE( 'int8' )
    3149                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,  &
    3150                        attribute_name=attribute%name, value_int8=attribute%value_int8, &
    3151                        return_value=output_return_value )
    3152 
    3153             CASE( 'int16' )
    3154                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,    &
    3155                        attribute_name=attribute%name, value_int16=attribute%value_int16, &
    3156                        return_value=output_return_value )
    3157 
    3158             CASE( 'int32' )
    3159                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,    &
    3160                        attribute_name=attribute%name, value_int32=attribute%value_int32, &
    3161                        return_value=output_return_value )
    3162 
    3163             CASE( 'real32' )
    3164                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,      &
    3165                        attribute_name=attribute%name, value_real32=attribute%value_real32, &
    3166                        return_value=output_return_value )
    3167 
    3168             CASE( 'real64' )
    3169                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,      &
    3170                        attribute_name=attribute%name, value_real64=attribute%value_real64, &
    3171                        return_value=output_return_value )
    3172 
    3173             CASE DEFAULT
    3174                return_value = 1
    3175                CALL internal_message( 'error', routine_name //                     &
    3176                                       ': file format "' // TRIM( file_format ) //  &
    3177                                       '" does not support attribute data type "'// &
    3178                                       TRIM( attribute%data_type ) //               &
    3179                                       '" ' // TRIM( temp_string ) )
    3180 
    3181          END SELECT
    3182 
    3183       CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
    3184 
    3185          SELECT CASE ( TRIM( attribute%data_type ) )
    3186 
    3187             CASE( 'char' )
    3188                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &
    3189                        attribute_name=attribute%name, value_char=attribute%value_char, &
    3190                        return_value=output_return_value )
    3191 
    3192             CASE( 'int8' )
    3193                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &
    3194                        attribute_name=attribute%name, value_int8=attribute%value_int8, &
    3195                        return_value=output_return_value )
    3196 
    3197             CASE( 'int16' )
    3198                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id,   &
    3199                        attribute_name=attribute%name, value_int16=attribute%value_int16, &
    3200                        return_value=output_return_value )
    3201 
    3202             CASE( 'int32' )
    3203                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id,   &
    3204                        attribute_name=attribute%name, value_int32=attribute%value_int32, &
    3205                        return_value=output_return_value )
    3206 
    3207             CASE( 'real32' )
    3208                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id,     &
    3209                        attribute_name=attribute%name, value_real32=attribute%value_real32, &
    3210                        return_value=output_return_value )
    3211 
    3212             CASE( 'real64' )
    3213                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id,     &
    3214                        attribute_name=attribute%name, value_real64=attribute%value_real64, &
    3215                        return_value=output_return_value )
    3216 
    3217             CASE DEFAULT
    3218                return_value = 1
    3219                CALL internal_message( 'error', routine_name //                     &
    3220                                       ': file format "' // TRIM( file_format ) //  &
    3221                                       '" does not support attribute data type "'// &
    3222                                       TRIM( attribute%data_type ) //               &
    3223                                       '" ' // TRIM( temp_string ) )
    3224 
    3225          END SELECT
    3226 
    3227       CASE DEFAULT
    3228          return_value = 1
    3229          CALL internal_message( 'error', routine_name //                                &
    3230                                 ': unsupported file format "' // TRIM( file_format ) // &
    3231                                 '" ' // TRIM( temp_string ) )
    3232 
    3233    END SELECT
    3234 
    3235    IF ( output_return_value /= 0 )  THEN
    3236       return_value = output_return_value
    3237       CALL internal_message( 'error', routine_name // &
    3238                              ': error while writing attribute ' // TRIM( temp_string ) )
    3239    ENDIF
    3240 
    3241 END FUNCTION write_attribute
     3140 FUNCTION write_attribute( file_format, file_id, file_name,        &
     3141                           variable_id, variable_name, attribute ) RESULT( return_value )
     3142
     3143    CHARACTER(LEN=*), INTENT(IN) ::  file_format    !< file format chosen for file
     3144    CHARACTER(LEN=*), INTENT(IN) ::  file_name      !< file name
     3145    CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< variable name
     3146
     3147    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'write_attribute'  !< file format chosen for file
     3148
     3149    INTEGER, INTENT(IN) ::  file_id              !< file ID
     3150    INTEGER             ::  return_value         !< return value
     3151    INTEGER             ::  output_return_value  !< return value of a called output routine
     3152    INTEGER, INTENT(IN) ::  variable_id          !< variable ID
     3153
     3154    TYPE(attribute_type), INTENT(IN) ::  attribute  !< attribute to be written
     3155
     3156
     3157    return_value = 0
     3158    output_return_value = 0
     3159!
     3160!-- Prepare for possible error message
     3161    temp_string = '(file "' // TRIM( file_name ) //           &
     3162                  '", variable "' // TRIM( variable_name ) // &
     3163                  '", attribute "' // TRIM( attribute%name ) // '")'
     3164!
     3165!-- Write attribute to file
     3166    SELECT CASE ( TRIM( file_format ) )
     3167
     3168       CASE ( 'binary' )
     3169
     3170          SELECT CASE ( TRIM( attribute%data_type ) )
     3171
     3172             CASE( 'char' )
     3173                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,  &
     3174                        attribute_name=attribute%name, value_char=attribute%value_char, &
     3175                        return_value=output_return_value )
     3176
     3177             CASE( 'int8' )
     3178                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,  &
     3179                        attribute_name=attribute%name, value_int8=attribute%value_int8, &
     3180                        return_value=output_return_value )
     3181
     3182             CASE( 'int16' )
     3183                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,    &
     3184                        attribute_name=attribute%name, value_int16=attribute%value_int16, &
     3185                        return_value=output_return_value )
     3186
     3187             CASE( 'int32' )
     3188                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,    &
     3189                        attribute_name=attribute%name, value_int32=attribute%value_int32, &
     3190                        return_value=output_return_value )
     3191
     3192             CASE( 'real32' )
     3193                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,      &
     3194                        attribute_name=attribute%name, value_real32=attribute%value_real32, &
     3195                        return_value=output_return_value )
     3196
     3197             CASE( 'real64' )
     3198                CALL binary_write_attribute( file_id=file_id, variable_id=variable_id,      &
     3199                        attribute_name=attribute%name, value_real64=attribute%value_real64, &
     3200                        return_value=output_return_value )
     3201
     3202             CASE DEFAULT
     3203                return_value = 1
     3204                CALL internal_message( 'error', routine_name //                     &
     3205                                       ': file format "' // TRIM( file_format ) //  &
     3206                                       '" does not support attribute data type "'// &
     3207                                       TRIM( attribute%data_type ) //               &
     3208                                       '" ' // TRIM( temp_string ) )
     3209
     3210          END SELECT
     3211
     3212       CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
     3213
     3214          SELECT CASE ( TRIM( attribute%data_type ) )
     3215
     3216             CASE( 'char' )
     3217                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &
     3218                        attribute_name=attribute%name, value_char=attribute%value_char, &
     3219                        return_value=output_return_value )
     3220
     3221             CASE( 'int8' )
     3222                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &
     3223                        attribute_name=attribute%name, value_int8=attribute%value_int8, &
     3224                        return_value=output_return_value )
     3225
     3226             CASE( 'int16' )
     3227                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id,   &
     3228                        attribute_name=attribute%name, value_int16=attribute%value_int16, &
     3229                        return_value=output_return_value )
     3230
     3231             CASE( 'int32' )
     3232                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id,   &
     3233                        attribute_name=attribute%name, value_int32=attribute%value_int32, &
     3234                        return_value=output_return_value )
     3235
     3236             CASE( 'real32' )
     3237                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id,     &
     3238                        attribute_name=attribute%name, value_real32=attribute%value_real32, &
     3239                        return_value=output_return_value )
     3240
     3241             CASE( 'real64' )
     3242                CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id,     &
     3243                        attribute_name=attribute%name, value_real64=attribute%value_real64, &
     3244                        return_value=output_return_value )
     3245
     3246             CASE DEFAULT
     3247                return_value = 1
     3248                CALL internal_message( 'error', routine_name //                     &
     3249                                       ': file format "' // TRIM( file_format ) //  &
     3250                                       '" does not support attribute data type "'// &
     3251                                       TRIM( attribute%data_type ) //               &
     3252                                       '" ' // TRIM( temp_string ) )
     3253
     3254          END SELECT
     3255
     3256       CASE DEFAULT
     3257          return_value = 1
     3258          CALL internal_message( 'error', routine_name //                                &
     3259                                 ': unsupported file format "' // TRIM( file_format ) // &
     3260                                 '" ' // TRIM( temp_string ) )
     3261
     3262    END SELECT
     3263
     3264    IF ( output_return_value /= 0 )  THEN
     3265       return_value = output_return_value
     3266       CALL internal_message( 'error', routine_name // &
     3267                              ': error while writing attribute ' // TRIM( temp_string ) )
     3268    ENDIF
     3269
     3270 END FUNCTION write_attribute
    32423271
    32433272!--------------------------------------------------------------------------------------------------!
     
    32463275!> Get dimension IDs and save them to variables.
    32473276!--------------------------------------------------------------------------------------------------!
    3248 SUBROUTINE collect_dimesion_ids_for_variables( file_name, variables, dimensions, return_value )
    3249 
    3250    CHARACTER(LEN=*), INTENT(IN) ::  file_name !< name of file
    3251 
    3252    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'collect_dimesion_ids_for_variables'  !< file format chosen for file
    3253 
    3254    INTEGER              ::  d             !< loop index
    3255    INTEGER              ::  i             !< loop index
    3256    INTEGER              ::  j             !< loop index
    3257    INTEGER              ::  ndims         !< number of dimensions
    3258    INTEGER              ::  nvars         !< number of variables
    3259    INTEGER, INTENT(OUT) ::  return_value  !< return value
    3260 
    3261    LOGICAL ::  found  !< true if dimension required by variable was found in dimension list
    3262 
    3263    TYPE(dimension_type), DIMENSION(:), INTENT(IN) ::  dimensions  !< list of dimensions in file
    3264 
    3265    TYPE(variable_type), DIMENSION(:), INTENT(INOUT) ::  variables  !< list of variables in file
    3266 
    3267 
    3268    return_value  = 0
    3269    ndims = SIZE( dimensions )
    3270    nvars = SIZE( variables )
    3271 
    3272    DO  i = 1, nvars
    3273       DO  j = 1, SIZE( variables(i)%dimension_names )
    3274          found = .FALSE.
    3275          DO  d = 1, ndims
    3276             IF ( variables(i)%dimension_names(j) == dimensions(d)%name )  THEN
    3277                variables(i)%dimension_ids(j) = dimensions(d)%id
    3278                found = .TRUE.
    3279                EXIT
    3280             ENDIF
    3281          ENDDO
    3282          IF ( .NOT. found )  THEN
    3283             return_value = 1
    3284             CALL internal_message( 'error', routine_name //                                &
    3285                     ': required dimension "' // TRIM( variables(i)%dimension_names(j) ) // &
    3286                     '" is undefined (variable "' // TRIM( variables(i)%name ) //           &
    3287                     '", file "' // TRIM( file_name ) // '")!' )
    3288             EXIT
    3289          ENDIF
    3290       ENDDO
    3291       IF ( .NOT. found )  EXIT
    3292    ENDDO
    3293 
    3294 END SUBROUTINE collect_dimesion_ids_for_variables
     3277 SUBROUTINE collect_dimesion_ids_for_variables( file_name, variables, dimensions, return_value )
     3278
     3279    CHARACTER(LEN=*), INTENT(IN) ::  file_name !< name of file
     3280
     3281    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'collect_dimesion_ids_for_variables'  !< file format chosen for file
     3282
     3283    INTEGER              ::  d             !< loop index
     3284    INTEGER              ::  i             !< loop index
     3285    INTEGER              ::  j             !< loop index
     3286    INTEGER              ::  ndims         !< number of dimensions
     3287    INTEGER              ::  nvars         !< number of variables
     3288    INTEGER, INTENT(OUT) ::  return_value  !< return value
     3289
     3290    LOGICAL ::  found  !< true if dimension required by variable was found in dimension list
     3291
     3292    TYPE(dimension_type), DIMENSION(:), INTENT(IN) ::  dimensions  !< list of dimensions in file
     3293
     3294    TYPE(variable_type), DIMENSION(:), INTENT(INOUT) ::  variables  !< list of variables in file
     3295
     3296
     3297    return_value  = 0
     3298    ndims = SIZE( dimensions )
     3299    nvars = SIZE( variables )
     3300
     3301    DO  i = 1, nvars
     3302       DO  j = 1, SIZE( variables(i)%dimension_names )
     3303          found = .FALSE.
     3304          DO  d = 1, ndims
     3305             IF ( variables(i)%dimension_names(j) == dimensions(d)%name )  THEN
     3306                variables(i)%dimension_ids(j) = dimensions(d)%id
     3307                found = .TRUE.
     3308                EXIT
     3309             ENDIF
     3310          ENDDO
     3311          IF ( .NOT. found )  THEN
     3312             return_value = 1
     3313             CALL internal_message( 'error', routine_name //                                &
     3314                     ': required dimension "' // TRIM( variables(i)%dimension_names(j) ) // &
     3315                     '" is undefined (variable "' // TRIM( variables(i)%name ) //           &
     3316                     '", file "' // TRIM( file_name ) // '")!' )
     3317             EXIT
     3318          ENDIF
     3319       ENDDO
     3320       IF ( .NOT. found )  EXIT
     3321    ENDDO
     3322
     3323 END SUBROUTINE collect_dimesion_ids_for_variables
    32953324
    32963325!--------------------------------------------------------------------------------------------------!
     
    33013330!> @todo Do we need an MPI barrier at the end?
    33023331!--------------------------------------------------------------------------------------------------!
    3303 SUBROUTINE stop_file_header_definition( file_format, file_id, file_name, return_value )
    3304 
    3305    CHARACTER(LEN=*), INTENT(IN) ::  file_format  !< file format
    3306    CHARACTER(LEN=*), INTENT(IN) ::  file_name    !< file name
    3307 
    3308    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'stop_file_header_definition'  !< name of routine
    3309 
    3310    INTEGER, INTENT(IN)  ::  file_id              !< file id
    3311    INTEGER              ::  output_return_value  !< return value of a called output routine
    3312    INTEGER, INTENT(OUT) ::  return_value         !< return value
    3313 
    3314 
    3315    return_value = 0
    3316    output_return_value = 0
    3317 
    3318    temp_string = '(file "' // TRIM( file_name ) // '")'
    3319 
    3320    SELECT CASE ( TRIM( file_format ) )
    3321 
    3322       CASE ( 'binary' )
    3323          CALL binary_stop_file_header_definition( file_id, output_return_value )
    3324 
    3325       CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
    3326          CALL netcdf4_stop_file_header_definition( file_id, output_return_value )
    3327 
    3328       CASE DEFAULT
    3329          return_value = 1
    3330          CALL internal_message( 'error', routine_name //                    &
    3331                                 ': file format "' // TRIM( file_format ) // &
    3332                                 '" not supported ' // TRIM( temp_string ) )
    3333 
    3334    END SELECT
    3335 
    3336    IF ( output_return_value /= 0 )  THEN
    3337       return_value = output_return_value
    3338       CALL internal_message( 'error', routine_name //                          &
    3339                              ': error while leaving file-definition state ' // &
    3340                              TRIM( temp_string ) )
    3341    ENDIF
    3342 
    3343    ! CALL MPI_Barrier( MPI_COMM_WORLD, return_value )
    3344 
    3345 END SUBROUTINE stop_file_header_definition
     3332 SUBROUTINE stop_file_header_definition( file_format, file_id, file_name, return_value )
     3333
     3334    CHARACTER(LEN=*), INTENT(IN) ::  file_format  !< file format
     3335    CHARACTER(LEN=*), INTENT(IN) ::  file_name    !< file name
     3336
     3337    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'stop_file_header_definition'  !< name of routine
     3338
     3339    INTEGER, INTENT(IN)  ::  file_id              !< file id
     3340    INTEGER              ::  output_return_value  !< return value of a called output routine
     3341    INTEGER, INTENT(OUT) ::  return_value         !< return value
     3342
     3343
     3344    return_value = 0
     3345    output_return_value = 0
     3346
     3347    temp_string = '(file "' // TRIM( file_name ) // '")'
     3348
     3349    SELECT CASE ( TRIM( file_format ) )
     3350
     3351       CASE ( 'binary' )
     3352          CALL binary_stop_file_header_definition( file_id, output_return_value )
     3353
     3354       CASE ( 'netcdf4-parallel', 'netcdf4-serial' )
     3355          CALL netcdf4_stop_file_header_definition( file_id, output_return_value )
     3356
     3357       CASE DEFAULT
     3358          return_value = 1
     3359          CALL internal_message( 'error', routine_name //                    &
     3360                                 ': file format "' // TRIM( file_format ) // &
     3361                                 '" not supported ' // TRIM( temp_string ) )
     3362
     3363    END SELECT
     3364
     3365    IF ( output_return_value /= 0 )  THEN
     3366       return_value = output_return_value
     3367       CALL internal_message( 'error', routine_name //                          &
     3368                              ': error while leaving file-definition state ' // &
     3369                              TRIM( temp_string ) )
     3370    ENDIF
     3371
     3372    ! CALL MPI_Barrier( MPI_COMM_WORLD, return_value )
     3373
     3374 END SUBROUTINE stop_file_header_definition
    33463375
    33473376!--------------------------------------------------------------------------------------------------!
     
    33503379!> Find a requested variable 'variable_name' and its used dimensions in requested file 'file_name'.
    33513380!--------------------------------------------------------------------------------------------------!
    3352 SUBROUTINE find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, &
    3353                              is_global, dimensions, return_value )
    3354 
    3355    CHARACTER(LEN=charlen), INTENT(OUT) ::  file_format    !< file format chosen for file
    3356    CHARACTER(LEN=*),       INTENT(IN)  ::  file_name      !< name of file
    3357    CHARACTER(LEN=*),       INTENT(IN)  ::  variable_name  !< name of variable
    3358 
    3359    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'find_var_in_file'  !< name of routine
    3360 
    3361    INTEGER              ::  d             !< loop index
    3362    INTEGER              ::  dd            !< loop index
    3363    INTEGER              ::  f             !< loop index
    3364    INTEGER, INTENT(OUT) ::  file_id       !< file ID
    3365    INTEGER, INTENT(OUT) ::  return_value  !< return value
    3366    INTEGER, INTENT(OUT) ::  variable_id   !< variable ID
    3367 
    3368    INTEGER, DIMENSION(:), ALLOCATABLE ::  dimension_ids  !< list of dimension IDs used by variable
    3369 
    3370    LOGICAL              ::  found      !< true if requested variable found in requested file
    3371    LOGICAL, INTENT(OUT) ::  is_global  !< true if variable is global
    3372 
    3373    TYPE(dimension_type), DIMENSION(:), ALLOCATABLE, INTENT(OUT) ::  dimensions  !< list of dimensions used by variable
    3374 
    3375 
    3376    return_value = 0
    3377    found = .FALSE.
    3378 
    3379    DO  f = 1, nfiles
    3380       IF ( TRIM( file_name ) == TRIM( files(f)%name ) )  THEN
    3381 
    3382          IF ( .NOT. files(f)%is_init )  THEN
    3383             return_value = 1
    3384             CALL internal_message( 'error', routine_name //                     &
    3385                                    ': file not initialized. ' //                &
    3386                                    'Writing variable to file is impossible ' // &
    3387                                    '(variable "' // TRIM( variable_name ) //    &
    3388                                    '", file "' // TRIM( file_name ) // '")!' )
    3389             EXIT
    3390          ENDIF
    3391 
    3392          file_id     = files(f)%id
    3393          file_format = files(f)%format
    3394 
    3395          !-- Search for variable in file
    3396          DO  d = 1, SIZE( files(f)%variables )
    3397             IF ( TRIM( variable_name ) == TRIM( files(f)%variables(d)%name ) )  THEN
    3398 
    3399                variable_id    = files(f)%variables(d)%id
    3400                is_global = files(f)%variables(d)%is_global
    3401 
    3402                ALLOCATE( dimension_ids(SIZE( files(f)%variables(d)%dimension_ids )) )
    3403                ALLOCATE( dimensions(SIZE( files(f)%variables(d)%dimension_ids )) )
    3404 
    3405                dimension_ids = files(f)%variables(d)%dimension_ids
    3406 
    3407                found = .TRUE.
    3408                EXIT
    3409 
    3410             ENDIF
    3411          ENDDO
    3412 
    3413          IF ( found )  THEN
    3414 
    3415             !-- Get list of dimensions used by variable
    3416             DO  d = 1, SIZE( files(f)%dimensions )
    3417                DO  dd = 1, SIZE( dimension_ids )
    3418                   IF ( dimension_ids(dd) == files(f)%dimensions(d)%id )  THEN
    3419                      dimensions(dd) = files(f)%dimensions(d)
    3420                      EXIT
    3421                   ENDIF
    3422                ENDDO
    3423             ENDDO
    3424 
    3425          ELSE
    3426 
    3427             !-- If variable was not found, search for a dimension instead
    3428             DO  d = 1, SIZE( files(f)%dimensions )
    3429                IF ( TRIM( variable_name ) == TRIM( files(f)%dimensions(d)%name ) )  THEN
    3430 
    3431                   variable_id    = files(f)%dimensions(d)%variable_id
    3432                   is_global = .TRUE.
    3433 
    3434                   ALLOCATE( dimensions(1) )
    3435 
    3436                   dimensions(1) = files(f)%dimensions(d)
    3437 
    3438                   found = .TRUE.
    3439                   EXIT
    3440 
    3441                ENDIF
    3442             ENDDO
    3443 
    3444          ENDIF
    3445 
    3446          !-- If variable was not found in requested file, return an error
    3447          IF ( .NOT. found )  THEN
    3448             return_value = 1
    3449             CALL internal_message( 'error', routine_name //                  &
    3450                                    ': variable not found in file ' //        &
    3451                                    '(variable "' // TRIM( variable_name ) // &
    3452                                    '", file "' // TRIM( file_name ) // '")!' )
    3453          ENDIF
    3454 
    3455          EXIT
    3456 
    3457       ENDIF  ! file found
    3458    ENDDO  ! loop over files
    3459 
    3460    IF ( .NOT. found  .AND.  return_value == 0 )  THEN
    3461       return_value = 1
    3462       CALL internal_message( 'error', routine_name //                  &
    3463                              ': file not found ' //                    &
    3464                              '(variable "' // TRIM( variable_name ) // &
    3465                              '", file "' // TRIM( file_name ) // '")!' )
    3466    ENDIF
    3467 
    3468 END SUBROUTINE find_var_in_file
     3381 SUBROUTINE find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, &
     3382                              is_global, dimensions, return_value )
     3383
     3384    CHARACTER(LEN=charlen), INTENT(OUT) ::  file_format    !< file format chosen for file
     3385    CHARACTER(LEN=*),       INTENT(IN)  ::  file_name      !< name of file
     3386    CHARACTER(LEN=*),       INTENT(IN)  ::  variable_name  !< name of variable
     3387
     3388    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'find_var_in_file'  !< name of routine
     3389
     3390    INTEGER              ::  d             !< loop index
     3391    INTEGER              ::  dd            !< loop index
     3392    INTEGER              ::  f             !< loop index
     3393    INTEGER, INTENT(OUT) ::  file_id       !< file ID
     3394    INTEGER, INTENT(OUT) ::  return_value  !< return value
     3395    INTEGER, INTENT(OUT) ::  variable_id   !< variable ID
     3396
     3397    INTEGER, DIMENSION(:), ALLOCATABLE ::  dimension_ids  !< list of dimension IDs used by variable
     3398
     3399    LOGICAL              ::  found      !< true if requested variable found in requested file
     3400    LOGICAL, INTENT(OUT) ::  is_global  !< true if variable is global
     3401
     3402    TYPE(dimension_type), DIMENSION(:), ALLOCATABLE, INTENT(OUT) ::  dimensions  !< list of dimensions used by variable
     3403
     3404
     3405    return_value = 0
     3406    found = .FALSE.
     3407
     3408    DO  f = 1, nfiles
     3409       IF ( TRIM( file_name ) == TRIM( files(f)%name ) )  THEN
     3410
     3411          IF ( .NOT. files(f)%is_init )  THEN
     3412             return_value = 1
     3413             CALL internal_message( 'error', routine_name //                     &
     3414                                    ': file not initialized. ' //                &
     3415                                    'Writing variable to file is impossible ' // &
     3416                                    '(variable "' // TRIM( variable_name ) //    &
     3417                                    '", file "' // TRIM( file_name ) // '")!' )
     3418             EXIT
     3419          ENDIF
     3420
     3421          file_id     = files(f)%id
     3422          file_format = files(f)%format
     3423!
     3424!--      Search for variable in file
     3425          DO  d = 1, SIZE( files(f)%variables )
     3426             IF ( TRIM( variable_name ) == TRIM( files(f)%variables(d)%name ) )  THEN
     3427
     3428                variable_id    = files(f)%variables(d)%id
     3429                is_global = files(f)%variables(d)%is_global
     3430
     3431                ALLOCATE( dimension_ids(SIZE( files(f)%variables(d)%dimension_ids )) )
     3432                ALLOCATE( dimensions(SIZE( files(f)%variables(d)%dimension_ids )) )
     3433
     3434                dimension_ids = files(f)%variables(d)%dimension_ids
     3435
     3436                found = .TRUE.
     3437                EXIT
     3438
     3439             ENDIF
     3440          ENDDO
     3441
     3442          IF ( found )  THEN
     3443!
     3444!--          Get list of dimensions used by variable
     3445             DO  d = 1, SIZE( files(f)%dimensions )
     3446                DO  dd = 1, SIZE( dimension_ids )
     3447                   IF ( dimension_ids(dd) == files(f)%dimensions(d)%id )  THEN
     3448                      dimensions(dd) = files(f)%dimensions(d)
     3449                      EXIT
     3450                   ENDIF
     3451                ENDDO
     3452             ENDDO
     3453
     3454          ELSE
     3455!
     3456!--          If variable was not found, search for a dimension instead
     3457             DO  d = 1, SIZE( files(f)%dimensions )
     3458                IF ( TRIM( variable_name ) == TRIM( files(f)%dimensions(d)%name ) )  THEN
     3459
     3460                   variable_id    = files(f)%dimensions(d)%variable_id
     3461                   is_global = .TRUE.
     3462
     3463                   ALLOCATE( dimensions(1) )
     3464
     3465                   dimensions(1) = files(f)%dimensions(d)
     3466
     3467                   found = .TRUE.
     3468                   EXIT
     3469
     3470                ENDIF
     3471             ENDDO
     3472
     3473          ENDIF
     3474!
     3475!--      If variable was not found in requested file, return an error
     3476          IF ( .NOT. found )  THEN
     3477             return_value = 1
     3478             CALL internal_message( 'error', routine_name //                  &
     3479                                    ': variable not found in file ' //        &
     3480                                    '(variable "' // TRIM( variable_name ) // &
     3481                                    '", file "' // TRIM( file_name ) // '")!' )
     3482          ENDIF
     3483
     3484          EXIT
     3485
     3486       ENDIF  ! file found
     3487    ENDDO  ! loop over files
     3488
     3489    IF ( .NOT. found  .AND.  return_value == 0 )  THEN
     3490       return_value = 1
     3491       CALL internal_message( 'error', routine_name //                  &
     3492                              ': file not found ' //                    &
     3493                              '(variable "' // TRIM( variable_name ) // &
     3494                              '", file "' // TRIM( file_name ) // '")!' )
     3495    ENDIF
     3496
     3497 END SUBROUTINE find_var_in_file
    34693498
    34703499!--------------------------------------------------------------------------------------------------!
     
    34783507!> starts and origins are set to zero for all dimensions.
    34793508!--------------------------------------------------------------------------------------------------!
    3480 SUBROUTINE get_masked_indices_and_masked_dimension_bounds(                             &
    3481               dimensions, bounds_start, bounds_end, bounds_masked_start, value_counts, &
    3482               bounds_origin, masked_indices )
    3483 
    3484    ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'get_masked_indices_and_masked_dimension_bounds'  !< name of routine
    3485 
    3486    INTEGER ::  d  !< loop index
    3487    INTEGER ::  i  !< loop index
    3488 
    3489    INTEGER, DIMENSION(:), INTENT(IN)  ::  bounds_end           !< upper bonuds to be searched in
    3490    INTEGER, DIMENSION(:), INTENT(OUT) ::  bounds_masked_start  !< lower bounds of masked dimensions within given bounds
    3491    INTEGER, DIMENSION(:), INTENT(OUT) ::  bounds_origin        !< first index of each dimension, 0 if dimension is masked
    3492    INTEGER, DIMENSION(:), INTENT(IN)  ::  bounds_start         !< lower bounds to be searched in
    3493    INTEGER, DIMENSION(:), INTENT(OUT) ::  value_counts         !< count of indices per dimension to be output
    3494 
    3495    INTEGER, DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) ::  masked_indices  !< masked indices within given bounds
    3496 
    3497    TYPE(dimension_type), DIMENSION(:), INTENT(IN) ::  dimensions  !< dimensions to be searched for masked indices
    3498 
    3499 
    3500    ALLOCATE( masked_indices(SIZE( dimensions ),0:MAXVAL( bounds_end - bounds_start + 1 )) )
    3501    masked_indices = -HUGE( 0 )
    3502 
    3503    !-- Check for masking and update lower and upper bounds if masked
    3504    DO  d = 1, SIZE( dimensions )
    3505 
    3506       IF ( dimensions(d)%is_masked )  THEN
    3507 
    3508          bounds_origin(d) = 0
    3509 
    3510          bounds_masked_start(d) = -HUGE( 0 )
    3511 
    3512          !-- Find number of masked values within given variable bounds
    3513          value_counts(d) = 0
    3514          DO  i = LBOUND( dimensions(d)%masked_indices, DIM=1 ), &
    3515                  UBOUND( dimensions(d)%masked_indices, DIM=1 )
    3516 
    3517             !-- Is masked index within given bounds?
    3518             IF ( dimensions(d)%masked_indices(i) >= bounds_start(d)  .AND.  &
    3519                  dimensions(d)%masked_indices(i) <= bounds_end(d)           )  THEN
    3520 
    3521                !-- Save masked index
    3522                masked_indices(d,value_counts(d)) = dimensions(d)%masked_indices(i)
    3523                value_counts(d) = value_counts(d) + 1
    3524 
    3525                !-- Save bounds of mask within given bounds
    3526                IF ( bounds_masked_start(d) == -HUGE( 0 ) )  bounds_masked_start(d) = i
    3527 
    3528             ENDIF
    3529 
    3530          ENDDO
    3531 
    3532          !-- Set masked bounds to zero if no masked index lies within bounds
    3533          IF ( value_counts(d) == 0 )  THEN
    3534             bounds_origin(:) = 0
    3535             bounds_masked_start(:) = 0
    3536             value_counts(:) = 0
    3537             EXIT
    3538          ENDIF
    3539 
    3540       ELSE
    3541 
    3542          !-- If dimension is not masked, save all indices within bounds for output
    3543          bounds_origin(d) = dimensions(d)%bounds(1)
    3544          bounds_masked_start(d) = bounds_start(d)
    3545          value_counts(d) = bounds_end(d) - bounds_start(d) + 1
    3546 
    3547          DO  i = 0, value_counts(d) - 1
    3548             masked_indices(d,i) = bounds_start(d) + i
    3549          ENDDO
    3550 
    3551       ENDIF
    3552 
    3553    ENDDO
    3554 
    3555 END SUBROUTINE get_masked_indices_and_masked_dimension_bounds
     3509 SUBROUTINE get_masked_indices_and_masked_dimension_bounds(                             &
     3510               dimensions, bounds_start, bounds_end, bounds_masked_start, value_counts, &
     3511               bounds_origin, masked_indices )
     3512
     3513    ! CHARACTER(LEN=*), PARAMETER ::  routine_name = 'get_masked_indices_and_masked_dimension_bounds'  !< name of routine
     3514
     3515    INTEGER ::  d  !< loop index
     3516    INTEGER ::  i  !< loop index
     3517
     3518    INTEGER, DIMENSION(:), INTENT(IN)  ::  bounds_end           !< upper bonuds to be searched in
     3519    INTEGER, DIMENSION(:), INTENT(OUT) ::  bounds_masked_start  !< lower bounds of masked dimensions within given bounds
     3520    INTEGER, DIMENSION(:), INTENT(OUT) ::  bounds_origin        !< first index of each dimension, 0 if dimension is masked
     3521    INTEGER, DIMENSION(:), INTENT(IN)  ::  bounds_start         !< lower bounds to be searched in
     3522    INTEGER, DIMENSION(:), INTENT(OUT) ::  value_counts         !< count of indices per dimension to be output
     3523
     3524    INTEGER, DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) ::  masked_indices  !< masked indices within given bounds
     3525
     3526    TYPE(dimension_type), DIMENSION(:), INTENT(IN) ::  dimensions  !< dimensions to be searched for masked indices
     3527
     3528
     3529    ALLOCATE( masked_indices(SIZE( dimensions ),0:MAXVAL( bounds_end - bounds_start + 1 )) )
     3530    masked_indices = -HUGE( 0 )
     3531!
     3532!-- Check for masking and update lower and upper bounds if masked
     3533    DO  d = 1, SIZE( dimensions )
     3534
     3535       IF ( dimensions(d)%is_masked )  THEN
     3536
     3537          bounds_origin(d) = 0
     3538
     3539          bounds_masked_start(d) = -HUGE( 0 )
     3540!
     3541!--      Find number of masked values within given variable bounds
     3542          value_counts(d) = 0
     3543          DO  i = LBOUND( dimensions(d)%masked_indices, DIM=1 ), &
     3544                  UBOUND( dimensions(d)%masked_indices, DIM=1 )
     3545!
     3546!--          Is masked index within given bounds?
     3547             IF ( dimensions(d)%masked_indices(i) >= bounds_start(d)  .AND.  &
     3548                  dimensions(d)%masked_indices(i) <= bounds_end(d)           )  THEN
     3549!
     3550!--            Save masked index
     3551                masked_indices(d,value_counts(d)) = dimensions(d)%masked_indices(i)
     3552                value_counts(d) = value_counts(d) + 1
     3553!
     3554!--            Save bounds of mask within given bounds
     3555                IF ( bounds_masked_start(d) == -HUGE( 0 ) )  bounds_masked_start(d) = i
     3556
     3557             ENDIF
     3558
     3559          ENDDO
     3560!
     3561!--      Set masked bounds to zero if no masked index lies within bounds
     3562          IF ( value_counts(d) == 0 )  THEN
     3563             bounds_origin(:) = 0
     3564             bounds_masked_start(:) = 0
     3565             value_counts(:) = 0
     3566             EXIT
     3567          ENDIF
     3568
     3569       ELSE
     3570!
     3571!--      If dimension is not masked, save all indices within bounds for output
     3572          bounds_origin(d) = dimensions(d)%bounds(1)
     3573          bounds_masked_start(d) = bounds_start(d)
     3574          value_counts(d) = bounds_end(d) - bounds_start(d) + 1
     3575
     3576          DO  i = 0, value_counts(d) - 1
     3577             masked_indices(d,i) = bounds_start(d) + i
     3578          ENDDO
     3579
     3580       ENDIF
     3581
     3582    ENDDO
     3583
     3584 END SUBROUTINE get_masked_indices_and_masked_dimension_bounds
    35563585
    35573586!--------------------------------------------------------------------------------------------------!
     
    35613590!> or creating the error message string.
    35623591!--------------------------------------------------------------------------------------------------!
    3563 SUBROUTINE internal_message( level, string )
    3564 
    3565    CHARACTER(LEN=*), INTENT(IN) ::  level   !< message importance level
    3566    CHARACTER(LEN=*), INTENT(IN) ::  string  !< message string
    3567 
    3568 
    3569    IF ( TRIM( level ) == 'error' )  THEN
    3570 
    3571       WRITE( internal_error_message, '(A,A)' ) 'DOM ERROR: ', string
    3572 
    3573    ELSEIF ( TRIM( level ) == 'debug'  .AND.  print_debug_output )  THEN
    3574 
    3575       WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
    3576       FLUSH( debug_output_unit )
    3577 
    3578    ENDIF
    3579 
    3580 END SUBROUTINE internal_message
     3592 SUBROUTINE internal_message( level, string )
     3593
     3594    CHARACTER(LEN=*), INTENT(IN) ::  level   !< message importance level
     3595    CHARACTER(LEN=*), INTENT(IN) ::  string  !< message string
     3596
     3597
     3598    IF ( TRIM( level ) == 'error' )  THEN
     3599
     3600       WRITE( internal_error_message, '(A,A)' ) 'DOM ERROR: ', string
     3601
     3602    ELSEIF ( TRIM( level ) == 'debug'  .AND.  print_debug_output )  THEN
     3603
     3604       WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
     3605       FLUSH( debug_output_unit )
     3606
     3607    ENDIF
     3608
     3609 END SUBROUTINE internal_message
    35813610
    35823611!--------------------------------------------------------------------------------------------------!
     
    35863615!> stage after the call to 'dom_init'. Multiple calls are possible.
    35873616!--------------------------------------------------------------------------------------------------!
    3588 SUBROUTINE dom_database_debug_output
    3589 
    3590    CHARACTER(LEN=*), PARAMETER ::  separation_string = '---'                   !< string separating blocks in output
    3591    CHARACTER(LEN=50)           ::  write_format1                               !< format for write statements
    3592    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_database_debug_output'  !< name of this routine
    3593 
    3594    INTEGER            ::  f                       !< loop index
    3595    INTEGER, PARAMETER ::  indent_depth = 3        !< space per indentation
    3596    INTEGER            ::  indent_level            !< indentation level
    3597    INTEGER, PARAMETER ::  max_keyname_length = 6  !< length of longest key name
    3598    INTEGER            ::  natts                   !< number of attributes
    3599    INTEGER            ::  ndims                   !< number of dimensions
    3600    INTEGER            ::  nvars                   !< number of variables
    3601 
    3602 
    3603    CALL internal_message( 'debug', routine_name // ': write database to debug output' )
    3604 
    3605    WRITE( debug_output_unit, '(A)' ) 'DOM database:'
    3606    WRITE( debug_output_unit, '(A)' ) REPEAT( separation_string // ' ', 4 )
    3607 
    3608    IF ( .NOT. ALLOCATED( files ) .OR. nfiles == 0 )  THEN
    3609 
    3610       WRITE( debug_output_unit, '(A)' ) 'database is empty'
    3611 
    3612    ELSE
    3613 
    3614       indent_level = 1
    3615       WRITE( write_format1, '(A,I3,A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A,T',  &
    3616                                         indent_level * indent_depth + 1 + max_keyname_length, &
    3617                                         ',(": ")'
    3618 
    3619       DO  f = 1, nfiles
    3620 
    3621          natts = 0
    3622          ndims = 0
    3623          nvars = 0
    3624          IF ( ALLOCATED( files(f)%attributes ) ) natts = SIZE( files(f)%attributes )
    3625          IF ( ALLOCATED( files(f)%dimensions ) ) ndims = SIZE( files(f)%dimensions )
    3626          IF ( ALLOCATED( files(f)%variables  ) ) nvars = SIZE( files(f)%variables  )
    3627 
    3628          WRITE( debug_output_unit, '(A)' ) 'file:'
    3629          WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) 'name', TRIM( files(f)%name )
    3630          WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) 'format', TRIM(files(f)%format)
    3631          WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) 'id', files(f)%id
    3632          WRITE( debug_output_unit, TRIM( write_format1 ) // ',L1)' ) 'is init', files(f)%is_init
    3633          WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#atts', natts
    3634          WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#dims', ndims
    3635          WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#vars', nvars
    3636 
    3637          IF ( natts /= 0 )  CALL print_attributes( indent_level, files(f)%attributes )
    3638          IF ( ndims /= 0 )  CALL print_dimensions( indent_level, files(f)%dimensions )
    3639          IF ( nvars /= 0 )  CALL print_variables( indent_level, files(f)%variables )
    3640 
    3641          WRITE( debug_output_unit, '(/A/)' ) REPEAT( separation_string // ' ', 4 )
    3642 
    3643       ENDDO
    3644 
    3645    ENDIF
    3646 
    3647    CONTAINS
    3648 
    3649       !--------------------------------------------------------------------------------------------!
    3650       ! Description:
    3651       ! ------------
    3652       !> Print list of attributes.
    3653       !--------------------------------------------------------------------------------------------!
    3654       SUBROUTINE print_attributes( indent_level, attributes )
    3655 
    3656          CHARACTER(LEN=50) ::  write_format1  !< format for write statements
    3657          CHARACTER(LEN=50) ::  write_format2  !< format for write statements
    3658 
    3659          INTEGER             ::  i                       !< loop index
    3660          INTEGER, INTENT(IN) ::  indent_level            !< indentation level
    3661          INTEGER, PARAMETER  ::  max_keyname_length = 6  !< length of longest key name
    3662          INTEGER             ::  nelement                !< number of elements to print
    3663 
    3664          TYPE(attribute_type), DIMENSION(:), INTENT(IN) ::  attributes  !< list of attributes
    3665 
    3666 
    3667          WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
    3668          WRITE( write_format2, '(A,I3,A,I3,A)' ) &
    3669             '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
    3670             ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
    3671 
    3672          WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) &
    3673             REPEAT( separation_string // ' ', 4 )
    3674          WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'attributes:'
    3675 
    3676          nelement = SIZE( attributes )
    3677          DO  i = 1, nelement
    3678             WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
    3679                'name', TRIM( attributes(i)%name )
    3680             WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
    3681                'type', TRIM( attributes(i)%data_type )
    3682 
    3683             IF ( TRIM( attributes(i)%data_type ) == 'char' )  THEN
    3684                WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
    3685                   'value', TRIM( attributes(i)%value_char )
    3686             ELSEIF ( TRIM( attributes(i)%data_type ) == 'int8' )  THEN
    3687                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)' ) &
    3688                   'value', attributes(i)%value_int8
    3689             ELSEIF ( TRIM( attributes(i)%data_type ) == 'int16' )  THEN
    3690                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)' ) &
    3691                   'value', attributes(i)%value_int16
    3692             ELSEIF ( TRIM( attributes(i)%data_type ) == 'int32' )  THEN
    3693                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)' ) &
    3694                   'value', attributes(i)%value_int32
    3695             ELSEIF ( TRIM( attributes(i)%data_type ) == 'real32' )  THEN
    3696                WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)' ) &
    3697                   'value', attributes(i)%value_real32
    3698             ELSEIF (  TRIM(attributes(i)%data_type) == 'real64' )  THEN
    3699                WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)' ) &
    3700                   'value', attributes(i)%value_real64
    3701             ENDIF
    3702             IF ( i < nelement )  &
    3703                WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string
    3704          ENDDO
    3705 
    3706       END SUBROUTINE print_attributes
    3707 
    3708       !--------------------------------------------------------------------------------------------!
    3709       ! Description:
    3710       ! ------------
    3711       !> Print list of dimensions.
    3712       !--------------------------------------------------------------------------------------------!
    3713       SUBROUTINE print_dimensions( indent_level, dimensions )
    3714 
    3715          CHARACTER(LEN=50) ::  write_format1  !< format for write statements
    3716          CHARACTER(LEN=50) ::  write_format2  !< format for write statements
    3717 
    3718          INTEGER             ::  i                        !< loop index
    3719          INTEGER, INTENT(IN) ::  indent_level             !< indentation level
    3720          INTEGER             ::  j                        !< loop index
    3721          INTEGER, PARAMETER  ::  max_keyname_length = 15  !< length of longest key name
    3722          INTEGER             ::  nelement                 !< number of elements to print
    3723 
    3724          LOGICAL ::  is_masked  !< true if dimension is masked
    3725 
    3726          TYPE(dimension_type), DIMENSION(:), INTENT(IN) ::  dimensions  !< list of dimensions
    3727 
    3728 
    3729          WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
    3730          WRITE( write_format2, '(A,I3,A,I3,A)' ) &
    3731             '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
    3732             ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
    3733 
    3734          WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) &
    3735             REPEAT( separation_string // ' ', 4 )
    3736          WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'dimensions:'
    3737 
    3738          nelement = SIZE( dimensions )
    3739          DO  i = 1, nelement
    3740             is_masked = dimensions(i)%is_masked
    3741 
    3742             !-- Print general information
    3743             WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
    3744                'name', TRIM( dimensions(i)%name )
    3745             WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
    3746                'type', TRIM( dimensions(i)%data_type )
    3747             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &
    3748                'id', dimensions(i)%id
    3749             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &
    3750                'length', dimensions(i)%length
    3751             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7,A,I7)' ) &
    3752                'bounds', dimensions(i)%bounds(1), ',', dimensions(i)%bounds(2)
    3753             WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)' ) &
    3754                'is masked', dimensions(i)%is_masked
    3755 
    3756             !-- Print information about mask
    3757             IF ( is_masked )  THEN
    3758                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &
    3759                   'masked length', dimensions(i)%length_mask
    3760 
    3761                WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)', ADVANCE='no' ) &
    3762                   'mask', dimensions(i)%mask(dimensions(i)%bounds(1))
    3763                DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
    3764                   WRITE( debug_output_unit, '(A,L1)', ADVANCE='no' ) ',', dimensions(i)%mask(j)
    3765                ENDDO
    3766                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3767 
    3768                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) &
    3769                   'masked indices', dimensions(i)%masked_indices(0)
    3770                DO  j = 1, dimensions(i)%length_mask-1
    3771                   WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
    3772                      ',', dimensions(i)%masked_indices(j)
    3773                ENDDO
    3774                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3775             ENDIF
    3776 
    3777             !-- Print saved values
    3778             IF ( ALLOCATED( dimensions(i)%values_int8 ) )  THEN
    3779 
    3780                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)', ADVANCE='no' ) &
    3781                   'values', dimensions(i)%values_int8(dimensions(i)%bounds(1))
    3782                DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
    3783                   WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) &
    3784                      ',', dimensions(i)%values_int8(j)
    3785                ENDDO
    3786                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3787                IF ( is_masked )  THEN
    3788                   WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)', ADVANCE='no' ) &
    3789                      'masked values', dimensions(i)%masked_values_int8(0)
    3790                   DO  j = 1, dimensions(i)%length_mask-1
    3791                      WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) &
    3792                         ',', dimensions(i)%masked_values_int8(j)
    3793                   ENDDO
    3794                   WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3795                ENDIF
    3796 
    3797             ELSEIF ( ALLOCATED( dimensions(i)%values_int16 ) )  THEN
    3798 
    3799                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) &
    3800                   'values', dimensions(i)%values_int16(dimensions(i)%bounds(1))
    3801                DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
    3802                   WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
    3803                      ',', dimensions(i)%values_int16(j)
    3804                ENDDO
    3805                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3806                IF ( is_masked )  THEN
    3807                   WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) &
    3808                      'masked values', dimensions(i)%masked_values_int16(0)
    3809                   DO  j = 1, dimensions(i)%length_mask-1
    3810                      WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
    3811                         ',', dimensions(i)%masked_values_int16(j)
    3812                   ENDDO
    3813                   WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3814                ENDIF
    3815 
    3816             ELSEIF ( ALLOCATED( dimensions(i)%values_int32 ) )  THEN
    3817 
    3818                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &
    3819                   'values', dimensions(i)%values_int32(dimensions(i)%bounds(1))
    3820                DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
    3821                   WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
    3822                      ',', dimensions(i)%values_int32(j)
    3823                ENDDO
    3824                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3825                IF ( is_masked )  THEN
    3826                   WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &
    3827                      'masked values', dimensions(i)%masked_values_int32(0)
    3828                   DO  j = 1, dimensions(i)%length_mask-1
    3829                      WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
    3830                         ',', dimensions(i)%masked_values_int32(j)
    3831                   ENDDO
    3832                   WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3833                ENDIF
    3834 
    3835             ELSEIF ( ALLOCATED( dimensions(i)%values_intwp ) )  THEN
    3836 
    3837                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &
    3838                   'values', dimensions(i)%values_intwp(dimensions(i)%bounds(1))
    3839                DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
    3840                   WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
    3841                      ',', dimensions(i)%values_intwp(j)
    3842                ENDDO
    3843                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3844                IF ( is_masked )  THEN
    3845                   WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &
    3846                      'masked values', dimensions(i)%masked_values_intwp(0)
    3847                   DO  j = 1, dimensions(i)%length_mask-1
    3848                      WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
    3849                         ',', dimensions(i)%masked_values_intwp(j)
    3850                   ENDDO
    3851                   WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3852                ENDIF
    3853 
    3854             ELSEIF ( ALLOCATED( dimensions(i)%values_real32 ) )  THEN
    3855 
    3856                WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)', ADVANCE='no' ) &
    3857                   'values', dimensions(i)%values_real32(dimensions(i)%bounds(1))
    3858                DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
    3859                   WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) &
    3860                      ',', dimensions(i)%values_real32(j)
    3861                ENDDO
    3862                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3863                IF ( is_masked )  THEN
    3864                   WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)', ADVANCE='no' ) &
    3865                      'masked values', dimensions(i)%masked_values_real32(0)
    3866                   DO  j = 1, dimensions(i)%length_mask-1
    3867                      WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) &
    3868                         ',', dimensions(i)%masked_values_real32(j)
    3869                   ENDDO
    3870                   WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3871                ENDIF
    3872 
    3873             ELSEIF ( ALLOCATED( dimensions(i)%values_real64 ) )  THEN
    3874 
    3875                WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &
    3876                   'values', dimensions(i)%values_real64(dimensions(i)%bounds(1))
    3877                DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
    3878                   WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
    3879                      ',', dimensions(i)%values_real64(j)
    3880                ENDDO
    3881                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3882                IF ( is_masked )  THEN
    3883                   WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &
    3884                      'masked values', dimensions(i)%masked_values_real64(0)
    3885                   DO  j = 1, dimensions(i)%length_mask-1
    3886                      WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
    3887                         ',', dimensions(i)%masked_values_real64(j)
    3888                   ENDDO
    3889                   WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3890                ENDIF
    3891 
    3892             ELSEIF ( ALLOCATED( dimensions(i)%values_realwp ) )  THEN
    3893 
    3894                WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &
    3895                   'values', dimensions(i)%values_realwp(dimensions(i)%bounds(1))
    3896                DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
    3897                   WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
    3898                      ',', dimensions(i)%values_realwp(j)
    3899                ENDDO
    3900                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3901                IF ( is_masked )  THEN
    3902                   WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &
    3903                      'masked values', dimensions(i)%masked_values_realwp(0)
    3904                   DO  j = 1, dimensions(i)%length_mask-1
    3905                      WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
    3906                         ',', dimensions(i)%masked_values_realwp(j)
    3907                   ENDDO
    3908                   WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3909                ENDIF
    3910 
    3911             ENDIF
    3912 
    3913             IF ( ALLOCATED( dimensions(i)%attributes ) )  &
    3914                CALL print_attributes( indent_level+1, dimensions(i)%attributes )
    3915 
    3916             IF ( i < nelement )  &
    3917                WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string
    3918          ENDDO
    3919 
    3920       END SUBROUTINE print_dimensions
    3921 
    3922       !--------------------------------------------------------------------------------------------!
    3923       ! Description:
    3924       ! ------------
    3925       !> Print list of variables.
    3926       !--------------------------------------------------------------------------------------------!
    3927       SUBROUTINE print_variables( indent_level, variables )
    3928 
    3929          CHARACTER(LEN=50) ::  write_format1  !< format for write statements
    3930          CHARACTER(LEN=50) ::  write_format2  !< format for write statements
    3931 
    3932          INTEGER             ::  i                        !< loop index
    3933          INTEGER, INTENT(IN) ::  indent_level             !< indentation level
    3934          INTEGER             ::  j                        !< loop index
    3935          INTEGER, PARAMETER  ::  max_keyname_length = 16  !< length of longest key name
    3936          INTEGER             ::  nelement                 !< number of elements to print
    3937 
    3938          TYPE(variable_type), DIMENSION(:), INTENT(IN) ::  variables  !< list of variables
    3939 
    3940 
    3941          WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
    3942          WRITE( write_format2, '(A,I3,A,I3,A)' ) &
    3943             '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
    3944             ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
    3945 
    3946          WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) &
    3947             REPEAT( separation_string // ' ', 4 )
    3948          WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'variables:'
    3949 
    3950          nelement = SIZE( variables )
    3951          DO  i = 1, nelement
    3952             WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
    3953                'name', TRIM( variables(i)%name )
    3954             WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
    3955                'type', TRIM( variables(i)%data_type )
    3956             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &
    3957                'id', variables(i)%id
    3958             WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)' ) &
    3959                'is global', variables(i)%is_global
    3960 
    3961             WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)', ADVANCE='no' ) &
    3962                'dimension names', TRIM( variables(i)%dimension_names(1) )
    3963             DO  j = 2, SIZE( variables(i)%dimension_names )
    3964                WRITE( debug_output_unit, '(A,A)', ADVANCE='no' ) &
    3965                   ',', TRIM( variables(i)%dimension_names(j) )
    3966             ENDDO
    3967             WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3968 
    3969             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)', ADVANCE='no' ) &
    3970                'dimension ids', variables(i)%dimension_ids(1)
    3971             DO  j = 2, SIZE( variables(i)%dimension_names )
    3972                WRITE( debug_output_unit, '(A,I7)', ADVANCE='no' ) &
    3973                   ',', variables(i)%dimension_ids(j)
    3974             ENDDO
    3975             WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
    3976 
    3977             IF ( ALLOCATED( variables(i)%attributes ) )  &
    3978                CALL print_attributes( indent_level+1, variables(i)%attributes )
    3979             IF ( i < nelement )  &
    3980                WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string
    3981          ENDDO
    3982 
    3983       END SUBROUTINE print_variables
    3984 
    3985 END SUBROUTINE dom_database_debug_output
    3986 
    3987 END MODULE data_output_module
     3617 SUBROUTINE dom_database_debug_output
     3618
     3619    CHARACTER(LEN=*), PARAMETER ::  separation_string = '---'                   !< string separating blocks in output
     3620    CHARACTER(LEN=50)           ::  write_format1                               !< format for write statements
     3621    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'dom_database_debug_output'  !< name of this routine
     3622
     3623    INTEGER            ::  f                       !< loop index
     3624    INTEGER, PARAMETER ::  indent_depth = 3        !< space per indentation
     3625    INTEGER            ::  indent_level            !< indentation level
     3626    INTEGER, PARAMETER ::  max_keyname_length = 6  !< length of longest key name
     3627    INTEGER            ::  natts                   !< number of attributes
     3628    INTEGER            ::  ndims                   !< number of dimensions
     3629    INTEGER            ::  nvars                   !< number of variables
     3630
     3631
     3632    CALL internal_message( 'debug', routine_name // ': write database to debug output' )
     3633
     3634    WRITE( debug_output_unit, '(A)' ) 'DOM database:'
     3635    WRITE( debug_output_unit, '(A)' ) REPEAT( separation_string // ' ', 4 )
     3636
     3637    IF ( .NOT. ALLOCATED( files ) .OR. nfiles == 0 )  THEN
     3638
     3639       WRITE( debug_output_unit, '(A)' ) 'database is empty'
     3640
     3641    ELSE
     3642
     3643       indent_level = 1
     3644       WRITE( write_format1, '(A,I3,A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A,T',  &
     3645                                         indent_level * indent_depth + 1 + max_keyname_length, &
     3646                                         ',(": ")'
     3647
     3648       DO  f = 1, nfiles
     3649
     3650          natts = 0
     3651          ndims = 0
     3652          nvars = 0
     3653          IF ( ALLOCATED( files(f)%attributes ) ) natts = SIZE( files(f)%attributes )
     3654          IF ( ALLOCATED( files(f)%dimensions ) ) ndims = SIZE( files(f)%dimensions )
     3655          IF ( ALLOCATED( files(f)%variables  ) ) nvars = SIZE( files(f)%variables  )
     3656
     3657          WRITE( debug_output_unit, '(A)' ) 'file:'
     3658          WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) 'name', TRIM( files(f)%name )
     3659          WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) 'format', TRIM(files(f)%format)
     3660          WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) 'id', files(f)%id
     3661          WRITE( debug_output_unit, TRIM( write_format1 ) // ',L1)' ) 'is init', files(f)%is_init
     3662          WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#atts', natts
     3663          WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#dims', ndims
     3664          WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#vars', nvars
     3665
     3666          IF ( natts /= 0 )  CALL print_attributes( indent_level, files(f)%attributes )
     3667          IF ( ndims /= 0 )  CALL print_dimensions( indent_level, files(f)%dimensions )
     3668          IF ( nvars /= 0 )  CALL print_variables( indent_level, files(f)%variables )
     3669
     3670          WRITE( debug_output_unit, '(/A/)' ) REPEAT( separation_string // ' ', 4 )
     3671
     3672       ENDDO
     3673
     3674    ENDIF
     3675
     3676    CONTAINS
     3677
     3678!--------------------------------------------------------------------------------------------!
     3679    ! Description:
     3680    ! ------------
     3681    !> Print list of attributes.
     3682!--------------------------------------------------------------------------------------------!
     3683    SUBROUTINE print_attributes( indent_level, attributes )
     3684
     3685       CHARACTER(LEN=50) ::  write_format1  !< format for write statements
     3686       CHARACTER(LEN=50) ::  write_format2  !< format for write statements
     3687
     3688       INTEGER             ::  i                       !< loop index
     3689       INTEGER, INTENT(IN) ::  indent_level            !< indentation level
     3690       INTEGER, PARAMETER  ::  max_keyname_length = 6  !< length of longest key name
     3691       INTEGER             ::  nelement                !< number of elements to print
     3692
     3693       TYPE(attribute_type), DIMENSION(:), INTENT(IN) ::  attributes  !< list of attributes
     3694
     3695
     3696       WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
     3697       WRITE( write_format2, '(A,I3,A,I3,A)' ) &
     3698          '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
     3699          ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
     3700
     3701       WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) &
     3702          REPEAT( separation_string // ' ', 4 )
     3703       WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'attributes:'
     3704
     3705       nelement = SIZE( attributes )
     3706       DO  i = 1, nelement
     3707          WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
     3708             'name', TRIM( attributes(i)%name )
     3709          WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
     3710             'type', TRIM( attributes(i)%data_type )
     3711
     3712          IF ( TRIM( attributes(i)%data_type ) == 'char' )  THEN
     3713             WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
     3714                'value', TRIM( attributes(i)%value_char )
     3715          ELSEIF ( TRIM( attributes(i)%data_type ) == 'int8' )  THEN
     3716             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)' ) &
     3717                'value', attributes(i)%value_int8
     3718          ELSEIF ( TRIM( attributes(i)%data_type ) == 'int16' )  THEN
     3719             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)' ) &
     3720                'value', attributes(i)%value_int16
     3721          ELSEIF ( TRIM( attributes(i)%data_type ) == 'int32' )  THEN
     3722             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)' ) &
     3723                'value', attributes(i)%value_int32
     3724          ELSEIF ( TRIM( attributes(i)%data_type ) == 'real32' )  THEN
     3725             WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)' ) &
     3726                'value', attributes(i)%value_real32
     3727          ELSEIF (  TRIM(attributes(i)%data_type) == 'real64' )  THEN
     3728             WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)' ) &
     3729                'value', attributes(i)%value_real64
     3730          ENDIF
     3731          IF ( i < nelement )  &
     3732             WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string
     3733       ENDDO
     3734
     3735    END SUBROUTINE print_attributes
     3736
     3737!--------------------------------------------------------------------------------------------!
     3738    ! Description:
     3739    ! ------------
     3740    !> Print list of dimensions.
     3741!--------------------------------------------------------------------------------------------!
     3742    SUBROUTINE print_dimensions( indent_level, dimensions )
     3743
     3744       CHARACTER(LEN=50) ::  write_format1  !< format for write statements
     3745       CHARACTER(LEN=50) ::  write_format2  !< format for write statements
     3746
     3747       INTEGER             ::  i                        !< loop index
     3748       INTEGER, INTENT(IN) ::  indent_level             !< indentation level
     3749       INTEGER             ::  j                        !< loop index
     3750       INTEGER, PARAMETER  ::  max_keyname_length = 15  !< length of longest key name
     3751       INTEGER             ::  nelement                 !< number of elements to print
     3752
     3753       LOGICAL ::  is_masked  !< true if dimension is masked
     3754
     3755       TYPE(dimension_type), DIMENSION(:), INTENT(IN) ::  dimensions  !< list of dimensions
     3756
     3757
     3758       WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
     3759       WRITE( write_format2, '(A,I3,A,I3,A)' ) &
     3760          '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
     3761          ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
     3762
     3763       WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) &
     3764          REPEAT( separation_string // ' ', 4 )
     3765       WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'dimensions:'
     3766
     3767       nelement = SIZE( dimensions )
     3768       DO  i = 1, nelement
     3769          is_masked = dimensions(i)%is_masked
     3770!
     3771!--      Print general information
     3772          WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
     3773             'name', TRIM( dimensions(i)%name )
     3774          WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
     3775             'type', TRIM( dimensions(i)%data_type )
     3776          WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &
     3777             'id', dimensions(i)%id
     3778          WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &
     3779             'length', dimensions(i)%length
     3780          WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7,A,I7)' ) &
     3781             'bounds', dimensions(i)%bounds(1), ',', dimensions(i)%bounds(2)
     3782          WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)' ) &
     3783             'is masked', dimensions(i)%is_masked
     3784!
     3785!--      Print information about mask
     3786          IF ( is_masked )  THEN
     3787             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &
     3788                'masked length', dimensions(i)%length_mask
     3789
     3790             WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)', ADVANCE='no' ) &
     3791                'mask', dimensions(i)%mask(dimensions(i)%bounds(1))
     3792             DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
     3793                WRITE( debug_output_unit, '(A,L1)', ADVANCE='no' ) ',', dimensions(i)%mask(j)
     3794             ENDDO
     3795             WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3796
     3797             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) &
     3798                'masked indices', dimensions(i)%masked_indices(0)
     3799             DO  j = 1, dimensions(i)%length_mask-1
     3800                WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
     3801                   ',', dimensions(i)%masked_indices(j)
     3802             ENDDO
     3803             WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3804          ENDIF
     3805!
     3806!--      Print saved values
     3807          IF ( ALLOCATED( dimensions(i)%values_int8 ) )  THEN
     3808
     3809             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)', ADVANCE='no' ) &
     3810                'values', dimensions(i)%values_int8(dimensions(i)%bounds(1))
     3811             DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
     3812                WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) &
     3813                   ',', dimensions(i)%values_int8(j)
     3814             ENDDO
     3815             WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3816             IF ( is_masked )  THEN
     3817                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)', ADVANCE='no' ) &
     3818                   'masked values', dimensions(i)%masked_values_int8(0)
     3819                DO  j = 1, dimensions(i)%length_mask-1
     3820                   WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) &
     3821                      ',', dimensions(i)%masked_values_int8(j)
     3822                ENDDO
     3823                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3824             ENDIF
     3825
     3826          ELSEIF ( ALLOCATED( dimensions(i)%values_int16 ) )  THEN
     3827
     3828             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) &
     3829                'values', dimensions(i)%values_int16(dimensions(i)%bounds(1))
     3830             DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
     3831                WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
     3832                   ',', dimensions(i)%values_int16(j)
     3833             ENDDO
     3834             WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3835             IF ( is_masked )  THEN
     3836                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) &
     3837                   'masked values', dimensions(i)%masked_values_int16(0)
     3838                DO  j = 1, dimensions(i)%length_mask-1
     3839                   WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
     3840                      ',', dimensions(i)%masked_values_int16(j)
     3841                ENDDO
     3842                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3843             ENDIF
     3844
     3845          ELSEIF ( ALLOCATED( dimensions(i)%values_int32 ) )  THEN
     3846
     3847             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &
     3848                'values', dimensions(i)%values_int32(dimensions(i)%bounds(1))
     3849             DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
     3850                WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
     3851                   ',', dimensions(i)%values_int32(j)
     3852             ENDDO
     3853             WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3854             IF ( is_masked )  THEN
     3855                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &
     3856                   'masked values', dimensions(i)%masked_values_int32(0)
     3857                DO  j = 1, dimensions(i)%length_mask-1
     3858                   WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
     3859                      ',', dimensions(i)%masked_values_int32(j)
     3860                ENDDO
     3861                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3862             ENDIF
     3863
     3864          ELSEIF ( ALLOCATED( dimensions(i)%values_intwp ) )  THEN
     3865
     3866             WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &
     3867                'values', dimensions(i)%values_intwp(dimensions(i)%bounds(1))
     3868             DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
     3869                WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
     3870                   ',', dimensions(i)%values_intwp(j)
     3871             ENDDO
     3872             WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3873             IF ( is_masked )  THEN
     3874                WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) &
     3875                   'masked values', dimensions(i)%masked_values_intwp(0)
     3876                DO  j = 1, dimensions(i)%length_mask-1
     3877                   WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
     3878                      ',', dimensions(i)%masked_values_intwp(j)
     3879                ENDDO
     3880                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3881             ENDIF
     3882
     3883          ELSEIF ( ALLOCATED( dimensions(i)%values_real32 ) )  THEN
     3884
     3885             WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)', ADVANCE='no' ) &
     3886                'values', dimensions(i)%values_real32(dimensions(i)%bounds(1))
     3887             DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
     3888                WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) &
     3889                   ',', dimensions(i)%values_real32(j)
     3890             ENDDO
     3891             WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3892             IF ( is_masked )  THEN
     3893                WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)', ADVANCE='no' ) &
     3894                   'masked values', dimensions(i)%masked_values_real32(0)
     3895                DO  j = 1, dimensions(i)%length_mask-1
     3896                   WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) &
     3897                      ',', dimensions(i)%masked_values_real32(j)
     3898                ENDDO
     3899                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3900             ENDIF
     3901
     3902          ELSEIF ( ALLOCATED( dimensions(i)%values_real64 ) )  THEN
     3903
     3904             WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &
     3905                'values', dimensions(i)%values_real64(dimensions(i)%bounds(1))
     3906             DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
     3907                WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
     3908                   ',', dimensions(i)%values_real64(j)
     3909             ENDDO
     3910             WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3911             IF ( is_masked )  THEN
     3912                WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &
     3913                   'masked values', dimensions(i)%masked_values_real64(0)
     3914                DO  j = 1, dimensions(i)%length_mask-1
     3915                   WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
     3916                      ',', dimensions(i)%masked_values_real64(j)
     3917                ENDDO
     3918                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3919             ENDIF
     3920
     3921          ELSEIF ( ALLOCATED( dimensions(i)%values_realwp ) )  THEN
     3922
     3923             WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &
     3924                'values', dimensions(i)%values_realwp(dimensions(i)%bounds(1))
     3925             DO  j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
     3926                WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
     3927                   ',', dimensions(i)%values_realwp(j)
     3928             ENDDO
     3929             WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3930             IF ( is_masked )  THEN
     3931                WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) &
     3932                   'masked values', dimensions(i)%masked_values_realwp(0)
     3933                DO  j = 1, dimensions(i)%length_mask-1
     3934                   WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
     3935                      ',', dimensions(i)%masked_values_realwp(j)
     3936                ENDDO
     3937                WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3938             ENDIF
     3939
     3940          ENDIF
     3941
     3942          IF ( ALLOCATED( dimensions(i)%attributes ) )  &
     3943             CALL print_attributes( indent_level+1, dimensions(i)%attributes )
     3944
     3945          IF ( i < nelement )  &
     3946             WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string
     3947       ENDDO
     3948
     3949    END SUBROUTINE print_dimensions
     3950
     3951!--------------------------------------------------------------------------------------------!
     3952    ! Description:
     3953    ! ------------
     3954    !> Print list of variables.
     3955!--------------------------------------------------------------------------------------------!
     3956    SUBROUTINE print_variables( indent_level, variables )
     3957
     3958       CHARACTER(LEN=50) ::  write_format1  !< format for write statements
     3959       CHARACTER(LEN=50) ::  write_format2  !< format for write statements
     3960
     3961       INTEGER             ::  i                        !< loop index
     3962       INTEGER, INTENT(IN) ::  indent_level             !< indentation level
     3963       INTEGER             ::  j                        !< loop index
     3964       INTEGER, PARAMETER  ::  max_keyname_length = 16  !< length of longest key name
     3965       INTEGER             ::  nelement                 !< number of elements to print
     3966
     3967       TYPE(variable_type), DIMENSION(:), INTENT(IN) ::  variables  !< list of variables
     3968
     3969
     3970       WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
     3971       WRITE( write_format2, '(A,I3,A,I3,A)' ) &
     3972          '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
     3973          ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
     3974
     3975       WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) &
     3976          REPEAT( separation_string // ' ', 4 )
     3977       WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'variables:'
     3978
     3979       nelement = SIZE( variables )
     3980       DO  i = 1, nelement
     3981          WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
     3982             'name', TRIM( variables(i)%name )
     3983          WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) &
     3984             'type', TRIM( variables(i)%data_type )
     3985          WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) &
     3986             'id', variables(i)%id
     3987          WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)' ) &
     3988             'is global', variables(i)%is_global
     3989
     3990          WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)', ADVANCE='no' ) &
     3991             'dimension names', TRIM( variables(i)%dimension_names(1) )
     3992          DO  j = 2, SIZE( variables(i)%dimension_names )
     3993             WRITE( debug_output_unit, '(A,A)', ADVANCE='no' ) &
     3994                ',', TRIM( variables(i)%dimension_names(j) )
     3995          ENDDO
     3996          WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     3997
     3998          WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)', ADVANCE='no' ) &
     3999             'dimension ids', variables(i)%dimension_ids(1)
     4000          DO  j = 2, SIZE( variables(i)%dimension_names )
     4001             WRITE( debug_output_unit, '(A,I7)', ADVANCE='no' ) &
     4002                ',', variables(i)%dimension_ids(j)
     4003          ENDDO
     4004          WRITE( debug_output_unit, '(A)' )  ''  ! write line-end
     4005
     4006          IF ( ALLOCATED( variables(i)%attributes ) )  &
     4007             CALL print_attributes( indent_level+1, variables(i)%attributes )
     4008          IF ( i < nelement )  &
     4009             WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string
     4010       ENDDO
     4011
     4012    END SUBROUTINE print_variables
     4013
     4014 END SUBROUTINE dom_database_debug_output
     4015
     4016 END MODULE data_output_module
  • palm/trunk/SOURCE/data_output_netcdf4_module.f90

    r4141 r4147  
    2525! -----------------
    2626! $Id$
     27! corrected indentation according to coding standard
     28!
     29! 4141 2019-08-05 12:24:51Z gronemeier
    2730! Initial revision
    2831!
     
    3740!> This is either done in parallel mode via parallel NetCDF4 I/O or in serial mode only by PE0.
    3841!--------------------------------------------------------------------------------------------------!
    39 MODULE data_output_netcdf4_module
    40 
    41    USE kinds
     42 MODULE data_output_netcdf4_module
     43
     44    USE kinds
    4245
    4346#if defined( __parallel )
    4447#if defined( __mpifh )
    45    INCLUDE "mpif.h"
    46 #else
    47    USE MPI
    48 #endif
    49 #endif
    50 
    51 #if defined( __netcdf4 )
    52    USE NETCDF
    53 #endif
    54 
    55    IMPLICIT NONE
    56 
    57    CHARACTER(LEN=800) ::  internal_error_message = ''  !< string containing the last error message
    58    CHARACTER(LEN=100) ::  file_suffix = ''             !< file suffix added to each file name
    59    CHARACTER(LEN=800) ::  temp_string                  !< dummy string
    60 
    61    CHARACTER(LEN=*), PARAMETER ::  mode_parallel = 'parallel'  !< string selecting netcdf4 parallel mode
    62    CHARACTER(LEN=*), PARAMETER ::  mode_serial   = 'serial'    !< string selecting netcdf4 serial mode
    63 
    64    INTEGER ::  debug_output_unit       !< Fortran Unit Number of the debug-output file
    65    INTEGER ::  global_id_in_file = -1  !< value of global ID within a file
    66    INTEGER ::  master_rank             !< master rank for tasks to be executed by single PE only
    67    INTEGER ::  output_group_comm       !< MPI communicator addressing all MPI ranks which participate in output
    68 
    69    LOGICAL ::  print_debug_output = .FALSE.  !< if true, debug output is printed
    70 
    71    SAVE
    72 
    73    PRIVATE
    74 
    75    INTERFACE netcdf4_init_module
    76       MODULE PROCEDURE netcdf4_init_module
    77    END INTERFACE netcdf4_init_module
    78 
    79    INTERFACE netcdf4_open_file
    80       MODULE PROCEDURE netcdf4_open_file
    81    END INTERFACE netcdf4_open_file
    82 
    83    INTERFACE netcdf4_init_dimension
    84       MODULE PROCEDURE netcdf4_init_dimension
    85    END INTERFACE netcdf4_init_dimension
    86 
    87    INTERFACE netcdf4_init_variable
    88       MODULE PROCEDURE netcdf4_init_variable
    89    END INTERFACE netcdf4_init_variable
    90 
    91    INTERFACE netcdf4_write_attribute
    92       MODULE PROCEDURE netcdf4_write_attribute
    93    END INTERFACE netcdf4_write_attribute
    94 
    95    INTERFACE netcdf4_stop_file_header_definition
    96       MODULE PROCEDURE netcdf4_stop_file_header_definition
    97    END INTERFACE netcdf4_stop_file_header_definition
    98 
    99    INTERFACE netcdf4_write_variable
    100       MODULE PROCEDURE netcdf4_write_variable
    101    END INTERFACE netcdf4_write_variable
    102 
    103    INTERFACE netcdf4_finalize
    104       MODULE PROCEDURE netcdf4_finalize
    105    END INTERFACE netcdf4_finalize
    106 
    107    INTERFACE netcdf4_get_error_message
    108       MODULE PROCEDURE netcdf4_get_error_message
    109    END INTERFACE netcdf4_get_error_message
    110 
    111    PUBLIC &
    112       netcdf4_finalize, &
    113       netcdf4_get_error_message, &
    114       netcdf4_init_dimension, &
    115       netcdf4_stop_file_header_definition, &
    116       netcdf4_init_module, &
    117       netcdf4_init_variable, &
    118       netcdf4_open_file, &
    119       netcdf4_write_attribute, &
    120       netcdf4_write_variable
    121 
    122 
    123 CONTAINS
     48    INCLUDE "mpif.h"
     49#else
     50    USE MPI
     51#endif
     52#endif
     53
     54#if defined( __netcdf4 )
     55    USE NETCDF
     56#endif
     57
     58    IMPLICIT NONE
     59
     60    CHARACTER(LEN=800) ::  internal_error_message = ''  !< string containing the last error message
     61    CHARACTER(LEN=100) ::  file_suffix = ''             !< file suffix added to each file name
     62    CHARACTER(LEN=800) ::  temp_string                  !< dummy string
     63
     64    CHARACTER(LEN=*), PARAMETER ::  mode_parallel = 'parallel'  !< string selecting netcdf4 parallel mode
     65    CHARACTER(LEN=*), PARAMETER ::  mode_serial   = 'serial'    !< string selecting netcdf4 serial mode
     66
     67    INTEGER ::  debug_output_unit       !< Fortran Unit Number of the debug-output file
     68    INTEGER ::  global_id_in_file = -1  !< value of global ID within a file
     69    INTEGER ::  master_rank             !< master rank for tasks to be executed by single PE only
     70    INTEGER ::  output_group_comm       !< MPI communicator addressing all MPI ranks which participate in output
     71
     72    LOGICAL ::  print_debug_output = .FALSE.  !< if true, debug output is printed
     73
     74    SAVE
     75
     76    PRIVATE
     77
     78    INTERFACE netcdf4_init_module
     79       MODULE PROCEDURE netcdf4_init_module
     80    END INTERFACE netcdf4_init_module
     81
     82    INTERFACE netcdf4_open_file
     83       MODULE PROCEDURE netcdf4_open_file
     84    END INTERFACE netcdf4_open_file
     85
     86    INTERFACE netcdf4_init_dimension
     87       MODULE PROCEDURE netcdf4_init_dimension
     88    END INTERFACE netcdf4_init_dimension
     89
     90    INTERFACE netcdf4_init_variable
     91       MODULE PROCEDURE netcdf4_init_variable
     92    END INTERFACE netcdf4_init_variable
     93
     94    INTERFACE netcdf4_write_attribute
     95       MODULE PROCEDURE netcdf4_write_attribute
     96    END INTERFACE netcdf4_write_attribute
     97
     98    INTERFACE netcdf4_stop_file_header_definition
     99       MODULE PROCEDURE netcdf4_stop_file_header_definition
     100    END INTERFACE netcdf4_stop_file_header_definition
     101
     102    INTERFACE netcdf4_write_variable
     103       MODULE PROCEDURE netcdf4_write_variable
     104    END INTERFACE netcdf4_write_variable
     105
     106    INTERFACE netcdf4_finalize
     107       MODULE PROCEDURE netcdf4_finalize
     108    END INTERFACE netcdf4_finalize
     109
     110    INTERFACE netcdf4_get_error_message
     111       MODULE PROCEDURE netcdf4_get_error_message
     112    END INTERFACE netcdf4_get_error_message
     113
     114    PUBLIC &
     115       netcdf4_finalize, &
     116       netcdf4_get_error_message, &
     117       netcdf4_init_dimension, &
     118       netcdf4_stop_file_header_definition, &
     119       netcdf4_init_module, &
     120       netcdf4_init_variable, &
     121       netcdf4_open_file, &
     122       netcdf4_write_attribute, &
     123       netcdf4_write_variable
     124
     125
     126 CONTAINS
    124127
    125128
     
    129132!> Initialize data-output module.
    130133!--------------------------------------------------------------------------------------------------!
    131 SUBROUTINE netcdf4_init_module( file_suffix_of_output_group, mpi_comm_of_output_group, &
    132                                 master_output_rank,                                    &
    133                                 program_debug_output_unit, debug_output, dom_global_id )
    134 
    135    CHARACTER(LEN=*), INTENT(IN) ::  file_suffix_of_output_group  !> file-name suffix added to each file;
    136                                                                  !> must be unique for each output group
    137 
    138    INTEGER, INTENT(IN) ::  dom_global_id              !< global id within a file defined by DOM
    139    INTEGER, INTENT(IN) ::  master_output_rank         !< MPI rank executing tasks which must be executed by a single PE
    140    INTEGER, INTENT(IN) ::  mpi_comm_of_output_group   !< MPI communicator specifying the rank group participating in output
    141    INTEGER, INTENT(IN) ::  program_debug_output_unit  !< file unit number for debug output
    142 
    143    LOGICAL, INTENT(IN) ::  debug_output  !< if true, debug output is printed
    144 
    145 
    146    file_suffix = file_suffix_of_output_group
    147    output_group_comm = mpi_comm_of_output_group
    148    master_rank = master_output_rank
    149 
    150    debug_output_unit = program_debug_output_unit
    151    print_debug_output = debug_output
    152 
    153    global_id_in_file = dom_global_id
    154 
    155 END SUBROUTINE netcdf4_init_module
     134 SUBROUTINE netcdf4_init_module( file_suffix_of_output_group, mpi_comm_of_output_group, &
     135                                 master_output_rank,                                    &
     136                                 program_debug_output_unit, debug_output, dom_global_id )
     137
     138    CHARACTER(LEN=*), INTENT(IN) ::  file_suffix_of_output_group  !> file-name suffix added to each file;
     139                                                                  !> must be unique for each output group
     140
     141    INTEGER, INTENT(IN) ::  dom_global_id              !< global id within a file defined by DOM
     142    INTEGER, INTENT(IN) ::  master_output_rank         !< MPI rank executing tasks which must be executed by a single PE
     143    INTEGER, INTENT(IN) ::  mpi_comm_of_output_group   !< MPI communicator specifying the rank group participating in output
     144    INTEGER, INTENT(IN) ::  program_debug_output_unit  !< file unit number for debug output
     145
     146    LOGICAL, INTENT(IN) ::  debug_output  !< if true, debug output is printed
     147
     148
     149    file_suffix = file_suffix_of_output_group
     150    output_group_comm = mpi_comm_of_output_group
     151    master_rank = master_output_rank
     152
     153    debug_output_unit = program_debug_output_unit
     154    print_debug_output = debug_output
     155
     156    global_id_in_file = dom_global_id
     157
     158 END SUBROUTINE netcdf4_init_module
    156159
    157160!--------------------------------------------------------------------------------------------------!
     
    160163!> Open netcdf file.
    161164!--------------------------------------------------------------------------------------------------!
    162 SUBROUTINE netcdf4_open_file( mode, file_name, file_id, return_value )
    163 
    164    CHARACTER(LEN=*), INTENT(IN) ::  file_name  !< name of file
    165    CHARACTER(LEN=*), INTENT(IN) ::  mode       !< operation mode (either parallel or serial)
    166 
    167    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_open_file'  !< name of this routine
    168 
    169    INTEGER, INTENT(OUT) ::  file_id       !< file ID
    170    INTEGER              ::  my_rank       !< MPI rank of processor
    171    INTEGER              ::  nc_stat       !< netcdf return value
    172    INTEGER, INTENT(OUT) ::  return_value  !< return value
    173 
    174 
    175    return_value = 0
    176    file_id = -1
    177 
    178    !-- Open new file
    179    CALL internal_message( 'debug', routine_name // ': create file "' // TRIM( file_name ) // '"' )
    180 
    181    IF ( TRIM( mode ) == mode_serial )  THEN
     165 SUBROUTINE netcdf4_open_file( mode, file_name, file_id, return_value )
     166
     167    CHARACTER(LEN=*), INTENT(IN) ::  file_name  !< name of file
     168    CHARACTER(LEN=*), INTENT(IN) ::  mode       !< operation mode (either parallel or serial)
     169
     170    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_open_file'  !< name of this routine
     171
     172    INTEGER, INTENT(OUT) ::  file_id       !< file ID
     173    INTEGER              ::  my_rank       !< MPI rank of processor
     174    INTEGER              ::  nc_stat       !< netcdf return value
     175    INTEGER, INTENT(OUT) ::  return_value  !< return value
     176
     177
     178    return_value = 0
     179    file_id = -1
     180!
     181!-- Open new file
     182    CALL internal_message( 'debug', routine_name // ': create file "' // TRIM( file_name ) // '"' )
     183
     184    IF ( TRIM( mode ) == mode_serial )  THEN
    182185
    183186#if defined( __netcdf4 )
    184187#if defined( __parallel )
    185       CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
    186       IF ( return_value /= 0 )  THEN
    187          CALL internal_message( 'error', routine_name // ': MPI_COMM_RANK error' )
    188       ENDIF
    189       IF ( my_rank /= master_rank )  THEN
    190          return_value = 1
    191          CALL internal_message( 'error', routine_name // &
    192                                 ': trying to define a NetCDF file in serial mode by an MPI ' // &
    193                                 'rank other than the master output rank. Serial NetCDF ' // &
    194                                 'files can only be defined by the master output rank!' )
    195       ENDIF
    196 #else
    197       my_rank = master_rank
    198       return_value = 0
    199 #endif
    200 
    201       IF ( return_value == 0 )  &
    202          nc_stat = NF90_CREATE( TRIM( file_name ) // TRIM( file_suffix ), &
    203                                 IOR( NF90_NOCLOBBER, NF90_NETCDF4 ),      &
    204                                 file_id )
    205 #else
    206       nc_stat = 0
    207       return_value = 1
    208       CALL internal_message( 'error', routine_name //                               &
    209                              ': pre-processor directive "__netcdf4" not given. ' // &
    210                              'Using NetCDF4 output not possible' )
    211 #endif
    212 
    213    ELSEIF ( TRIM( mode ) == mode_parallel )  THEN
     188       CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
     189       IF ( return_value /= 0 )  THEN
     190          CALL internal_message( 'error', routine_name // ': MPI_COMM_RANK error' )
     191       ENDIF
     192       IF ( my_rank /= master_rank )  THEN
     193          return_value = 1
     194          CALL internal_message( 'error', routine_name // &
     195                                 ': trying to define a NetCDF file in serial mode by an MPI ' // &
     196                                 'rank other than the master output rank. Serial NetCDF ' // &
     197                                 'files can only be defined by the master output rank!' )
     198       ENDIF
     199#else
     200       my_rank = master_rank
     201       return_value = 0
     202#endif
     203
     204       IF ( return_value == 0 )  &
     205          nc_stat = NF90_CREATE( TRIM( file_name ) // TRIM( file_suffix ), &
     206                                 IOR( NF90_NOCLOBBER, NF90_NETCDF4 ),      &
     207                                 file_id )
     208#else
     209       nc_stat = 0
     210       return_value = 1
     211       CALL internal_message( 'error', routine_name //                               &
     212                              ': pre-processor directive "__netcdf4" not given. ' // &
     213                              'Using NetCDF4 output not possible' )
     214#endif
     215
     216    ELSEIF ( TRIM( mode ) == mode_parallel )  THEN
    214217
    215218#if defined( __parallel ) && defined( __netcdf4 ) && defined( __netcdf4_parallel )
    216       nc_stat = NF90_CREATE( TRIM( file_name ) // TRIM( file_suffix ),               &
    217                              IOR( NF90_NOCLOBBER, IOR( NF90_NETCDF4, NF90_MPIIO ) ), &
    218                              file_id, COMM = output_group_comm, INFO = MPI_INFO_NULL )
    219 #else
    220       nc_stat = 0
    221       return_value = 1
    222       CALL internal_message( 'error', routine_name //                                 &
    223                              ': pre-processor directives "__parallel" and/or ' //     &
    224                              '"__netcdf4" and/or "__netcdf4_parallel" not given. ' // &
    225                              'Using parallel NetCDF4 output not possible' )
    226 #endif
    227 
    228    ELSE
    229       nc_stat = 0
    230       return_value = 1
    231       CALL internal_message( 'error', routine_name // ': selected mode "' //  &
    232                                       TRIM( mode ) // '" must be either "' // &
    233                                       mode_serial // '" or "' // mode_parallel // '"' )
    234    ENDIF
    235 
    236 #if defined( __netcdf4 )
    237    IF ( nc_stat /= NF90_NOERR  .AND.  return_value == 0 )  THEN
    238       return_value = 1
    239       CALL internal_message( 'error', routine_name //                 &
    240                              ': NetCDF error while opening file "' // &
    241                              TRIM( file_name ) // '": ' // NF90_STRERROR( nc_stat ) )
    242    ENDIF
    243 #endif
    244 
    245 END SUBROUTINE netcdf4_open_file
     219       nc_stat = NF90_CREATE( TRIM( file_name ) // TRIM( file_suffix ),               &
     220                              IOR( NF90_NOCLOBBER, IOR( NF90_NETCDF4, NF90_MPIIO ) ), &
     221                              file_id, COMM = output_group_comm, INFO = MPI_INFO_NULL )
     222#else
     223       nc_stat = 0
     224       return_value = 1
     225       CALL internal_message( 'error', routine_name //                                 &
     226                              ': pre-processor directives "__parallel" and/or ' //     &
     227                              '"__netcdf4" and/or "__netcdf4_parallel" not given. ' // &
     228                              'Using parallel NetCDF4 output not possible' )
     229#endif
     230
     231    ELSE
     232       nc_stat = 0
     233       return_value = 1
     234       CALL internal_message( 'error', routine_name // ': selected mode "' //  &
     235                                       TRIM( mode ) // '" must be either "' // &
     236                                       mode_serial // '" or "' // mode_parallel // '"' )
     237    ENDIF
     238
     239#if defined( __netcdf4 )
     240    IF ( nc_stat /= NF90_NOERR  .AND.  return_value == 0 )  THEN
     241       return_value = 1
     242       CALL internal_message( 'error', routine_name //                 &
     243                              ': NetCDF error while opening file "' // &
     244                              TRIM( file_name ) // '": ' // NF90_STRERROR( nc_stat ) )
     245    ENDIF
     246#endif
     247
     248 END SUBROUTINE netcdf4_open_file
    246249
    247250!--------------------------------------------------------------------------------------------------!
     
    250253!> Write attribute to netcdf file.
    251254!--------------------------------------------------------------------------------------------------!
    252 SUBROUTINE netcdf4_write_attribute( file_id, variable_id, attribute_name, &
    253                  value_char, value_int8, value_int16, value_int32,        &
    254                  value_real32, value_real64, return_value )
    255 
    256    CHARACTER(LEN=*), INTENT(IN)           ::  attribute_name  !< name of attribute
    257    CHARACTER(LEN=*), INTENT(IN), OPTIONAL ::  value_char      !< value of attribute
    258 
    259    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_write_attribute'  !< name of this routine
    260 
    261    INTEGER ::  nc_stat    !< netcdf return value
    262    INTEGER ::  target_id  !< ID of target which gets attribute (either global or variable_id)
    263 
    264    INTEGER, INTENT(IN)  ::  file_id       !< file ID
    265    INTEGER, INTENT(OUT) ::  return_value  !< return value
    266    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
    267 
    268    INTEGER(KIND=1), INTENT(IN), OPTIONAL ::  value_int8   !< value of attribute
    269    INTEGER(KIND=2), INTENT(IN), OPTIONAL ::  value_int16  !< value of attribute
    270    INTEGER(KIND=4), INTENT(IN), OPTIONAL ::  value_int32  !< value of attribute
    271 
    272    REAL(KIND=4), INTENT(IN), OPTIONAL ::  value_real32  !< value of attribute
    273    REAL(KIND=8), INTENT(IN), OPTIONAL ::  value_real64  !< value of attribute
    274 
    275 
    276 #if defined( __netcdf4 )
    277    return_value = 0
    278 
    279    IF ( variable_id == global_id_in_file )  THEN
    280       target_id = NF90_GLOBAL
    281    ELSE
    282       target_id = variable_id
    283    ENDIF
    284 
    285    CALL internal_message( 'debug', routine_name // &
    286                           ': write attribute "' // TRIM( attribute_name ) // '"' )
    287 
    288    IF ( PRESENT( value_char ) )  THEN
    289       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), TRIM( value_char ) )
    290    ELSEIF ( PRESENT( value_int8 ) )  THEN
    291       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int8 )
    292    ELSEIF ( PRESENT( value_int16 ) )  THEN
    293       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int16 )
    294    ELSEIF ( PRESENT( value_int32 ) )  THEN
    295       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int32 )
    296    ELSEIF ( PRESENT( value_real32 ) )  THEN
    297       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_real32 )
    298    ELSEIF ( PRESENT( value_real64 ) )  THEN
    299       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_real64 )
    300    ELSE
    301       return_value = 1
    302       CALL internal_message( 'error', routine_name // &
    303                              ': no value given for attribute "' // TRIM( attribute_name ) // '"' )
    304    ENDIF
    305 
    306    IF ( return_value == 0 )  THEN
    307       IF ( nc_stat /= NF90_NOERR )  THEN
    308          return_value = 1
    309          CALL internal_message( 'error', routine_name //                      &
    310                                 ': NetCDF error while writing attribute "' // &
    311                                 TRIM( attribute_name ) // '": ' // NF90_STRERROR( nc_stat ) )
    312       ENDIF
    313    ENDIF
    314 #else
    315    return_value = 1
    316 #endif
    317 
    318 END SUBROUTINE netcdf4_write_attribute
     255 SUBROUTINE netcdf4_write_attribute( file_id, variable_id, attribute_name, &
     256                  value_char, value_int8, value_int16, value_int32,        &
     257                  value_real32, value_real64, return_value )
     258
     259    CHARACTER(LEN=*), INTENT(IN)           ::  attribute_name  !< name of attribute
     260    CHARACTER(LEN=*), INTENT(IN), OPTIONAL ::  value_char      !< value of attribute
     261
     262    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_write_attribute'  !< name of this routine
     263
     264    INTEGER ::  nc_stat    !< netcdf return value
     265    INTEGER ::  target_id  !< ID of target which gets attribute (either global or variable_id)
     266
     267    INTEGER, INTENT(IN)  ::  file_id       !< file ID
     268    INTEGER, INTENT(OUT) ::  return_value  !< return value
     269    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
     270
     271    INTEGER(KIND=1), INTENT(IN), OPTIONAL ::  value_int8   !< value of attribute
     272    INTEGER(KIND=2), INTENT(IN), OPTIONAL ::  value_int16  !< value of attribute
     273    INTEGER(KIND=4), INTENT(IN), OPTIONAL ::  value_int32  !< value of attribute
     274
     275    REAL(KIND=4), INTENT(IN), OPTIONAL ::  value_real32  !< value of attribute
     276    REAL(KIND=8), INTENT(IN), OPTIONAL ::  value_real64  !< value of attribute
     277
     278
     279#if defined( __netcdf4 )
     280    return_value = 0
     281
     282    IF ( variable_id == global_id_in_file )  THEN
     283       target_id = NF90_GLOBAL
     284    ELSE
     285       target_id = variable_id
     286    ENDIF
     287
     288    CALL internal_message( 'debug', routine_name // &
     289                           ': write attribute "' // TRIM( attribute_name ) // '"' )
     290
     291    IF ( PRESENT( value_char ) )  THEN
     292       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), TRIM( value_char ) )
     293    ELSEIF ( PRESENT( value_int8 ) )  THEN
     294       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int8 )
     295    ELSEIF ( PRESENT( value_int16 ) )  THEN
     296       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int16 )
     297    ELSEIF ( PRESENT( value_int32 ) )  THEN
     298       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int32 )
     299    ELSEIF ( PRESENT( value_real32 ) )  THEN
     300       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_real32 )
     301    ELSEIF ( PRESENT( value_real64 ) )  THEN
     302       nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_real64 )
     303    ELSE
     304       return_value = 1
     305       CALL internal_message( 'error', routine_name // &
     306                              ': no value given for attribute "' // TRIM( attribute_name ) // '"' )
     307    ENDIF
     308
     309    IF ( return_value == 0 )  THEN
     310       IF ( nc_stat /= NF90_NOERR )  THEN
     311          return_value = 1
     312          CALL internal_message( 'error', routine_name //                      &
     313                                 ': NetCDF error while writing attribute "' // &
     314                                 TRIM( attribute_name ) // '": ' // NF90_STRERROR( nc_stat ) )
     315       ENDIF
     316    ENDIF
     317#else
     318    return_value = 1
     319#endif
     320
     321 END SUBROUTINE netcdf4_write_attribute
    319322
    320323!--------------------------------------------------------------------------------------------------!
     
    323326!> Initialize dimension.
    324327!--------------------------------------------------------------------------------------------------!
    325 SUBROUTINE netcdf4_init_dimension( mode, file_id, dimension_id, variable_id, &
    326               dimension_name, dimension_type, dimension_length, return_value )
    327 
    328    CHARACTER(LEN=*), INTENT(IN) ::  dimension_name  !< name of dimension
    329    CHARACTER(LEN=*), INTENT(IN) ::  dimension_type  !< data type of dimension
    330    CHARACTER(LEN=*), INTENT(IN) ::  mode            !< operation mode (either parallel or serial)
    331 
    332    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_init_dimension'  !< name of this routine
    333 
    334    INTEGER, INTENT(OUT) ::  dimension_id         !< dimension ID
    335    INTEGER, INTENT(IN)  ::  dimension_length     !< length of dimension
    336    INTEGER, INTENT(IN)  ::  file_id              !< file ID
    337    INTEGER              ::  nc_dimension_length  !< length of dimension
    338    INTEGER              ::  nc_stat              !< netcdf return value
    339    INTEGER, INTENT(OUT) ::  return_value         !< return value
    340    INTEGER, INTENT(OUT) ::  variable_id          !< variable ID
    341 
    342 
    343 #if defined( __netcdf4 )
    344    return_value = 0
    345    variable_id = -1
    346 
    347    CALL internal_message( 'debug', routine_name // &
    348                           ': init dimension "' // TRIM( dimension_name ) // '"' )
    349 
    350    !-- Check if dimension is unlimited
    351    IF ( dimension_length < 0 )  THEN
    352       nc_dimension_length = NF90_UNLIMITED
    353    ELSE
    354       nc_dimension_length = dimension_length
    355    ENDIF
    356 
    357    !-- Define dimension in file
    358    nc_stat = NF90_DEF_DIM( file_id, dimension_name, nc_dimension_length, dimension_id )
    359 
    360    IF ( nc_stat == NF90_NOERR )  THEN
    361 
    362       !-- Define variable holding dimension values in file
    363       CALL netcdf4_init_variable( mode, file_id, variable_id, dimension_name, dimension_type, &
    364                                   (/ dimension_id /), is_global=.TRUE., return_value=return_value )
    365 
    366    ELSE
    367       return_value = 1
    368       CALL internal_message( 'error', routine_name //                           &
    369                              ': NetCDF error while initializing dimension "' // &
    370                              TRIM( dimension_name ) // '": ' // NF90_STRERROR( nc_stat ) )
    371    ENDIF
    372 #else
    373    return_value = 1
    374    variable_id = -1
    375    dimension_id = -1
    376 #endif
    377 
    378 END SUBROUTINE netcdf4_init_dimension
     328 SUBROUTINE netcdf4_init_dimension( mode, file_id, dimension_id, variable_id, &
     329               dimension_name, dimension_type, dimension_length, return_value )
     330
     331    CHARACTER(LEN=*), INTENT(IN) ::  dimension_name  !< name of dimension
     332    CHARACTER(LEN=*), INTENT(IN) ::  dimension_type  !< data type of dimension
     333    CHARACTER(LEN=*), INTENT(IN) ::  mode            !< operation mode (either parallel or serial)
     334
     335    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_init_dimension'  !< name of this routine
     336
     337    INTEGER, INTENT(OUT) ::  dimension_id         !< dimension ID
     338    INTEGER, INTENT(IN)  ::  dimension_length     !< length of dimension
     339    INTEGER, INTENT(IN)  ::  file_id              !< file ID
     340    INTEGER              ::  nc_dimension_length  !< length of dimension
     341    INTEGER              ::  nc_stat              !< netcdf return value
     342    INTEGER, INTENT(OUT) ::  return_value         !< return value
     343    INTEGER, INTENT(OUT) ::  variable_id          !< variable ID
     344
     345
     346#if defined( __netcdf4 )
     347    return_value = 0
     348    variable_id = -1
     349
     350    CALL internal_message( 'debug', routine_name // &
     351                           ': init dimension "' // TRIM( dimension_name ) // '"' )
     352!
     353!-- Check if dimension is unlimited
     354    IF ( dimension_length < 0 )  THEN
     355       nc_dimension_length = NF90_UNLIMITED
     356    ELSE
     357       nc_dimension_length = dimension_length
     358    ENDIF
     359!
     360!-- Define dimension in file
     361    nc_stat = NF90_DEF_DIM( file_id, dimension_name, nc_dimension_length, dimension_id )
     362
     363    IF ( nc_stat == NF90_NOERR )  THEN
     364!
     365!--    Define variable holding dimension values in file
     366       CALL netcdf4_init_variable( mode, file_id, variable_id, dimension_name, dimension_type, &
     367                                   (/ dimension_id /), is_global=.TRUE., return_value=return_value )
     368
     369    ELSE
     370       return_value = 1
     371       CALL internal_message( 'error', routine_name //                           &
     372                              ': NetCDF error while initializing dimension "' // &
     373                              TRIM( dimension_name ) // '": ' // NF90_STRERROR( nc_stat ) )
     374    ENDIF
     375#else
     376    return_value = 1
     377    variable_id = -1
     378    dimension_id = -1
     379#endif
     380
     381 END SUBROUTINE netcdf4_init_dimension
    379382
    380383!--------------------------------------------------------------------------------------------------!
     
    383386!> Initialize variable.
    384387!--------------------------------------------------------------------------------------------------!
    385 SUBROUTINE netcdf4_init_variable( mode, file_id, variable_id, variable_name, variable_type, &
    386                                   dimension_ids, is_global, return_value )
    387 
    388    CHARACTER(LEN=*), INTENT(IN) ::  mode           !< operation mode (either parallel or serial)
    389    CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
    390    CHARACTER(LEN=*), INTENT(IN) ::  variable_type  !< data type of variable
    391 
    392    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_init_variable'  !< name of this routine
    393 
    394    INTEGER, INTENT(IN)  ::  file_id           !< file ID
    395    INTEGER              ::  nc_stat           !< netcdf return value
    396    INTEGER              ::  nc_variable_type  !< netcdf data type
    397    INTEGER, INTENT(OUT) ::  return_value      !< return value
    398    INTEGER, INTENT(OUT) ::  variable_id       !< variable ID
    399 
    400    INTEGER, DIMENSION(:), INTENT(IN) ::  dimension_ids  !< list of dimension IDs used by variable
    401 
    402    LOGICAL, INTENT(IN)  ::  is_global  !< true if variable is global (same on all PE)
    403 
    404 
    405 #if defined( __netcdf4 )
    406    return_value = 0
    407 
    408    WRITE( temp_string, * ) is_global
    409    CALL internal_message( 'debug', routine_name //                        &
    410                           ': init variable "' // TRIM( variable_name ) // &
    411                           '" ( is_global = ' // TRIM( temp_string ) // ')' )
    412 
    413    nc_variable_type = get_netcdf_data_type( variable_type )
    414 
    415    IF ( nc_variable_type /= -1 )  THEN
    416 
    417       !-- Define variable in file
    418       nc_stat = NF90_DEF_VAR( file_id, variable_name, nc_variable_type, dimension_ids, variable_id )
     388 SUBROUTINE netcdf4_init_variable( mode, file_id, variable_id, variable_name, variable_type, &
     389                                   dimension_ids, is_global, return_value )
     390
     391    CHARACTER(LEN=*), INTENT(IN) ::  mode           !< operation mode (either parallel or serial)
     392    CHARACTER(LEN=*), INTENT(IN) ::  variable_name  !< name of variable
     393    CHARACTER(LEN=*), INTENT(IN) ::  variable_type  !< data type of variable
     394
     395    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_init_variable'  !< name of this routine
     396
     397    INTEGER, INTENT(IN)  ::  file_id           !< file ID
     398    INTEGER              ::  nc_stat           !< netcdf return value
     399    INTEGER              ::  nc_variable_type  !< netcdf data type
     400    INTEGER, INTENT(OUT) ::  return_value      !< return value
     401    INTEGER, INTENT(OUT) ::  variable_id       !< variable ID
     402
     403    INTEGER, DIMENSION(:), INTENT(IN) ::  dimension_ids  !< list of dimension IDs used by variable
     404
     405    LOGICAL, INTENT(IN)  ::  is_global  !< true if variable is global (same on all PE)
     406
     407
     408#if defined( __netcdf4 )
     409    return_value = 0
     410
     411    WRITE( temp_string, * ) is_global
     412    CALL internal_message( 'debug', routine_name //                        &
     413                           ': init variable "' // TRIM( variable_name ) // &
     414                           '" ( is_global = ' // TRIM( temp_string ) // ')' )
     415
     416    nc_variable_type = get_netcdf_data_type( variable_type )
     417
     418    IF ( nc_variable_type /= -1 )  THEN
     419!
     420!--    Define variable in file
     421       nc_stat = NF90_DEF_VAR( file_id, variable_name, nc_variable_type, dimension_ids, variable_id )
    419422
    420423#if defined( __netcdf4_parallel )
    421       !-- Define how variable can be accessed by PEs in parallel netcdf file
    422       IF ( nc_stat == NF90_NOERR  .AND.  TRIM( mode ) == mode_parallel )  THEN
    423          IF ( is_global )  THEN
    424             nc_stat = NF90_VAR_PAR_ACCESS( file_id, variable_id, NF90_INDEPENDENT )
    425          ELSE
    426             nc_stat = NF90_VAR_PAR_ACCESS( file_id, variable_id, NF90_COLLECTIVE )
    427          ENDIF
    428       ENDIF
    429 #endif
    430 
    431       IF ( nc_stat /= NF90_NOERR )  THEN
    432          return_value = 1
    433          CALL internal_message( 'error', routine_name //                          &
    434                                 ': NetCDF error while initializing variable "' // &
    435                                 TRIM( variable_name ) // '": ' // NF90_STRERROR( nc_stat ) )
    436       ENDIF
    437 
    438    ELSE
    439       return_value = 1
    440    ENDIF
    441 
    442 #else
    443    return_value = 1
    444    variable_id = -1
    445 #endif
    446 
    447 END SUBROUTINE netcdf4_init_variable
     424!
     425!--    Define how variable can be accessed by PEs in parallel netcdf file
     426       IF ( nc_stat == NF90_NOERR  .AND.  TRIM( mode ) == mode_parallel )  THEN
     427          IF ( is_global )  THEN
     428             nc_stat = NF90_VAR_PAR_ACCESS( file_id, variable_id, NF90_INDEPENDENT )
     429          ELSE
     430             nc_stat = NF90_VAR_PAR_ACCESS( file_id, variable_id, NF90_COLLECTIVE )
     431          ENDIF
     432       ENDIF
     433#endif
     434
     435       IF ( nc_stat /= NF90_NOERR )  THEN
     436          return_value = 1
     437          CALL internal_message( 'error', routine_name //                          &
     438                                 ': NetCDF error while initializing variable "' // &
     439                                 TRIM( variable_name ) // '": ' // NF90_STRERROR( nc_stat ) )
     440       ENDIF
     441
     442    ELSE
     443       return_value = 1
     444    ENDIF
     445
     446#else
     447    return_value = 1
     448    variable_id = -1
     449#endif
     450
     451 END SUBROUTINE netcdf4_init_variable
    448452
    449453!--------------------------------------------------------------------------------------------------!
     
    452456!> Leave file definition state.
    453457!--------------------------------------------------------------------------------------------------!
    454 SUBROUTINE netcdf4_stop_file_header_definition( file_id, return_value )
    455 
    456    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_stop_file_header_definition'  !< name of this routine
    457 
    458    INTEGER, INTENT(IN)  ::  file_id        !< file ID
    459    INTEGER              ::  nc_stat        !< netcdf return value
    460    INTEGER              ::  old_fill_mode  !< previous netcdf fill mode
    461    INTEGER, INTENT(OUT) ::  return_value   !< return value
    462 
    463 
    464 #if defined( __netcdf4 )
    465    return_value = 0
    466 
    467    WRITE( temp_string, * ) file_id
    468    CALL internal_message( 'debug', routine_name // &
    469                           ': finalize file definition (file_id=' // TRIM( temp_string ) // ')' )
    470 
    471    !-- Set general no fill, otherwise the performance drops significantly
    472    nc_stat = NF90_SET_FILL( file_id, NF90_NOFILL, old_fill_mode )
    473 
    474    IF ( nc_stat == NF90_NOERR )  THEN
    475       nc_stat = NF90_ENDDEF( file_id )
    476    ENDIF
    477 
    478    IF ( nc_stat /= NF90_NOERR )  THEN
    479       return_value = 1
    480       CALL internal_message( 'error', routine_name // &
    481                              ': NetCDF error: ' // NF90_STRERROR( nc_stat ) )
    482    ENDIF
    483 #else
    484    return_value = 1
    485 #endif
    486 
    487 END SUBROUTINE netcdf4_stop_file_header_definition
     458 SUBROUTINE netcdf4_stop_file_header_definition( file_id, return_value )
     459
     460    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_stop_file_header_definition'  !< name of this routine
     461
     462    INTEGER, INTENT(IN)  ::  file_id        !< file ID
     463    INTEGER              ::  nc_stat        !< netcdf return value
     464    INTEGER              ::  old_fill_mode  !< previous netcdf fill mode
     465    INTEGER, INTENT(OUT) ::  return_value   !< return value
     466
     467
     468#if defined( __netcdf4 )
     469    return_value = 0
     470
     471    WRITE( temp_string, * ) file_id
     472    CALL internal_message( 'debug', routine_name // &
     473                           ': finalize file definition (file_id=' // TRIM( temp_string ) // ')' )
     474!
     475!-- Set general no fill, otherwise the performance drops significantly
     476    nc_stat = NF90_SET_FILL( file_id, NF90_NOFILL, old_fill_mode )
     477
     478    IF ( nc_stat == NF90_NOERR )  THEN
     479       nc_stat = NF90_ENDDEF( file_id )
     480    ENDIF
     481
     482    IF ( nc_stat /= NF90_NOERR )  THEN
     483       return_value = 1
     484       CALL internal_message( 'error', routine_name // &
     485                              ': NetCDF error: ' // NF90_STRERROR( nc_stat ) )
     486    ENDIF
     487#else
     488    return_value = 1
     489#endif
     490
     491 END SUBROUTINE netcdf4_stop_file_header_definition
    488492
    489493!--------------------------------------------------------------------------------------------------!
     
    492496!> Write variable of different kind into netcdf file.
    493497!--------------------------------------------------------------------------------------------------!
    494 SUBROUTINE netcdf4_write_variable(                                                    &
    495               file_id, variable_id, bounds_start, value_counts, bounds_origin,        &
    496               is_global,                                                              &
    497               values_int8_0d,   values_int8_1d,   values_int8_2d,   values_int8_3d,   &
    498               values_int16_0d,  values_int16_1d,  values_int16_2d,  values_int16_3d,  &
    499               values_int32_0d,  values_int32_1d,  values_int32_2d,  values_int32_3d,  &
    500               values_intwp_0d,  values_intwp_1d,  values_intwp_2d,  values_intwp_3d,  &
    501               values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &
    502               values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &
    503               values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d, &
    504               return_value )
    505 
    506    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_write_variable'  !< name of this routine
    507 
    508    INTEGER              ::  d             !< loop index
    509    INTEGER, INTENT(IN)  ::  file_id       !< file ID
    510    INTEGER              ::  my_rank       !< MPI rank of processor
    511    INTEGER              ::  nc_stat       !< netcdf return value
    512    INTEGER              ::  ndims         !< number of dimensions of variable in file
    513    INTEGER, INTENT(OUT) ::  return_value  !< return value
    514    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
    515 
    516    INTEGER, DIMENSION(:),              INTENT(IN)  ::  bounds_origin      !< starting index of each dimension
    517    INTEGER, DIMENSION(:),              INTENT(IN)  ::  bounds_start       !< starting index of variable
    518    INTEGER, DIMENSION(:), ALLOCATABLE              ::  dimension_ids      !< IDs of dimensions of variable in file
    519    INTEGER, DIMENSION(:), ALLOCATABLE              ::  dimension_lengths  !< length of dimensions of variable in file
    520    INTEGER, DIMENSION(:),              INTENT(IN)  ::  value_counts       !< count of values along each dimension to be written
    521 
    522    INTEGER(KIND=1), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int8_0d   !< output variable
    523    INTEGER(KIND=2), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int16_0d  !< output variable
    524    INTEGER(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int32_0d  !< output variable
    525    INTEGER(iwp),    POINTER,             INTENT(IN), OPTIONAL                   ::  values_intwp_0d  !< output variable
    526    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int8_1d   !< output variable
    527    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int16_1d  !< output variable
    528    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int32_1d  !< output variable
    529    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_intwp_1d  !< output variable
    530    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int8_2d   !< output variable
    531    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int16_2d  !< output variable
    532    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int32_2d  !< output variable
    533    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_intwp_2d  !< output variable
    534    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int8_3d   !< output variable
    535    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int16_3d  !< output variable
    536    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int32_3d  !< output variable
    537    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_intwp_3d  !< output variable
    538 
    539    LOGICAL, INTENT(IN) ::  is_global  !< true if variable is global (same on all PE)
    540 
    541    REAL(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real32_0d  !< output variable
    542    REAL(KIND=8), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real64_0d  !< output variable
    543    REAL(wp),     POINTER,             INTENT(IN), OPTIONAL                   ::  values_realwp_0d  !< output variable
    544    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real32_1d  !< output variable
    545    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real64_1d  !< output variable
    546    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_realwp_1d  !< output variable
    547    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real32_2d  !< output variable
    548    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real64_2d  !< output variable
    549    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_realwp_2d  !< output variable
    550    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real32_3d  !< output variable
    551    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real64_3d  !< output variable
    552    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_realwp_3d  !< output variable
     498 SUBROUTINE netcdf4_write_variable(                                                    &
     499               file_id, variable_id, bounds_start, value_counts, bounds_origin,        &
     500               is_global,                                                              &
     501               values_int8_0d,   values_int8_1d,   values_int8_2d,   values_int8_3d,   &
     502               values_int16_0d,  values_int16_1d,  values_int16_2d,  values_int16_3d,  &
     503               values_int32_0d,  values_int32_1d,  values_int32_2d,  values_int32_3d,  &
     504               values_intwp_0d,  values_intwp_1d,  values_intwp_2d,  values_intwp_3d,  &
     505               values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &
     506               values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &
     507               values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d, &
     508               return_value )
     509
     510    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_write_variable'  !< name of this routine
     511
     512    INTEGER              ::  d             !< loop index
     513    INTEGER, INTENT(IN)  ::  file_id       !< file ID
     514    INTEGER              ::  my_rank       !< MPI rank of processor
     515    INTEGER              ::  nc_stat       !< netcdf return value
     516    INTEGER              ::  ndims         !< number of dimensions of variable in file
     517    INTEGER, INTENT(OUT) ::  return_value  !< return value
     518    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
     519
     520    INTEGER, DIMENSION(:),              INTENT(IN)  ::  bounds_origin      !< starting index of each dimension
     521    INTEGER, DIMENSION(:),              INTENT(IN)  ::  bounds_start       !< starting index of variable
     522    INTEGER, DIMENSION(:), ALLOCATABLE              ::  dimension_ids      !< IDs of dimensions of variable in file
     523    INTEGER, DIMENSION(:), ALLOCATABLE              ::  dimension_lengths  !< length of dimensions of variable in file
     524    INTEGER, DIMENSION(:),              INTENT(IN)  ::  value_counts       !< count of values along each dimension to be written
     525
     526    INTEGER(KIND=1), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int8_0d   !< output variable
     527    INTEGER(KIND=2), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int16_0d  !< output variable
     528    INTEGER(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int32_0d  !< output variable
     529    INTEGER(iwp),    POINTER,             INTENT(IN), OPTIONAL                   ::  values_intwp_0d  !< output variable
     530    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int8_1d   !< output variable
     531    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int16_1d  !< output variable
     532    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int32_1d  !< output variable
     533    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_intwp_1d  !< output variable
     534    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int8_2d   !< output variable
     535    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int16_2d  !< output variable
     536    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int32_2d  !< output variable
     537    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_intwp_2d  !< output variable
     538    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int8_3d   !< output variable
     539    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int16_3d  !< output variable
     540    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int32_3d  !< output variable
     541    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_intwp_3d  !< output variable
     542
     543    LOGICAL, INTENT(IN) ::  is_global  !< true if variable is global (same on all PE)
     544
     545    REAL(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real32_0d  !< output variable
     546    REAL(KIND=8), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real64_0d  !< output variable
     547    REAL(wp),     POINTER,             INTENT(IN), OPTIONAL                   ::  values_realwp_0d  !< output variable
     548    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real32_1d  !< output variable
     549    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real64_1d  !< output variable
     550    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_realwp_1d  !< output variable
     551    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real32_2d  !< output variable
     552    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real64_2d  !< output variable
     553    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_realwp_2d  !< output variable
     554    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real32_3d  !< output variable
     555    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real64_3d  !< output variable
     556    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_realwp_3d  !< output variable
    553557
    554558
     
    556560
    557561#if defined( __parallel )
    558    CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
    559    IF ( return_value /= 0 )  THEN
    560       CALL internal_message( 'error', routine_name // ': MPI_COMM_RANK error' )
    561    ENDIF
    562 #else
    563    my_rank = master_rank
    564    return_value = 0
    565 #endif
    566 
    567    IF ( return_value == 0  .AND.  ( .NOT. is_global  .OR.  my_rank == master_rank ) )  THEN
    568 
    569       WRITE( temp_string, * ) variable_id
    570       CALL internal_message( 'debug', routine_name // ': write variable ' // TRIM( temp_string ) )
    571 
    572       ndims = SIZE( bounds_start )
    573 
    574       !-- 8bit integer output
    575       IF ( PRESENT( values_int8_0d ) )  THEN
    576          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int8_0d /), &
    577                                  start = bounds_start - bounds_origin + 1,   &
    578                                  count = value_counts )
    579       ELSEIF ( PRESENT( values_int8_1d ) )  THEN
    580          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_1d,     &
    581                                  start = bounds_start - bounds_origin + 1, &
    582                                  count = value_counts )
    583       ELSEIF ( PRESENT( values_int8_2d ) )  THEN
    584          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_2d,     &
    585                                  start = bounds_start - bounds_origin + 1, &
    586                                  count = value_counts )
    587       ELSEIF ( PRESENT( values_int8_3d ) )  THEN
    588          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_3d,     &
    589                                  start = bounds_start - bounds_origin + 1, &
    590                                  count = value_counts )
    591       !-- 16bit integer output
    592       ELSEIF ( PRESENT( values_int16_0d ) )  THEN
    593          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int16_0d /), &
    594                                  start = bounds_start - bounds_origin + 1,    &
    595                                  count = value_counts )
    596       ELSEIF ( PRESENT( values_int16_1d ) )  THEN
    597          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_1d,    &
    598                                  start = bounds_start - bounds_origin + 1, &
    599                                  count = value_counts )
    600       ELSEIF ( PRESENT( values_int16_2d ) )  THEN
    601          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_2d,    &
    602                                  start = bounds_start - bounds_origin + 1, &
    603                                  count = value_counts )
    604       ELSEIF ( PRESENT( values_int16_3d ) )  THEN
    605          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_3d,    &
    606                                  start = bounds_start - bounds_origin + 1, &
    607                                  count = value_counts )
    608       !-- 32bit integer output
    609       ELSEIF ( PRESENT( values_int32_0d ) )  THEN
    610          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int32_0d /),  &
    611                                  start = bounds_start - bounds_origin + 1,     &
    612                                  count = value_counts )
    613       ELSEIF ( PRESENT( values_int32_1d ) )  THEN
    614          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_1d,    &
    615                                  start = bounds_start - bounds_origin + 1, &
    616                                  count = value_counts )
    617       ELSEIF ( PRESENT( values_int32_2d ) )  THEN
    618          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_2d,    &
    619                                  start = bounds_start - bounds_origin + 1, &
    620                                  count = value_counts )
    621       ELSEIF ( PRESENT( values_int32_3d ) )  THEN
    622          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_3d,    &
    623                                  start = bounds_start - bounds_origin + 1, &
    624                                  count = value_counts )
    625       !-- working-precision integer output
    626       ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
    627          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_intwp_0d /),  &
    628                                  start = bounds_start - bounds_origin + 1,     &
    629                                  count = value_counts )
    630       ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
    631          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_1d,    &
    632                                  start = bounds_start - bounds_origin + 1, &
    633                                  count = value_counts )
    634       ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
    635          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_2d,    &
    636                                  start = bounds_start - bounds_origin + 1, &
    637                                  count = value_counts )
    638       ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
    639          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_3d,    &
    640                                  start = bounds_start - bounds_origin + 1, &
    641                                  count = value_counts )
    642       !-- 32bit real output
    643       ELSEIF ( PRESENT( values_real32_0d ) )  THEN
    644          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_real32_0d /), &
    645                                  start = bounds_start - bounds_origin + 1,     &
    646                                  count = value_counts )
    647       ELSEIF ( PRESENT( values_real32_1d ) )  THEN
    648          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_1d,   &
    649                                  start = bounds_start - bounds_origin + 1, &
    650                                  count = value_counts )
    651       ELSEIF ( PRESENT( values_real32_2d ) )  THEN
    652          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_2d,   &
    653                                  start = bounds_start - bounds_origin + 1, &
    654                                  count = value_counts )
    655       ELSEIF ( PRESENT( values_real32_3d ) )  THEN
    656          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_3d,   &
    657                                  start = bounds_start - bounds_origin + 1, &
    658                                  count = value_counts )
    659       !-- 64bit real output
    660       ELSEIF ( PRESENT( values_real64_0d ) )  THEN
    661          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_real64_0d /), &
    662                                  start = bounds_start - bounds_origin + 1,     &
    663                                  count = value_counts )
    664       ELSEIF ( PRESENT( values_real64_1d ) )  THEN
    665          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_1d,   &
    666                                  start = bounds_start - bounds_origin + 1, &
    667                                  count = value_counts )
    668       ELSEIF ( PRESENT( values_real64_2d ) )  THEN
    669          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_2d,   &
    670                                  start = bounds_start - bounds_origin + 1, &
    671                                  count = value_counts )
    672       ELSEIF ( PRESENT( values_real64_3d ) )  THEN
    673          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_3d,   &
    674                                  start = bounds_start - bounds_origin + 1, &
    675                                  count = value_counts )
    676       !-- working-precision real output
    677       ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
    678          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_realwp_0d /), &
    679                                  start = bounds_start - bounds_origin + 1,     &
    680                                  count = value_counts )
    681       ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
    682          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_1d,   &
    683                                  start = bounds_start - bounds_origin + 1, &
    684                                  count = value_counts )
    685       ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
    686          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_2d,   &
    687                                  start = bounds_start - bounds_origin + 1, &
    688                                  count = value_counts )
    689       ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
    690          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_3d,   &
    691                                  start = bounds_start - bounds_origin + 1, &
    692                                  count = value_counts )
    693       ELSE
    694          return_value = 1
    695          nc_stat = NF90_NOERR
    696          WRITE( temp_string, '(": variable_id=",I6,", file_id=",I6)' ) variable_id, file_id
    697          CALL internal_message( 'error', routine_name // &
    698                                 ': no output values given ' // TRIM( temp_string ) )
    699       ENDIF
    700 
    701       !-- Check for errors
    702       IF ( nc_stat /= NF90_NOERR )  THEN
    703          return_value = 1
    704 
    705          IF ( nc_stat == NF90_EEDGE .OR. nc_stat == NF90_EINVALCOORDS )  THEN
    706 
    707             !-- If given bounds exceed dimension bounds, get information of bounds in file
    708             WRITE( temp_string, * )  NF90_STRERROR( nc_stat )
    709 
    710             ALLOCATE( dimension_ids(ndims) )
    711             ALLOCATE( dimension_lengths(ndims) )
    712 
    713             nc_stat = NF90_INQUIRE_VARIABLE( file_id, variable_id, dimids=dimension_ids )
    714 
    715             d = 1
    716             DO WHILE ( d <= ndims .AND. nc_stat == NF90_NOERR )
    717                nc_stat = NF90_INQUIRE_DIMENSION( file_id, dimension_ids(d), &
    718                                                  LEN=dimension_lengths(d) )
    719                d = d + 1
    720             ENDDO
    721 
    722             IF ( nc_stat == NF90_NOERR )  THEN
    723                WRITE( temp_string, * )  TRIM( temp_string ) // '; given variable bounds: ' //  &
    724                   'start=', bounds_start, ', count=', value_counts, ', origin=', bounds_origin
    725                CALL internal_message( 'error', routine_name //     &
    726                                       ': error while writing: ' // TRIM( temp_string ) )
    727             ELSE
    728                !-- Error occured during NF90_INQUIRE_VARIABLE or NF90_INQUIRE_DIMENSION
    729                CALL internal_message( 'error', routine_name //            &
    730                                       ': error while accessing file: ' // &
    731                                        NF90_STRERROR( nc_stat ) )
    732             ENDIF
    733 
    734          ELSE
    735             !-- Other NetCDF error
    736             CALL internal_message( 'error', routine_name //     &
    737                                    ': error while writing: ' // NF90_STRERROR( nc_stat ) )
    738          ENDIF
    739       ENDIF
    740 
    741    ENDIF
    742 #else
    743    return_value = 1
    744 #endif
    745 
    746 END SUBROUTINE netcdf4_write_variable
     562    CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
     563    IF ( return_value /= 0 )  THEN
     564       CALL internal_message( 'error', routine_name // ': MPI_COMM_RANK error' )
     565    ENDIF
     566#else
     567    my_rank = master_rank
     568    return_value = 0
     569#endif
     570
     571    IF ( return_value == 0  .AND.  ( .NOT. is_global  .OR.  my_rank == master_rank ) )  THEN
     572
     573       WRITE( temp_string, * ) variable_id
     574       CALL internal_message( 'debug', routine_name // ': write variable ' // TRIM( temp_string ) )
     575
     576       ndims = SIZE( bounds_start )
     577!
     578!--    8bit integer output
     579       IF ( PRESENT( values_int8_0d ) )  THEN
     580          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int8_0d /), &
     581                                  start = bounds_start - bounds_origin + 1,   &
     582                                  count = value_counts )
     583       ELSEIF ( PRESENT( values_int8_1d ) )  THEN
     584          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_1d,     &
     585                                  start = bounds_start - bounds_origin + 1, &
     586                                  count = value_counts )
     587       ELSEIF ( PRESENT( values_int8_2d ) )  THEN
     588          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_2d,     &
     589                                  start = bounds_start - bounds_origin + 1, &
     590                                  count = value_counts )
     591       ELSEIF ( PRESENT( values_int8_3d ) )  THEN
     592          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_3d,     &
     593                                  start = bounds_start - bounds_origin + 1, &
     594                                  count = value_counts )
     595!
     596!--    16bit integer output
     597       ELSEIF ( PRESENT( values_int16_0d ) )  THEN
     598          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int16_0d /), &
     599                                  start = bounds_start - bounds_origin + 1,    &
     600                                  count = value_counts )
     601       ELSEIF ( PRESENT( values_int16_1d ) )  THEN
     602          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_1d,    &
     603                                  start = bounds_start - bounds_origin + 1, &
     604                                  count = value_counts )
     605       ELSEIF ( PRESENT( values_int16_2d ) )  THEN
     606          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_2d,    &
     607                                  start = bounds_start - bounds_origin + 1, &
     608                                  count = value_counts )
     609       ELSEIF ( PRESENT( values_int16_3d ) )  THEN
     610          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_3d,    &
     611                                  start = bounds_start - bounds_origin + 1, &
     612                                  count = value_counts )
     613!
     614!--    32bit integer output
     615       ELSEIF ( PRESENT( values_int32_0d ) )  THEN
     616          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int32_0d /),  &
     617                                  start = bounds_start - bounds_origin + 1,     &
     618                                  count = value_counts )
     619       ELSEIF ( PRESENT( values_int32_1d ) )  THEN
     620          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_1d,    &
     621                                  start = bounds_start - bounds_origin + 1, &
     622                                  count = value_counts )
     623       ELSEIF ( PRESENT( values_int32_2d ) )  THEN
     624          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_2d,    &
     625                                  start = bounds_start - bounds_origin + 1, &
     626                                  count = value_counts )
     627       ELSEIF ( PRESENT( values_int32_3d ) )  THEN
     628          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_3d,    &
     629                                  start = bounds_start - bounds_origin + 1, &
     630                                  count = value_counts )
     631!
     632!--    working-precision integer output
     633       ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
     634          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_intwp_0d /),  &
     635                                  start = bounds_start - bounds_origin + 1,     &
     636                                  count = value_counts )
     637       ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
     638          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_1d,    &
     639                                  start = bounds_start - bounds_origin + 1, &
     640                                  count = value_counts )
     641       ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
     642          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_2d,    &
     643                                  start = bounds_start - bounds_origin + 1, &
     644                                  count = value_counts )
     645       ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
     646          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_3d,    &
     647                                  start = bounds_start - bounds_origin + 1, &
     648                                  count = value_counts )
     649!
     650!--    32bit real output
     651       ELSEIF ( PRESENT( values_real32_0d ) )  THEN
     652          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_real32_0d /), &
     653                                  start = bounds_start - bounds_origin + 1,     &
     654                                  count = value_counts )
     655       ELSEIF ( PRESENT( values_real32_1d ) )  THEN
     656          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_1d,   &
     657                                  start = bounds_start - bounds_origin + 1, &
     658                                  count = value_counts )
     659       ELSEIF ( PRESENT( values_real32_2d ) )  THEN
     660          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_2d,   &
     661                                  start = bounds_start - bounds_origin + 1, &
     662                                  count = value_counts )
     663       ELSEIF ( PRESENT( values_real32_3d ) )  THEN
     664          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_3d,   &
     665                                  start = bounds_start - bounds_origin + 1, &
     666                                  count = value_counts )
     667!
     668!--    64bit real output
     669       ELSEIF ( PRESENT( values_real64_0d ) )  THEN
     670          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_real64_0d /), &
     671                                  start = bounds_start - bounds_origin + 1,     &
     672                                  count = value_counts )
     673       ELSEIF ( PRESENT( values_real64_1d ) )  THEN
     674          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_1d,   &
     675                                  start = bounds_start - bounds_origin + 1, &
     676                                  count = value_counts )
     677       ELSEIF ( PRESENT( values_real64_2d ) )  THEN
     678          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_2d,   &
     679                                  start = bounds_start - bounds_origin + 1, &
     680                                  count = value_counts )
     681       ELSEIF ( PRESENT( values_real64_3d ) )  THEN
     682          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_3d,   &
     683                                  start = bounds_start - bounds_origin + 1, &
     684                                  count = value_counts )
     685!
     686!--    working-precision real output
     687       ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
     688          nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_realwp_0d /), &
     689                                  start = bounds_start - bounds_origin + 1,     &
     690                                  count = value_counts )
     691       ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
     692          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_1d,   &
     693                                  start = bounds_start - bounds_origin + 1, &
     694                                  count = value_counts )
     695       ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
     696          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_2d,   &
     697                                  start = bounds_start - bounds_origin + 1, &
     698                                  count = value_counts )
     699       ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
     700          nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_3d,   &
     701                                  start = bounds_start - bounds_origin + 1, &
     702                                  count = value_counts )
     703       ELSE
     704          return_value = 1
     705          nc_stat = NF90_NOERR
     706          WRITE( temp_string, '(": variable_id=",I6,", file_id=",I6)' ) variable_id, file_id
     707          CALL internal_message( 'error', routine_name // &
     708                                 ': no output values given ' // TRIM( temp_string ) )
     709       ENDIF
     710!
     711!--    Check for errors
     712       IF ( nc_stat /= NF90_NOERR )  THEN
     713          return_value = 1
     714
     715          IF ( nc_stat == NF90_EEDGE .OR. nc_stat == NF90_EINVALCOORDS )  THEN
     716!
     717!--          If given bounds exceed dimension bounds, get information of bounds in file
     718             WRITE( temp_string, * )  NF90_STRERROR( nc_stat )
     719
     720             ALLOCATE( dimension_ids(ndims) )
     721             ALLOCATE( dimension_lengths(ndims) )
     722
     723             nc_stat = NF90_INQUIRE_VARIABLE( file_id, variable_id, dimids=dimension_ids )
     724
     725             d = 1
     726             DO WHILE ( d <= ndims .AND. nc_stat == NF90_NOERR )
     727                nc_stat = NF90_INQUIRE_DIMENSION( file_id, dimension_ids(d), &
     728                                                  LEN=dimension_lengths(d) )
     729                d = d + 1
     730             ENDDO
     731
     732             IF ( nc_stat == NF90_NOERR )  THEN
     733                WRITE( temp_string, * )  TRIM( temp_string ) // '; given variable bounds: ' //  &
     734                   'start=', bounds_start, ', count=', value_counts, ', origin=', bounds_origin
     735                CALL internal_message( 'error', routine_name //     &
     736                                       ': error while writing: ' // TRIM( temp_string ) )
     737             ELSE
     738!
     739!--             Error occured during NF90_INQUIRE_VARIABLE or NF90_INQUIRE_DIMENSION
     740                CALL internal_message( 'error', routine_name //            &
     741                                       ': error while accessing file: ' // &
     742                                        NF90_STRERROR( nc_stat ) )
     743             ENDIF
     744
     745          ELSE
     746!
     747!--          Other NetCDF error
     748             CALL internal_message( 'error', routine_name //     &
     749                                    ': error while writing: ' // NF90_STRERROR( nc_stat ) )
     750          ENDIF
     751       ENDIF
     752
     753    ENDIF
     754#else
     755    return_value = 1
     756#endif
     757
     758 END SUBROUTINE netcdf4_write_variable
    747759
    748760!--------------------------------------------------------------------------------------------------!
     
    751763!> Close netcdf file.
    752764!--------------------------------------------------------------------------------------------------!
    753 SUBROUTINE netcdf4_finalize( file_id, return_value )
    754 
    755    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_finalize'  !< name of routine
    756 
    757    INTEGER, INTENT(IN)  ::  file_id       !< file ID
    758    INTEGER              ::  nc_stat       !< netcdf return value
    759    INTEGER, INTENT(OUT) ::  return_value  !< return value
    760 
    761 
    762 #if defined( __netcdf4 )
    763    WRITE( temp_string, * ) file_id
    764    CALL internal_message( 'debug', routine_name // &
    765                           ': close file (file_id=' // TRIM( temp_string ) // ')' )
    766 
    767    nc_stat = NF90_CLOSE( file_id )
    768    IF ( nc_stat == NF90_NOERR )  THEN
    769       return_value = 0
    770    ELSE
    771       return_value = 1
    772       CALL internal_message( 'error', routine_name // &
    773                              ': NetCDF error: ' // NF90_STRERROR( nc_stat ) )
    774    ENDIF
    775 #else
    776    return_value = 1
    777 #endif
    778 
    779 END SUBROUTINE netcdf4_finalize
     765 SUBROUTINE netcdf4_finalize( file_id, return_value )
     766
     767    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'netcdf4_finalize'  !< name of routine
     768
     769    INTEGER, INTENT(IN)  ::  file_id       !< file ID
     770    INTEGER              ::  nc_stat       !< netcdf return value
     771    INTEGER, INTENT(OUT) ::  return_value  !< return value
     772
     773
     774#if defined( __netcdf4 )
     775    WRITE( temp_string, * ) file_id
     776    CALL internal_message( 'debug', routine_name // &
     777                           ': close file (file_id=' // TRIM( temp_string ) // ')' )
     778
     779    nc_stat = NF90_CLOSE( file_id )
     780    IF ( nc_stat == NF90_NOERR )  THEN
     781       return_value = 0
     782    ELSE
     783       return_value = 1
     784       CALL internal_message( 'error', routine_name // &
     785                              ': NetCDF error: ' // NF90_STRERROR( nc_stat ) )
     786    ENDIF
     787#else
     788    return_value = 1
     789#endif
     790
     791 END SUBROUTINE netcdf4_finalize
    780792
    781793!--------------------------------------------------------------------------------------------------!
     
    784796!> Convert data_type string into netcdf data type value.
    785797!--------------------------------------------------------------------------------------------------!
    786 FUNCTION get_netcdf_data_type( data_type ) RESULT( return_value )
    787 
    788    CHARACTER(LEN=*), INTENT(IN) ::  data_type  !< requested data type
    789 
    790    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'get_netcdf_data_type'  !< name of this routine
    791 
    792    INTEGER ::  return_value  !< netcdf data type
    793 
    794 
    795    SELECT CASE ( TRIM( data_type ) )
    796 
    797 #if defined( __netcdf4 )
    798       CASE ( 'char' )
    799          return_value = NF90_CHAR
    800 
    801       CASE ( 'int8' )
    802          return_value = NF90_BYTE
    803 
    804       CASE ( 'int16' )
    805          return_value = NF90_SHORT
    806 
    807       CASE ( 'int32' )
    808          return_value = NF90_INT
    809 
    810       CASE ( 'real32' )
    811          return_value = NF90_FLOAT
    812 
    813       CASE ( 'real64' )
    814          return_value = NF90_DOUBLE
    815 #endif
    816 
    817       CASE DEFAULT
    818          CALL internal_message( 'error', routine_name // &
    819                                 ': data type unknown (' // TRIM( data_type ) // ')' )
    820          return_value = -1
    821 
    822    END SELECT
    823 
    824 END FUNCTION get_netcdf_data_type
     798 FUNCTION get_netcdf_data_type( data_type ) RESULT( return_value )
     799
     800    CHARACTER(LEN=*), INTENT(IN) ::  data_type  !< requested data type
     801
     802    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'get_netcdf_data_type'  !< name of this routine
     803
     804    INTEGER ::  return_value  !< netcdf data type
     805
     806
     807    SELECT CASE ( TRIM( data_type ) )
     808
     809#if defined( __netcdf4 )
     810       CASE ( 'char' )
     811          return_value = NF90_CHAR
     812
     813       CASE ( 'int8' )
     814          return_value = NF90_BYTE
     815
     816       CASE ( 'int16' )
     817          return_value = NF90_SHORT
     818
     819       CASE ( 'int32' )
     820          return_value = NF90_INT
     821
     822       CASE ( 'real32' )
     823          return_value = NF90_FLOAT
     824
     825       CASE ( 'real64' )
     826          return_value = NF90_DOUBLE
     827#endif
     828
     829       CASE DEFAULT
     830          CALL internal_message( 'error', routine_name // &
     831                                 ': data type unknown (' // TRIM( data_type ) // ')' )
     832          return_value = -1
     833
     834    END SELECT
     835
     836 END FUNCTION get_netcdf_data_type
    825837
    826838!--------------------------------------------------------------------------------------------------!
     
    830842!> or creating the error message string.
    831843!--------------------------------------------------------------------------------------------------!
    832 SUBROUTINE internal_message( level, string )
    833 
    834    CHARACTER(LEN=*), INTENT(IN) ::  level   !< message importance level
    835    CHARACTER(LEN=*), INTENT(IN) ::  string  !< message string
    836 
    837 
    838    IF ( TRIM( level ) == 'error' )  THEN
    839 
    840       WRITE( internal_error_message, '(A,A)' ) ': ', string
    841 
    842    ELSEIF ( TRIM( level ) == 'debug'  .AND.  print_debug_output )  THEN
    843 
    844       WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
    845       FLUSH( debug_output_unit )
    846 
    847    ENDIF
    848 
    849 END SUBROUTINE internal_message
     844 SUBROUTINE internal_message( level, string )
     845
     846    CHARACTER(LEN=*), INTENT(IN) ::  level   !< message importance level
     847    CHARACTER(LEN=*), INTENT(IN) ::  string  !< message string
     848
     849
     850    IF ( TRIM( level ) == 'error' )  THEN
     851
     852       WRITE( internal_error_message, '(A,A)' ) ': ', string
     853
     854    ELSEIF ( TRIM( level ) == 'debug'  .AND.  print_debug_output )  THEN
     855
     856       WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
     857       FLUSH( debug_output_unit )
     858
     859    ENDIF
     860
     861 END SUBROUTINE internal_message
    850862
    851863!--------------------------------------------------------------------------------------------------!
     
    854866!> Return the last created error message.
    855867!--------------------------------------------------------------------------------------------------!
    856 FUNCTION netcdf4_get_error_message() RESULT( error_message )
    857 
    858    CHARACTER(LEN=800) ::  error_message  !< return error message to main program
    859 
    860 
    861    error_message = TRIM( internal_error_message )
    862 
    863    internal_error_message = ''
    864 
    865 END FUNCTION netcdf4_get_error_message
    866 
    867 
    868 END MODULE data_output_netcdf4_module
     868 FUNCTION netcdf4_get_error_message() RESULT( error_message )
     869
     870    CHARACTER(LEN=800) ::  error_message  !< return error message to main program
     871
     872
     873    error_message = TRIM( internal_error_message )
     874
     875    internal_error_message = ''
     876
     877 END FUNCTION netcdf4_get_error_message
     878
     879
     880 END MODULE data_output_netcdf4_module
Note: See TracChangeset for help on using the changeset viewer.