Home


About us
PALM
PALM-4U
Installation
Release notes
Documentation
Getting Help
Gallery
Developers area

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

corrected indentation according to coding standard

File:
1 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
Note: See TracChangeset for help on using the changeset viewer.
                                                                                                                                                                                                                                                                                                                                                                               
  | Impressum | ©Leibniz Universität Hannover |