[4070] | 1 | !> @file data_output_binary_module.f90 |
---|
| 2 | !--------------------------------------------------------------------------------------------------! |
---|
| 3 | ! This file is part of the PALM model system. |
---|
| 4 | ! |
---|
| 5 | ! PALM is free software: you can redistribute it and/or modify it under the |
---|
| 6 | ! terms of the GNU General Public License as published by the Free Software |
---|
| 7 | ! Foundation, either version 3 of the License, or (at your option) any later |
---|
| 8 | ! version. |
---|
| 9 | ! |
---|
| 10 | ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY |
---|
| 11 | ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR |
---|
| 12 | ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. |
---|
| 13 | ! |
---|
| 14 | ! You should have received a copy of the GNU General Public License along with |
---|
| 15 | ! PALM. If not, see <http://www.gnu.org/licenses/>. |
---|
| 16 | ! |
---|
| 17 | ! Copyright 2019-2019 Leibniz Universitaet Hannover |
---|
| 18 | !--------------------------------------------------------------------------------------------------! |
---|
| 19 | ! |
---|
| 20 | ! Current revisions: |
---|
| 21 | ! ------------------ |
---|
[4106] | 22 | ! |
---|
| 23 | ! |
---|
[4070] | 24 | ! Former revisions: |
---|
| 25 | ! ----------------- |
---|
| 26 | ! $Id: data_output_binary_module.f90 4106 2019-07-19 08:54:42Z gronemeier $ |
---|
| 27 | ! Initial revision |
---|
| 28 | ! |
---|
| 29 | ! |
---|
| 30 | ! Authors: |
---|
| 31 | ! -------- |
---|
| 32 | !> @author: Tobias Gronemeier |
---|
| 33 | ! |
---|
| 34 | ! Description: |
---|
| 35 | ! ------------ |
---|
| 36 | !> Binary output module to write output data into binary files. |
---|
| 37 | !> |
---|
[4106] | 38 | !> @todo Get iostat value of write statements. |
---|
[4070] | 39 | !--------------------------------------------------------------------------------------------------! |
---|
| 40 | MODULE data_output_binary_module |
---|
| 41 | |
---|
| 42 | USE kinds |
---|
| 43 | |
---|
| 44 | #if defined( __parallel ) |
---|
| 45 | #if defined( __mpifh ) |
---|
| 46 | INCLUDE "mpif.h" |
---|
| 47 | #else |
---|
| 48 | USE MPI |
---|
| 49 | #endif |
---|
| 50 | #endif |
---|
| 51 | |
---|
| 52 | IMPLICIT NONE |
---|
| 53 | |
---|
| 54 | INTEGER(iwp), PARAMETER :: charlen = 100_iwp !< maximum length of character variables |
---|
| 55 | |
---|
| 56 | CHARACTER(LEN=*), PARAMETER :: config_file_name = 'BINARY_TO_NETCDF_CONFIG' !< name of config file |
---|
[4106] | 57 | CHARACTER(LEN=*), PARAMETER :: mode_binary = 'binary' !< string to select operation mode of module |
---|
[4070] | 58 | CHARACTER(LEN=*), PARAMETER :: prefix = 'BIN_' !< file prefix for binary files |
---|
| 59 | |
---|
| 60 | CHARACTER(LEN=800) :: internal_error_message = '' !< string containing the last error message |
---|
| 61 | CHARACTER(LEN=800) :: temp_string !< dummy string |
---|
| 62 | |
---|
| 63 | INTEGER(iwp) :: binary_file_lowest_unit = 1000 !< lowest unit number of all binary files created by this module |
---|
| 64 | INTEGER(iwp) :: config_file_unit !< unit number of config file |
---|
| 65 | INTEGER(iwp) :: debug_output_unit !< Fortran Unit Number of the debug-output file |
---|
| 66 | INTEGER(iwp) :: global_id_in_file = -1 !< value of global ID within a file |
---|
| 67 | INTEGER(iwp) :: next_available_unit !< next unit number available for new file |
---|
| 68 | |
---|
| 69 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: files_highest_var_id !< highest assigned ID of variable or dimension in a file |
---|
| 70 | |
---|
| 71 | LOGICAL :: binary_open_file_first_call = .TRUE. !< true if binary_open_file routine was not called yet |
---|
| 72 | LOGICAL :: config_file_open = .FALSE. !< true if config file is opened and not closed |
---|
| 73 | LOGICAL :: print_debug_output = .FALSE. !< if true, debug output is printed |
---|
| 74 | |
---|
| 75 | SAVE |
---|
| 76 | |
---|
| 77 | PRIVATE |
---|
| 78 | |
---|
| 79 | INTERFACE binary_init_module |
---|
| 80 | MODULE PROCEDURE binary_init_module |
---|
| 81 | END INTERFACE binary_init_module |
---|
| 82 | |
---|
| 83 | INTERFACE binary_open_file |
---|
| 84 | MODULE PROCEDURE binary_open_file |
---|
| 85 | END INTERFACE binary_open_file |
---|
| 86 | |
---|
| 87 | INTERFACE binary_init_dimension |
---|
| 88 | MODULE PROCEDURE binary_init_dimension |
---|
| 89 | END INTERFACE binary_init_dimension |
---|
| 90 | |
---|
| 91 | INTERFACE binary_init_variable |
---|
| 92 | MODULE PROCEDURE binary_init_variable |
---|
| 93 | END INTERFACE binary_init_variable |
---|
| 94 | |
---|
| 95 | INTERFACE binary_write_attribute |
---|
| 96 | MODULE PROCEDURE binary_write_attribute |
---|
| 97 | END INTERFACE binary_write_attribute |
---|
| 98 | |
---|
| 99 | INTERFACE binary_init_end |
---|
| 100 | MODULE PROCEDURE binary_init_end |
---|
| 101 | END INTERFACE binary_init_end |
---|
| 102 | |
---|
| 103 | INTERFACE binary_write_variable |
---|
| 104 | MODULE PROCEDURE binary_write_variable |
---|
| 105 | END INTERFACE binary_write_variable |
---|
| 106 | |
---|
| 107 | INTERFACE binary_finalize |
---|
| 108 | MODULE PROCEDURE binary_finalize |
---|
| 109 | END INTERFACE binary_finalize |
---|
| 110 | |
---|
| 111 | INTERFACE binary_get_error_message |
---|
| 112 | MODULE PROCEDURE binary_get_error_message |
---|
| 113 | END INTERFACE binary_get_error_message |
---|
| 114 | |
---|
| 115 | PUBLIC & |
---|
| 116 | binary_finalize, & |
---|
| 117 | binary_get_error_message, & |
---|
| 118 | binary_init_dimension, & |
---|
| 119 | binary_init_end, & |
---|
| 120 | binary_init_module, & |
---|
| 121 | binary_init_variable, & |
---|
| 122 | binary_open_file, & |
---|
| 123 | binary_write_attribute, & |
---|
| 124 | binary_write_variable |
---|
| 125 | |
---|
| 126 | |
---|
| 127 | CONTAINS |
---|
| 128 | |
---|
| 129 | |
---|
| 130 | !--------------------------------------------------------------------------------------------------! |
---|
| 131 | ! Description: |
---|
| 132 | ! ------------ |
---|
| 133 | !> Initialize data-output module. |
---|
| 134 | !--------------------------------------------------------------------------------------------------! |
---|
| 135 | SUBROUTINE binary_init_module( program_debug_output_unit, debug_output, dom_global_id ) |
---|
| 136 | |
---|
| 137 | INTEGER(iwp), INTENT(IN) :: dom_global_id !< global id within a file defined by DOM |
---|
| 138 | INTEGER(iwp), INTENT(IN) :: program_debug_output_unit !< file unit number for debug output |
---|
| 139 | |
---|
| 140 | LOGICAL, INTENT(IN) :: debug_output !< if true, debug output is printed |
---|
| 141 | |
---|
| 142 | |
---|
| 143 | debug_output_unit = program_debug_output_unit |
---|
| 144 | |
---|
| 145 | print_debug_output = debug_output |
---|
| 146 | |
---|
| 147 | global_id_in_file = dom_global_id |
---|
| 148 | |
---|
| 149 | |
---|
| 150 | END SUBROUTINE binary_init_module |
---|
| 151 | |
---|
| 152 | !--------------------------------------------------------------------------------------------------! |
---|
| 153 | ! Description: |
---|
| 154 | ! ------------ |
---|
| 155 | !> Open binary file. |
---|
| 156 | !--------------------------------------------------------------------------------------------------! |
---|
[4106] | 157 | SUBROUTINE binary_open_file( mode, filename, file_id, return_value ) |
---|
[4070] | 158 | |
---|
| 159 | CHARACTER(LEN=charlen) :: bin_filename = '' !< actual name of binary file |
---|
| 160 | CHARACTER(LEN=charlen), INTENT(IN) :: filename !< name of file |
---|
| 161 | CHARACTER(LEN=7) :: myid_char !< string containing value of myid with leading zeros |
---|
[4106] | 162 | CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode |
---|
[4070] | 163 | |
---|
| 164 | CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_open_file' !< name of this routine |
---|
| 165 | |
---|
| 166 | INTEGER(iwp), INTENT(OUT) :: file_id !< file ID |
---|
| 167 | INTEGER(iwp) :: myid !< id of local processor id (MPI rank) |
---|
| 168 | INTEGER(iwp), INTENT(OUT) :: return_value !< return value |
---|
| 169 | |
---|
| 170 | INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: files_highest_var_id_tmp !< temporary list of given variable IDs in file |
---|
| 171 | |
---|
| 172 | LOGICAL :: file_exists !< true if file to be opened already exists |
---|
| 173 | |
---|
| 174 | |
---|
| 175 | return_value = 0 |
---|
| 176 | |
---|
| 177 | #if defined( __parallel ) |
---|
| 178 | CALL MPI_COMM_RANK( MPI_COMM_WORLD, myid, return_value ) |
---|
| 179 | IF ( return_value == 0 ) THEN |
---|
| 180 | WRITE( myid_char, '("_",I6.6)' ) myid |
---|
| 181 | ELSE |
---|
[4106] | 182 | CALL internal_message( 'debug', routine_name // ': MPI_COMM_RANK error' ) |
---|
[4070] | 183 | ENDIF |
---|
| 184 | #else |
---|
| 185 | myid = 0 |
---|
| 186 | myid_char = '_' // REPEAT('0', 6) |
---|
| 187 | #endif |
---|
| 188 | |
---|
[4106] | 189 | !-- Check mode (not required, added for compatibility reasons) |
---|
| 190 | IF ( TRIM( mode ) == mode_binary ) CONTINUE |
---|
| 191 | |
---|
[4070] | 192 | !-- Open binary config file for combining script |
---|
| 193 | IF ( return_value == 0 .AND. binary_open_file_first_call ) THEN |
---|
| 194 | |
---|
| 195 | binary_open_file_first_call = .FALSE. |
---|
| 196 | config_file_unit = binary_file_lowest_unit |
---|
| 197 | |
---|
| 198 | IF ( myid == 0 ) THEN |
---|
| 199 | |
---|
| 200 | !-- Remove any pre-existing file |
---|
| 201 | INQUIRE( FILE=TRIM( config_file_name ), EXIST=file_exists ) |
---|
| 202 | |
---|
| 203 | IF ( file_exists ) THEN |
---|
| 204 | CALL internal_message( 'debug', routine_name // & |
---|
| 205 | ': Remove existing file ' // & |
---|
| 206 | TRIM( config_file_name ) ) |
---|
| 207 | CALL SYSTEM( 'rm ' // TRIM( config_file_name ) ) |
---|
| 208 | ENDIF |
---|
| 209 | |
---|
| 210 | OPEN( config_file_unit, FILE=TRIM( config_file_name ), & |
---|
| 211 | FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value ) |
---|
| 212 | |
---|
| 213 | IF ( return_value == 0 ) THEN |
---|
| 214 | |
---|
| 215 | config_file_open = .TRUE. |
---|
| 216 | |
---|
| 217 | !-- Write some general information to config file |
---|
| 218 | WRITE( config_file_unit ) LEN( prefix ) |
---|
| 219 | WRITE( config_file_unit ) prefix |
---|
| 220 | WRITE( config_file_unit ) charlen |
---|
| 221 | WRITE( config_file_unit ) global_id_in_file |
---|
| 222 | |
---|
| 223 | ELSE |
---|
| 224 | |
---|
| 225 | return_value = 1 |
---|
| 226 | CALL internal_message( 'error', routine_name // ': could not create config' ) |
---|
| 227 | |
---|
| 228 | ENDIF |
---|
| 229 | |
---|
| 230 | ENDIF |
---|
| 231 | |
---|
| 232 | next_available_unit = binary_file_lowest_unit + 1 |
---|
| 233 | |
---|
| 234 | ENDIF |
---|
| 235 | |
---|
| 236 | !-- Initialize output file: open, write header, initialize variable/dimension IDs |
---|
| 237 | IF ( return_value == 0 ) THEN |
---|
| 238 | |
---|
| 239 | bin_filename = prefix // TRIM( filename ) // myid_char |
---|
| 240 | |
---|
| 241 | !-- Remove any pre-existing file |
---|
| 242 | INQUIRE( FILE=TRIM( bin_filename ), EXIST=file_exists ) |
---|
| 243 | |
---|
| 244 | IF ( file_exists ) THEN |
---|
| 245 | CALL internal_message( 'debug', routine_name // & |
---|
| 246 | ': remove existing file ' // TRIM( bin_filename ) ) |
---|
| 247 | CALL SYSTEM( 'rm ' // TRIM( bin_filename ) ) |
---|
| 248 | ENDIF |
---|
| 249 | |
---|
| 250 | !-- Open binary file |
---|
| 251 | CALL internal_message( 'debug', routine_name // ': open file ' // TRIM( bin_filename ) ) |
---|
| 252 | OPEN ( next_available_unit, FILE=TRIM( bin_filename ), & |
---|
| 253 | FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value ) |
---|
| 254 | |
---|
| 255 | IF ( return_value == 0 ) THEN |
---|
| 256 | |
---|
| 257 | !-- Add filename to config file |
---|
| 258 | IF ( myid == 0 ) THEN |
---|
| 259 | WRITE( config_file_unit ) filename |
---|
| 260 | ENDIF |
---|
| 261 | |
---|
| 262 | !-- Save file ID and increase next file unit number |
---|
| 263 | file_id = next_available_unit |
---|
| 264 | next_available_unit = next_available_unit + 1 |
---|
| 265 | |
---|
| 266 | !-- Write some meta data to file |
---|
| 267 | WRITE ( file_id ) charlen |
---|
| 268 | WRITE ( file_id ) file_id |
---|
| 269 | WRITE ( file_id ) filename |
---|
| 270 | |
---|
| 271 | !-- Extend file-variable/dimension-ID list by 1 and set it to 0 for new file. |
---|
| 272 | IF ( ALLOCATED( files_highest_var_id ) ) THEN |
---|
| 273 | ALLOCATE( files_highest_var_id_tmp(SIZE( files_highest_var_id )) ) |
---|
| 274 | files_highest_var_id_tmp = files_highest_var_id |
---|
| 275 | DEALLOCATE( files_highest_var_id ) |
---|
| 276 | ALLOCATE( files_highest_var_id(binary_file_lowest_unit+1:file_id) ) |
---|
| 277 | files_highest_var_id(:file_id-1) = files_highest_var_id_tmp |
---|
| 278 | DEALLOCATE( files_highest_var_id_tmp ) |
---|
| 279 | ELSE |
---|
| 280 | ALLOCATE( files_highest_var_id(binary_file_lowest_unit+1:file_id) ) |
---|
| 281 | ENDIF |
---|
| 282 | files_highest_var_id(file_id) = 0_iwp |
---|
| 283 | |
---|
| 284 | ELSE |
---|
| 285 | return_value = 1 |
---|
| 286 | CALL internal_message( 'error', routine_name // & |
---|
| 287 | ': could not open file "' // TRIM( filename ) // '"') |
---|
| 288 | ENDIF |
---|
| 289 | |
---|
| 290 | ENDIF |
---|
| 291 | |
---|
| 292 | END SUBROUTINE binary_open_file |
---|
| 293 | |
---|
| 294 | !--------------------------------------------------------------------------------------------------! |
---|
| 295 | ! Description: |
---|
| 296 | ! ------------ |
---|
| 297 | !> Write attribute to file. |
---|
| 298 | !--------------------------------------------------------------------------------------------------! |
---|
| 299 | SUBROUTINE binary_write_attribute( file_id, var_id, att_name, att_value_char, & |
---|
| 300 | att_value_int8, att_value_int16, att_value_int32, & |
---|
| 301 | att_value_real32, att_value_real64, return_value ) |
---|
| 302 | |
---|
| 303 | CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_write_attribute' !< name of this routine |
---|
| 304 | |
---|
| 305 | CHARACTER(LEN=charlen), INTENT(IN) :: att_name !< name of attribute |
---|
| 306 | CHARACTER(LEN=charlen), INTENT(IN), OPTIONAL :: att_value_char !< value of attribute |
---|
| 307 | CHARACTER(LEN=charlen) :: att_type !< data type of attribute |
---|
| 308 | CHARACTER(LEN=charlen) :: out_str !< output string |
---|
| 309 | |
---|
| 310 | INTEGER(KIND=1), INTENT(IN), OPTIONAL :: att_value_int8 !< value of attribute |
---|
| 311 | INTEGER(KIND=2), INTENT(IN), OPTIONAL :: att_value_int16 !< value of attribute |
---|
| 312 | INTEGER(KIND=4), INTENT(IN), OPTIONAL :: att_value_int32 !< value of attribute |
---|
| 313 | |
---|
| 314 | INTEGER(iwp), INTENT(IN) :: file_id !< file ID |
---|
| 315 | INTEGER(iwp), INTENT(IN) :: var_id !< variable ID |
---|
| 316 | INTEGER(iwp), INTENT(OUT) :: return_value !< return value |
---|
| 317 | |
---|
| 318 | REAL(KIND=4), INTENT(IN), OPTIONAL :: att_value_real32 !< value of attribute |
---|
| 319 | REAL(KIND=8), INTENT(IN), OPTIONAL :: att_value_real64 !< value of attribute |
---|
| 320 | |
---|
| 321 | |
---|
| 322 | return_value = 0 |
---|
| 323 | |
---|
| 324 | CALL internal_message( 'debug', TRIM( routine_name ) // & |
---|
| 325 | ': write attribute ' // TRIM( att_name ) ) |
---|
| 326 | |
---|
| 327 | !-- Write attribute to file |
---|
| 328 | out_str = 'attribute' |
---|
| 329 | WRITE( file_id ) out_str |
---|
| 330 | |
---|
| 331 | WRITE( file_id ) var_id |
---|
| 332 | WRITE( file_id ) att_name |
---|
| 333 | |
---|
| 334 | IF ( PRESENT( att_value_char ) ) THEN |
---|
| 335 | att_type = 'char' |
---|
| 336 | WRITE( file_id ) att_type |
---|
| 337 | WRITE( file_id ) att_value_char |
---|
| 338 | ELSEIF ( PRESENT( att_value_int8 ) ) THEN |
---|
| 339 | att_type = 'int8' |
---|
| 340 | WRITE( file_id ) att_type |
---|
| 341 | WRITE( file_id ) att_value_int8 |
---|
| 342 | ELSEIF ( PRESENT( att_value_int16 ) ) THEN |
---|
| 343 | att_type = 'int16' |
---|
| 344 | WRITE( file_id ) att_type |
---|
| 345 | WRITE( file_id ) att_value_int16 |
---|
| 346 | ELSEIF ( PRESENT( att_value_int32 ) ) THEN |
---|
| 347 | att_type = 'int32' |
---|
| 348 | WRITE( file_id ) att_type |
---|
| 349 | WRITE( file_id ) att_value_int32 |
---|
| 350 | ELSEIF ( PRESENT( att_value_real32 ) ) THEN |
---|
| 351 | att_type = 'real32' |
---|
| 352 | WRITE( file_id ) att_type |
---|
| 353 | WRITE( file_id ) att_value_real32 |
---|
| 354 | ELSEIF ( PRESENT( att_value_real64 ) ) THEN |
---|
| 355 | att_type = 'real64' |
---|
| 356 | WRITE( file_id ) att_type |
---|
| 357 | WRITE( file_id ) att_value_real64 |
---|
| 358 | ELSE |
---|
| 359 | return_value = 1 |
---|
| 360 | CALL internal_message( 'error', TRIM( routine_name ) // & |
---|
[4106] | 361 | ': attribute "' // TRIM( att_name ) // '": no value given' ) |
---|
[4070] | 362 | ENDIF |
---|
| 363 | |
---|
| 364 | END SUBROUTINE binary_write_attribute |
---|
| 365 | |
---|
| 366 | !--------------------------------------------------------------------------------------------------! |
---|
| 367 | ! Description: |
---|
| 368 | ! ------------ |
---|
| 369 | !> Initialize dimension. Write information in file header and save dimension |
---|
| 370 | !> values to be later written to file. |
---|
| 371 | !--------------------------------------------------------------------------------------------------! |
---|
[4106] | 372 | SUBROUTINE binary_init_dimension( mode, file_id, dim_id, var_id, & |
---|
| 373 | dim_name, dim_type, dim_length, return_value ) |
---|
[4070] | 374 | |
---|
| 375 | CHARACTER(LEN=charlen), INTENT(IN) :: dim_name !< name of dimension |
---|
| 376 | CHARACTER(LEN=charlen), INTENT(IN) :: dim_type !< data type of dimension |
---|
| 377 | CHARACTER(LEN=charlen) :: out_str !< output string |
---|
[4106] | 378 | CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode |
---|
[4070] | 379 | |
---|
| 380 | CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_dimension' !< name of this routine |
---|
| 381 | |
---|
| 382 | INTEGER(iwp), INTENT(OUT) :: dim_id !< dimension ID |
---|
| 383 | INTEGER(iwp), INTENT(IN) :: dim_length !< length of dimension |
---|
| 384 | INTEGER(iwp), INTENT(IN) :: file_id !< file ID |
---|
| 385 | INTEGER(iwp), INTENT(OUT) :: return_value !< return value |
---|
| 386 | INTEGER(iwp), INTENT(OUT) :: var_id !< variable ID |
---|
| 387 | |
---|
| 388 | |
---|
| 389 | return_value = 0 |
---|
| 390 | |
---|
| 391 | CALL internal_message( 'debug', routine_name // ': init dimension ' // TRIM( dim_name ) ) |
---|
| 392 | |
---|
[4106] | 393 | !-- Check mode (not required, added for compatibility reasons only) |
---|
| 394 | IF ( TRIM( mode ) == mode_binary ) CONTINUE |
---|
| 395 | |
---|
[4070] | 396 | !-- Assign dimension ID |
---|
| 397 | dim_id = files_highest_var_id( file_id ) + 1 |
---|
| 398 | files_highest_var_id( file_id ) = dim_id |
---|
| 399 | |
---|
| 400 | !-- Define dimension in file |
---|
| 401 | out_str = 'dimension' |
---|
| 402 | WRITE( file_id ) out_str |
---|
| 403 | WRITE( file_id ) dim_name |
---|
| 404 | WRITE( file_id ) dim_id |
---|
| 405 | WRITE( file_id ) dim_type |
---|
| 406 | WRITE( file_id ) dim_length |
---|
| 407 | |
---|
| 408 | !-- Define variable associated with dimension |
---|
[4106] | 409 | CALL binary_init_variable( mode, file_id, var_id, dim_name, dim_type, (/dim_id/), & |
---|
| 410 | is_global=.TRUE., return_value=return_value ) |
---|
[4070] | 411 | IF ( return_value /= 0 ) THEN |
---|
| 412 | CALL internal_message( 'error', routine_name // & |
---|
| 413 | ': init dimension "' // TRIM( dim_name ) // '"' ) |
---|
| 414 | ENDIF |
---|
| 415 | |
---|
| 416 | END SUBROUTINE binary_init_dimension |
---|
| 417 | |
---|
| 418 | !--------------------------------------------------------------------------------------------------! |
---|
| 419 | ! Description: |
---|
| 420 | ! ------------ |
---|
| 421 | !> Initialize variable. Write information of variable into file header. |
---|
| 422 | !--------------------------------------------------------------------------------------------------! |
---|
[4106] | 423 | SUBROUTINE binary_init_variable( mode, file_id, var_id, var_name, var_type, & |
---|
| 424 | var_dim_ids, is_global, return_value ) |
---|
[4070] | 425 | |
---|
| 426 | CHARACTER(LEN=charlen) :: out_str !< output string |
---|
| 427 | CHARACTER(LEN=charlen), INTENT(IN) :: var_name !< name of variable |
---|
| 428 | CHARACTER(LEN=charlen), INTENT(IN) :: var_type !< data type of variable |
---|
[4106] | 429 | CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode |
---|
[4070] | 430 | |
---|
| 431 | CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_variable' !< name of this routine |
---|
| 432 | |
---|
| 433 | INTEGER(iwp), INTENT(IN) :: file_id !< file ID |
---|
| 434 | INTEGER(iwp), INTENT(OUT) :: var_id !< variable ID |
---|
| 435 | INTEGER(iwp), INTENT(OUT) :: return_value !< return value |
---|
| 436 | |
---|
| 437 | INTEGER(iwp), DIMENSION(:), INTENT(IN) :: var_dim_ids !< list of dimension IDs used by variable |
---|
| 438 | |
---|
| 439 | LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE) |
---|
| 440 | |
---|
| 441 | |
---|
| 442 | return_value = 0 |
---|
| 443 | |
---|
| 444 | CALL internal_message( 'debug', routine_name // ': init variable ' // TRIM( var_name ) ) |
---|
| 445 | |
---|
[4106] | 446 | !-- Check mode (not required, added for compatibility reasons only) |
---|
| 447 | IF ( TRIM( mode ) == mode_binary ) CONTINUE |
---|
[4070] | 448 | |
---|
[4106] | 449 | !-- Check if variable is global (not required, added for compatibility reasons only) |
---|
| 450 | IF ( is_global ) CONTINUE |
---|
| 451 | |
---|
[4070] | 452 | !-- Assign variable ID |
---|
| 453 | var_id = files_highest_var_id( file_id ) + 1 |
---|
| 454 | files_highest_var_id( file_id ) = var_id |
---|
| 455 | |
---|
| 456 | !-- Write variable information in file |
---|
| 457 | out_str = 'variable' |
---|
| 458 | WRITE( file_id ) out_str |
---|
| 459 | WRITE( file_id ) var_name |
---|
| 460 | WRITE( file_id ) var_id |
---|
| 461 | WRITE( file_id ) var_type |
---|
| 462 | WRITE( file_id ) SIZE( var_dim_ids ) |
---|
| 463 | WRITE( file_id ) var_dim_ids |
---|
| 464 | |
---|
| 465 | END SUBROUTINE binary_init_variable |
---|
| 466 | |
---|
| 467 | !--------------------------------------------------------------------------------------------------! |
---|
| 468 | ! Description: |
---|
| 469 | ! ------------ |
---|
| 470 | !> Leave file definition state. |
---|
| 471 | !--------------------------------------------------------------------------------------------------! |
---|
| 472 | SUBROUTINE binary_init_end( file_id, return_value ) |
---|
| 473 | |
---|
| 474 | CHARACTER(LEN=charlen) :: out_str !< output string |
---|
| 475 | |
---|
| 476 | CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_end' !< name of this routine |
---|
| 477 | |
---|
| 478 | INTEGER(iwp), INTENT(IN) :: file_id !< file ID |
---|
| 479 | INTEGER(iwp), INTENT(OUT) :: return_value !< return value |
---|
| 480 | |
---|
| 481 | |
---|
| 482 | return_value = 0 |
---|
| 483 | |
---|
| 484 | WRITE( temp_string, * ) file_id |
---|
| 485 | CALL internal_message( 'debug', & |
---|
| 486 | routine_name // & |
---|
| 487 | ': finalize file definition (file_id=' // TRIM( temp_string ) // ')' ) |
---|
| 488 | |
---|
| 489 | out_str = '*** end file header ***' |
---|
| 490 | WRITE( file_id ) out_str |
---|
| 491 | |
---|
| 492 | END SUBROUTINE binary_init_end |
---|
| 493 | |
---|
| 494 | !--------------------------------------------------------------------------------------------------! |
---|
| 495 | ! Description: |
---|
| 496 | ! ------------ |
---|
| 497 | !> Write variable to file. |
---|
| 498 | !--------------------------------------------------------------------------------------------------! |
---|
| 499 | SUBROUTINE binary_write_variable( & |
---|
| 500 | file_id, var_id, bounds_start, bounds_end, bounds_origin, & |
---|
| 501 | do_output, is_global, & |
---|
| 502 | var_int8_0d, var_int8_1d, var_int8_2d, var_int8_3d, & |
---|
| 503 | var_int16_0d, var_int16_1d, var_int16_2d, var_int16_3d, & |
---|
| 504 | var_int32_0d, var_int32_1d, var_int32_2d, var_int32_3d, & |
---|
| 505 | var_intwp_0d, var_intwp_1d, var_intwp_2d, var_intwp_3d, & |
---|
| 506 | var_real32_0d, var_real32_1d, var_real32_2d, var_real32_3d, & |
---|
| 507 | var_real64_0d, var_real64_1d, var_real64_2d, var_real64_3d, & |
---|
| 508 | var_realwp_0d, var_realwp_1d, var_realwp_2d, var_realwp_3d, & |
---|
| 509 | return_value ) |
---|
| 510 | |
---|
[4106] | 511 | CHARACTER(LEN=charlen) :: out_str !< output string |
---|
| 512 | |
---|
[4070] | 513 | CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_write_variable' !< name of this routine |
---|
| 514 | |
---|
| 515 | INTEGER(iwp), INTENT(IN) :: file_id !< file ID |
---|
| 516 | INTEGER(iwp), INTENT(OUT) :: return_value !< return value |
---|
| 517 | INTEGER(iwp), INTENT(IN) :: var_id !< variable ID |
---|
| 518 | |
---|
| 519 | INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_origin !< starting index of each dimension |
---|
| 520 | INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_end !< ending index of variable |
---|
| 521 | INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_start !< starting index of variable |
---|
| 522 | |
---|
| 523 | INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL :: var_int8_0d !< output variable |
---|
| 524 | INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int8_1d !< output variable |
---|
| 525 | INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int8_2d !< output variable |
---|
| 526 | INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int8_3d !< output variable |
---|
| 527 | |
---|
| 528 | INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL :: var_int16_0d !< output variable |
---|
| 529 | INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int16_1d !< output variable |
---|
| 530 | INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int16_2d !< output variable |
---|
| 531 | INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int16_3d !< output variable |
---|
| 532 | |
---|
| 533 | INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL :: var_int32_0d !< output variable |
---|
| 534 | INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int32_1d !< output variable |
---|
| 535 | INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int32_2d !< output variable |
---|
| 536 | INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int32_3d !< output variable |
---|
| 537 | |
---|
| 538 | INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL :: var_intwp_0d !< output variable |
---|
| 539 | INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_intwp_1d !< output variable |
---|
| 540 | INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_intwp_2d !< output variable |
---|
| 541 | INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_intwp_3d !< output variable |
---|
| 542 | |
---|
| 543 | LOGICAL, INTENT(IN) :: do_output !< write output only if do_output = true |
---|
| 544 | LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE) |
---|
| 545 | |
---|
| 546 | REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: var_real32_0d !< output variable |
---|
| 547 | REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_real32_1d !< output variable |
---|
| 548 | REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_real32_2d !< output variable |
---|
| 549 | REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_real32_3d !< output variable |
---|
| 550 | |
---|
| 551 | REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL :: var_real64_0d !< output variable |
---|
| 552 | REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_real64_1d !< output variable |
---|
| 553 | REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_real64_2d !< output variable |
---|
| 554 | REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_real64_3d !< output variable |
---|
| 555 | |
---|
| 556 | REAL(wp), POINTER, INTENT(IN), OPTIONAL :: var_realwp_0d !< output variable |
---|
| 557 | REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_realwp_1d !< output variable |
---|
| 558 | REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_realwp_2d !< output variable |
---|
| 559 | REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_realwp_3d !< output variable |
---|
| 560 | |
---|
| 561 | |
---|
| 562 | return_value = 0 |
---|
| 563 | |
---|
| 564 | WRITE( temp_string, '(": write variable ",I6," into file ",I6)' ) var_id, file_id |
---|
| 565 | CALL internal_message( 'debug', routine_name // TRIM( temp_string ) ) |
---|
| 566 | |
---|
| 567 | IF ( is_global ) CONTINUE ! reqired to prevent compiler warning |
---|
| 568 | |
---|
| 569 | IF ( do_output ) THEN |
---|
| 570 | WRITE( file_id ) var_id |
---|
| 571 | WRITE( file_id ) bounds_start |
---|
| 572 | WRITE( file_id ) bounds_end |
---|
| 573 | WRITE( file_id ) bounds_origin |
---|
| 574 | !-- 8bit integer output |
---|
| 575 | IF ( PRESENT( var_int8_0d ) ) THEN |
---|
[4106] | 576 | out_str = 'int8' |
---|
| 577 | WRITE( file_id ) out_str |
---|
[4070] | 578 | WRITE( file_id ) var_int8_0d |
---|
| 579 | ELSEIF ( PRESENT( var_int8_1d ) ) THEN |
---|
[4106] | 580 | out_str = 'int8' |
---|
| 581 | WRITE( file_id ) out_str |
---|
[4070] | 582 | WRITE( file_id ) var_int8_1d |
---|
| 583 | ELSEIF ( PRESENT( var_int8_2d ) ) THEN |
---|
[4106] | 584 | out_str = 'int8' |
---|
| 585 | WRITE( file_id ) out_str |
---|
[4070] | 586 | WRITE( file_id ) var_int8_2d |
---|
| 587 | ELSEIF ( PRESENT( var_int8_3d ) ) THEN |
---|
[4106] | 588 | out_str = 'int8' |
---|
| 589 | WRITE( file_id ) out_str |
---|
[4070] | 590 | WRITE( file_id ) var_int8_3d |
---|
| 591 | !-- 16bit integer output |
---|
| 592 | ELSEIF ( PRESENT( var_int16_0d ) ) THEN |
---|
[4106] | 593 | out_str = 'int16' |
---|
| 594 | WRITE( file_id ) out_str |
---|
[4070] | 595 | WRITE( file_id ) var_int16_0d |
---|
| 596 | ELSEIF ( PRESENT( var_int16_1d ) ) THEN |
---|
[4106] | 597 | out_str = 'int16' |
---|
| 598 | WRITE( file_id ) out_str |
---|
[4070] | 599 | WRITE( file_id ) var_int16_1d |
---|
| 600 | ELSEIF ( PRESENT( var_int16_2d ) ) THEN |
---|
[4106] | 601 | out_str = 'int16' |
---|
| 602 | WRITE( file_id ) out_str |
---|
[4070] | 603 | WRITE( file_id ) var_int16_2d |
---|
| 604 | ELSEIF ( PRESENT( var_int16_3d ) ) THEN |
---|
[4106] | 605 | out_str = 'int16' |
---|
| 606 | WRITE( file_id ) out_str |
---|
[4070] | 607 | WRITE( file_id ) var_int16_3d |
---|
| 608 | !-- 32bit integer output |
---|
| 609 | ELSEIF ( PRESENT( var_int32_0d ) ) THEN |
---|
[4106] | 610 | out_str = 'int32' |
---|
| 611 | WRITE( file_id ) out_str |
---|
[4070] | 612 | WRITE( file_id ) var_int32_0d |
---|
| 613 | ELSEIF ( PRESENT( var_int32_1d ) ) THEN |
---|
[4106] | 614 | out_str = 'int32' |
---|
| 615 | WRITE( file_id ) out_str |
---|
[4070] | 616 | WRITE( file_id ) var_int32_1d |
---|
| 617 | ELSEIF ( PRESENT( var_int32_2d ) ) THEN |
---|
[4106] | 618 | out_str = 'int32' |
---|
| 619 | WRITE( file_id ) out_str |
---|
[4070] | 620 | WRITE( file_id ) var_int32_2d |
---|
| 621 | ELSEIF ( PRESENT( var_int32_3d ) ) THEN |
---|
[4106] | 622 | out_str = 'int32' |
---|
| 623 | WRITE( file_id ) out_str |
---|
[4070] | 624 | WRITE( file_id ) var_int32_3d |
---|
| 625 | !-- working-precision integer output |
---|
| 626 | ELSEIF ( PRESENT( var_intwp_0d ) ) THEN |
---|
[4106] | 627 | out_str = 'intwp' |
---|
| 628 | WRITE( file_id ) out_str |
---|
[4070] | 629 | WRITE( file_id ) var_intwp_0d |
---|
| 630 | ELSEIF ( PRESENT( var_intwp_1d ) ) THEN |
---|
[4106] | 631 | out_str = 'intwp' |
---|
| 632 | WRITE( file_id ) out_str |
---|
[4070] | 633 | WRITE( file_id ) var_intwp_1d |
---|
| 634 | ELSEIF ( PRESENT( var_intwp_2d ) ) THEN |
---|
[4106] | 635 | out_str = 'intwp' |
---|
| 636 | WRITE( file_id ) out_str |
---|
[4070] | 637 | WRITE( file_id ) var_intwp_2d |
---|
| 638 | ELSEIF ( PRESENT( var_intwp_3d ) ) THEN |
---|
[4106] | 639 | out_str = 'intwp' |
---|
| 640 | WRITE( file_id ) out_str |
---|
[4070] | 641 | WRITE( file_id ) var_intwp_3d |
---|
| 642 | !-- 32bit real output |
---|
| 643 | ELSEIF ( PRESENT( var_real32_0d ) ) THEN |
---|
[4106] | 644 | out_str = 'real32' |
---|
| 645 | WRITE( file_id ) out_str |
---|
[4070] | 646 | WRITE( file_id ) var_real32_0d |
---|
| 647 | ELSEIF ( PRESENT( var_real32_1d ) ) THEN |
---|
[4106] | 648 | out_str = 'real32' |
---|
| 649 | WRITE( file_id ) out_str |
---|
[4070] | 650 | WRITE( file_id ) var_real32_1d |
---|
| 651 | ELSEIF ( PRESENT( var_real32_2d ) ) THEN |
---|
[4106] | 652 | out_str = 'real32' |
---|
| 653 | WRITE( file_id ) out_str |
---|
[4070] | 654 | WRITE( file_id ) var_real32_2d |
---|
| 655 | ELSEIF ( PRESENT( var_real32_3d ) ) THEN |
---|
[4106] | 656 | out_str = 'real32' |
---|
| 657 | WRITE( file_id ) out_str |
---|
[4070] | 658 | WRITE( file_id ) var_real32_3d |
---|
| 659 | !-- 64bit real output |
---|
| 660 | ELSEIF ( PRESENT( var_real64_0d ) ) THEN |
---|
[4106] | 661 | out_str = 'real64' |
---|
| 662 | WRITE( file_id ) out_str |
---|
[4070] | 663 | WRITE( file_id ) var_real64_0d |
---|
| 664 | ELSEIF ( PRESENT( var_real64_1d ) ) THEN |
---|
[4106] | 665 | out_str = 'real64' |
---|
| 666 | WRITE( file_id ) out_str |
---|
[4070] | 667 | WRITE( file_id ) var_real64_1d |
---|
| 668 | ELSEIF ( PRESENT( var_real64_2d ) ) THEN |
---|
[4106] | 669 | out_str = 'real64' |
---|
| 670 | WRITE( file_id ) out_str |
---|
[4070] | 671 | WRITE( file_id ) var_real64_2d |
---|
| 672 | ELSEIF ( PRESENT( var_real64_3d ) ) THEN |
---|
[4106] | 673 | out_str = 'real64' |
---|
| 674 | WRITE( file_id ) out_str |
---|
[4070] | 675 | WRITE( file_id ) var_real64_3d |
---|
| 676 | !-- working-precision real output |
---|
| 677 | ELSEIF ( PRESENT( var_realwp_0d ) ) THEN |
---|
[4106] | 678 | out_str = 'realwp' |
---|
| 679 | WRITE( file_id ) out_str |
---|
[4070] | 680 | WRITE( file_id ) var_realwp_0d |
---|
| 681 | ELSEIF ( PRESENT( var_realwp_1d ) ) THEN |
---|
[4106] | 682 | out_str = 'realwp' |
---|
| 683 | WRITE( file_id ) out_str |
---|
[4070] | 684 | WRITE( file_id ) var_realwp_1d |
---|
| 685 | ELSEIF ( PRESENT( var_realwp_2d ) ) THEN |
---|
[4106] | 686 | out_str = 'realwp' |
---|
| 687 | WRITE( file_id ) out_str |
---|
[4070] | 688 | WRITE( file_id ) var_realwp_2d |
---|
| 689 | ELSEIF ( PRESENT( var_realwp_3d ) ) THEN |
---|
[4106] | 690 | out_str = 'realwp' |
---|
| 691 | WRITE( file_id ) out_str |
---|
[4070] | 692 | WRITE( file_id ) var_realwp_3d |
---|
| 693 | ELSE |
---|
| 694 | return_value = 1 |
---|
[4106] | 695 | CALL internal_message( 'error', routine_name // ': no values given' ) |
---|
[4070] | 696 | ENDIF |
---|
| 697 | |
---|
| 698 | ENDIF |
---|
| 699 | |
---|
| 700 | END SUBROUTINE binary_write_variable |
---|
| 701 | |
---|
| 702 | !--------------------------------------------------------------------------------------------------! |
---|
| 703 | ! Description: |
---|
| 704 | ! ------------ |
---|
| 705 | !> Close opened files. |
---|
| 706 | !--------------------------------------------------------------------------------------------------! |
---|
| 707 | SUBROUTINE binary_finalize( file_id, return_value ) |
---|
| 708 | |
---|
| 709 | CHARACTER(LEN=charlen) :: out_str !< output string |
---|
| 710 | |
---|
| 711 | CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_finalize' !< name of this routine |
---|
| 712 | |
---|
| 713 | INTEGER(iwp), INTENT(IN) :: file_id !< file ID |
---|
| 714 | INTEGER(iwp), INTENT(OUT) :: return_value !< return value |
---|
| 715 | |
---|
| 716 | |
---|
| 717 | IF ( config_file_open ) THEN |
---|
| 718 | |
---|
| 719 | out_str = '*** end config file ***' |
---|
| 720 | WRITE( config_file_unit ) out_str |
---|
| 721 | |
---|
| 722 | CLOSE( config_file_unit, IOSTAT=return_value ) |
---|
| 723 | |
---|
| 724 | IF ( return_value /= 0 ) THEN |
---|
| 725 | CALL internal_message( 'error', routine_name // ': cannot close configuration file' ) |
---|
| 726 | ELSE |
---|
| 727 | config_file_open = .FALSE. |
---|
| 728 | ENDIF |
---|
| 729 | |
---|
| 730 | ELSE |
---|
| 731 | |
---|
| 732 | return_value = 0 |
---|
| 733 | |
---|
| 734 | ENDIF |
---|
| 735 | |
---|
| 736 | IF ( return_value == 0 ) THEN |
---|
| 737 | |
---|
| 738 | WRITE(temp_string,*) file_id |
---|
| 739 | CALL internal_message( 'debug', routine_name // & |
---|
| 740 | ': close file (file_id=' // TRIM( temp_string ) // ')' ) |
---|
| 741 | |
---|
| 742 | CLOSE( file_id, IOSTAT=return_value ) |
---|
| 743 | IF ( return_value /= 0 ) THEN |
---|
| 744 | WRITE(temp_string,*) file_id |
---|
| 745 | CALL internal_message( 'error', & |
---|
| 746 | routine_name // & |
---|
| 747 | ': cannot close file (file_id=' // TRIM( temp_string ) // ')' ) |
---|
| 748 | ENDIF |
---|
| 749 | |
---|
| 750 | ENDIF |
---|
| 751 | |
---|
| 752 | END SUBROUTINE binary_finalize |
---|
| 753 | |
---|
| 754 | |
---|
| 755 | !--------------------------------------------------------------------------------------------------! |
---|
| 756 | ! Description: |
---|
| 757 | ! ------------ |
---|
| 758 | !> Message routine writing debug information into the debug file |
---|
| 759 | !> or creating the error message string. |
---|
| 760 | !--------------------------------------------------------------------------------------------------! |
---|
| 761 | SUBROUTINE internal_message( level, string ) |
---|
| 762 | |
---|
| 763 | CHARACTER(LEN=*), INTENT(IN) :: level !< message importance level |
---|
| 764 | CHARACTER(LEN=*), INTENT(IN) :: string !< message string |
---|
| 765 | |
---|
| 766 | |
---|
| 767 | IF ( TRIM( level ) == 'error' ) THEN |
---|
| 768 | |
---|
[4106] | 769 | WRITE( internal_error_message, '(A,A)' ) ': ', string |
---|
[4070] | 770 | |
---|
| 771 | ELSEIF ( TRIM( level ) == 'debug' .AND. print_debug_output ) THEN |
---|
| 772 | |
---|
| 773 | WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string |
---|
| 774 | FLUSH( debug_output_unit ) |
---|
| 775 | |
---|
| 776 | ENDIF |
---|
| 777 | |
---|
| 778 | END SUBROUTINE internal_message |
---|
| 779 | |
---|
| 780 | !--------------------------------------------------------------------------------------------------! |
---|
| 781 | ! Description: |
---|
| 782 | ! ------------ |
---|
| 783 | !> Return the last created error message. |
---|
| 784 | !--------------------------------------------------------------------------------------------------! |
---|
| 785 | SUBROUTINE binary_get_error_message( error_message ) |
---|
| 786 | |
---|
| 787 | CHARACTER(LEN=800), INTENT(OUT) :: error_message !< return error message to main program |
---|
| 788 | |
---|
| 789 | |
---|
| 790 | error_message = internal_error_message |
---|
| 791 | |
---|
| 792 | END SUBROUTINE binary_get_error_message |
---|
| 793 | |
---|
| 794 | |
---|
| 795 | END MODULE data_output_binary_module |
---|