!> @file data_output_binary_module.f90 !--------------------------------------------------------------------------------------------------! ! This file is part of the PALM model system. ! ! PALM is free software: you can redistribute it and/or modify it under the ! terms of the GNU General Public License as published by the Free Software ! Foundation, either version 3 of the License, or (at your option) any later ! version. ! ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License along with ! PALM. If not, see . ! ! Copyright 2019-2019 Leibniz Universitaet Hannover !--------------------------------------------------------------------------------------------------! ! ! Current revisions: ! ------------------ ! ! ! Former revisions: ! ----------------- ! $Id: data_output_binary_module.f90 4108 2019-07-22 09:48:42Z suehring $ ! Initial revision ! ! ! Authors: ! -------- !> @author: Tobias Gronemeier ! ! Description: ! ------------ !> Binary output module to write output data into binary files. !> !> @todo Get iostat value of write statements. !--------------------------------------------------------------------------------------------------! MODULE data_output_binary_module USE kinds #if defined( __parallel ) #if defined( __mpifh ) INCLUDE "mpif.h" #else USE MPI #endif #endif IMPLICIT NONE INTEGER(iwp), PARAMETER :: charlen = 100_iwp !< maximum length of character variables CHARACTER(LEN=*), PARAMETER :: config_file_name = 'BINARY_TO_NETCDF_CONFIG' !< name of config file CHARACTER(LEN=*), PARAMETER :: mode_binary = 'binary' !< string to select operation mode of module CHARACTER(LEN=*), PARAMETER :: file_prefix = 'BIN_' !< file prefix for binary files CHARACTER(LEN=charlen) :: file_suffix = '' !< file suffix added to each file name CHARACTER(LEN=800) :: internal_error_message = '' !< string containing the last error message CHARACTER(LEN=800) :: temp_string !< dummy string INTEGER(iwp) :: binary_file_lowest_unit = 1000 !< lowest unit number of all binary files created by this module INTEGER(iwp) :: config_file_unit !< unit number of config file INTEGER(iwp) :: debug_output_unit !< Fortran Unit Number of the debug-output file INTEGER(iwp) :: global_id_in_file = -1 !< value of global ID within a file INTEGER :: master_rank !< master rank for tasks to be executed by single PE only INTEGER(iwp) :: next_available_unit !< next unit number available for new file INTEGER :: output_group_comm !< MPI communicator addressing all MPI ranks which participate in output INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: files_highest_var_id !< highest assigned ID of variable or dimension in a file LOGICAL :: binary_open_file_first_call = .TRUE. !< true if binary_open_file routine was not called yet LOGICAL :: config_file_open = .FALSE. !< true if config file is opened and not closed LOGICAL :: print_debug_output = .FALSE. !< if true, debug output is printed SAVE PRIVATE INTERFACE binary_init_module MODULE PROCEDURE binary_init_module END INTERFACE binary_init_module INTERFACE binary_open_file MODULE PROCEDURE binary_open_file END INTERFACE binary_open_file INTERFACE binary_init_dimension MODULE PROCEDURE binary_init_dimension END INTERFACE binary_init_dimension INTERFACE binary_init_variable MODULE PROCEDURE binary_init_variable END INTERFACE binary_init_variable INTERFACE binary_write_attribute MODULE PROCEDURE binary_write_attribute END INTERFACE binary_write_attribute INTERFACE binary_init_end MODULE PROCEDURE binary_init_end END INTERFACE binary_init_end INTERFACE binary_write_variable MODULE PROCEDURE binary_write_variable END INTERFACE binary_write_variable INTERFACE binary_finalize MODULE PROCEDURE binary_finalize END INTERFACE binary_finalize INTERFACE binary_get_error_message MODULE PROCEDURE binary_get_error_message END INTERFACE binary_get_error_message PUBLIC & binary_finalize, & binary_get_error_message, & binary_init_dimension, & binary_init_end, & binary_init_module, & binary_init_variable, & binary_open_file, & binary_write_attribute, & binary_write_variable CONTAINS !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Initialize data-output module. !--------------------------------------------------------------------------------------------------! SUBROUTINE binary_init_module( file_suffix_of_output_group, mpi_comm_of_output_group, & master_output_rank, & program_debug_output_unit, debug_output, dom_global_id ) CHARACTER(LEN=*), INTENT(IN) :: file_suffix_of_output_group !> file-name suffix added to each file; !> must be unique for each output group INTEGER(iwp), INTENT(IN) :: dom_global_id !< global id within a file defined by DOM INTEGER, INTENT(IN) :: master_output_rank !< MPI rank executing tasks which must be executed by a single PE INTEGER, INTENT(IN) :: mpi_comm_of_output_group !< MPI communicator specifying the rank group participating in output INTEGER(iwp), INTENT(IN) :: program_debug_output_unit !< file unit number for debug output LOGICAL, INTENT(IN) :: debug_output !< if true, debug output is printed file_suffix = file_suffix_of_output_group output_group_comm = mpi_comm_of_output_group master_rank = master_output_rank debug_output_unit = program_debug_output_unit print_debug_output = debug_output global_id_in_file = dom_global_id END SUBROUTINE binary_init_module !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Open binary file. !--------------------------------------------------------------------------------------------------! SUBROUTINE binary_open_file( mode, filename, file_id, return_value ) CHARACTER(LEN=charlen) :: bin_filename = '' !< actual name of binary file CHARACTER(LEN=charlen), INTENT(IN) :: filename !< name of file CHARACTER(LEN=7) :: my_rank_char !< string containing value of my_rank with leading zeros CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_open_file' !< name of this routine INTEGER(iwp), INTENT(OUT) :: file_id !< file ID INTEGER :: my_rank !< MPI rank of local processor INTEGER :: nrank !< number of MPI ranks participating in output INTEGER(iwp), INTENT(OUT) :: return_value !< return value INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: files_highest_var_id_tmp !< temporary list of given variable IDs in file LOGICAL :: file_exists !< true if file to be opened already exists return_value = 0 #if defined( __parallel ) CALL MPI_COMM_SIZE( output_group_comm, nrank, return_value ) IF ( return_value == 0 ) CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value ) IF ( return_value == 0 ) THEN WRITE( my_rank_char, '("_",I6.6)' ) my_rank ELSE CALL internal_message( 'error', routine_name // ': MPI error' ) ENDIF #else nrank = 1 my_rank = master_rank WRITE( my_rank_char, '("_",I6.6)' ) my_rank #endif !-- Check mode (not required, added for compatibility reasons) IF ( TRIM( mode ) == mode_binary ) CONTINUE !-- Open binary config file for combining script IF ( return_value == 0 .AND. binary_open_file_first_call ) THEN binary_open_file_first_call = .FALSE. config_file_unit = binary_file_lowest_unit IF ( my_rank == master_rank ) THEN !-- Remove any pre-existing file INQUIRE( FILE=TRIM( config_file_name ) // TRIM( file_suffix ), & EXIST=file_exists ) IF ( file_exists ) THEN CALL internal_message( 'debug', routine_name // & ': Remove existing file ' // & TRIM( config_file_name ) // TRIM( file_suffix ) ) !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by !> PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used ! CALL EXECUTE_COMMAND_LINE( & ! COMMAND='rm ' // TRIM( config_file_name ) // TRIM( file_suffix ), & ! WAIT=.TRUE., EXITSTAT=return_value ) CALL SYSTEM( 'rm ' // TRIM( config_file_name ) // TRIM( file_suffix ) ) ENDIF OPEN( config_file_unit, FILE=TRIM( config_file_name ) // TRIM( file_suffix ), & FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value ) IF ( return_value == 0 ) THEN config_file_open = .TRUE. !-- Write some general information to config file WRITE( config_file_unit ) nrank WRITE( config_file_unit ) master_rank WRITE( config_file_unit ) LEN( file_prefix ) WRITE( config_file_unit ) file_prefix WRITE( config_file_unit ) charlen WRITE( config_file_unit ) global_id_in_file ELSE return_value = 1 CALL internal_message( 'error', routine_name // ': could not create config' ) ENDIF ENDIF next_available_unit = binary_file_lowest_unit + 1 ENDIF !-- Initialize output file: open, write header, initialize variable/dimension IDs IF ( return_value == 0 ) THEN bin_filename = file_prefix // TRIM( filename ) // TRIM( file_suffix ) // my_rank_char !-- Remove any pre-existing file INQUIRE( FILE=TRIM( bin_filename ), EXIST=file_exists ) IF ( file_exists ) THEN CALL internal_message( 'debug', routine_name // & ': remove existing file ' // TRIM( bin_filename ) ) !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by !> PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used ! CALL EXECUTE_COMMAND_LINE( COMMAND='rm ' // TRIM( bin_filename ), & ! WAIT=.TRUE., EXITSTAT=return_value ) CALL SYSTEM( 'rm ' // TRIM( bin_filename ) ) ENDIF !-- Open binary file CALL internal_message( 'debug', routine_name // ': open file ' // TRIM( bin_filename ) ) OPEN ( next_available_unit, FILE=TRIM( bin_filename ), & FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value ) IF ( return_value == 0 ) THEN !-- Add filename to config file IF ( my_rank == master_rank ) THEN WRITE( config_file_unit ) filename ENDIF !-- Save file ID and increase next file unit number file_id = next_available_unit next_available_unit = next_available_unit + 1 !-- Write some meta data to file WRITE ( file_id ) charlen WRITE ( file_id ) file_id WRITE ( file_id ) filename !-- Extend file-variable/dimension-ID list by 1 and set it to 0 for new file. IF ( ALLOCATED( files_highest_var_id ) ) THEN ALLOCATE( files_highest_var_id_tmp(SIZE( files_highest_var_id )) ) files_highest_var_id_tmp = files_highest_var_id DEALLOCATE( files_highest_var_id ) ALLOCATE( files_highest_var_id(binary_file_lowest_unit+1:file_id) ) files_highest_var_id(:file_id-1) = files_highest_var_id_tmp DEALLOCATE( files_highest_var_id_tmp ) ELSE ALLOCATE( files_highest_var_id(binary_file_lowest_unit+1:file_id) ) ENDIF files_highest_var_id(file_id) = 0_iwp ELSE return_value = 1 CALL internal_message( 'error', routine_name // & ': could not open file "' // TRIM( filename ) // '"') ENDIF ENDIF END SUBROUTINE binary_open_file !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Write attribute to file. !--------------------------------------------------------------------------------------------------! SUBROUTINE binary_write_attribute( file_id, var_id, att_name, att_value_char, & att_value_int8, att_value_int16, att_value_int32, & att_value_real32, att_value_real64, return_value ) CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_write_attribute' !< name of this routine CHARACTER(LEN=charlen), INTENT(IN) :: att_name !< name of attribute CHARACTER(LEN=charlen), INTENT(IN), OPTIONAL :: att_value_char !< value of attribute CHARACTER(LEN=charlen) :: att_type !< data type of attribute CHARACTER(LEN=charlen) :: out_str !< output string INTEGER(KIND=1), INTENT(IN), OPTIONAL :: att_value_int8 !< value of attribute INTEGER(KIND=2), INTENT(IN), OPTIONAL :: att_value_int16 !< value of attribute INTEGER(KIND=4), INTENT(IN), OPTIONAL :: att_value_int32 !< value of attribute INTEGER(iwp), INTENT(IN) :: file_id !< file ID INTEGER(iwp), INTENT(IN) :: var_id !< variable ID INTEGER(iwp), INTENT(OUT) :: return_value !< return value REAL(KIND=4), INTENT(IN), OPTIONAL :: att_value_real32 !< value of attribute REAL(KIND=8), INTENT(IN), OPTIONAL :: att_value_real64 !< value of attribute return_value = 0 CALL internal_message( 'debug', TRIM( routine_name ) // & ': write attribute ' // TRIM( att_name ) ) !-- Write attribute to file out_str = 'attribute' WRITE( file_id ) out_str WRITE( file_id ) var_id WRITE( file_id ) att_name IF ( PRESENT( att_value_char ) ) THEN att_type = 'char' WRITE( file_id ) att_type WRITE( file_id ) att_value_char ELSEIF ( PRESENT( att_value_int8 ) ) THEN att_type = 'int8' WRITE( file_id ) att_type WRITE( file_id ) att_value_int8 ELSEIF ( PRESENT( att_value_int16 ) ) THEN att_type = 'int16' WRITE( file_id ) att_type WRITE( file_id ) att_value_int16 ELSEIF ( PRESENT( att_value_int32 ) ) THEN att_type = 'int32' WRITE( file_id ) att_type WRITE( file_id ) att_value_int32 ELSEIF ( PRESENT( att_value_real32 ) ) THEN att_type = 'real32' WRITE( file_id ) att_type WRITE( file_id ) att_value_real32 ELSEIF ( PRESENT( att_value_real64 ) ) THEN att_type = 'real64' WRITE( file_id ) att_type WRITE( file_id ) att_value_real64 ELSE return_value = 1 CALL internal_message( 'error', TRIM( routine_name ) // & ': attribute "' // TRIM( att_name ) // '": no value given' ) ENDIF END SUBROUTINE binary_write_attribute !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Initialize dimension. Write information in file header and save dimension !> values to be later written to file. !--------------------------------------------------------------------------------------------------! SUBROUTINE binary_init_dimension( mode, file_id, dim_id, var_id, & dim_name, dim_type, dim_length, return_value ) CHARACTER(LEN=charlen), INTENT(IN) :: dim_name !< name of dimension CHARACTER(LEN=charlen), INTENT(IN) :: dim_type !< data type of dimension CHARACTER(LEN=charlen) :: out_str !< output string CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_dimension' !< name of this routine INTEGER(iwp), INTENT(OUT) :: dim_id !< dimension ID INTEGER(iwp), INTENT(IN) :: dim_length !< length of dimension INTEGER(iwp), INTENT(IN) :: file_id !< file ID INTEGER(iwp), INTENT(OUT) :: return_value !< return value INTEGER(iwp), INTENT(OUT) :: var_id !< variable ID return_value = 0 CALL internal_message( 'debug', routine_name // ': init dimension ' // TRIM( dim_name ) ) !-- Check mode (not required, added for compatibility reasons only) IF ( TRIM( mode ) == mode_binary ) CONTINUE !-- Assign dimension ID dim_id = files_highest_var_id( file_id ) + 1 files_highest_var_id( file_id ) = dim_id !-- Define dimension in file out_str = 'dimension' WRITE( file_id ) out_str WRITE( file_id ) dim_name WRITE( file_id ) dim_id WRITE( file_id ) dim_type WRITE( file_id ) dim_length !-- Define variable associated with dimension CALL binary_init_variable( mode, file_id, var_id, dim_name, dim_type, (/dim_id/), & is_global=.TRUE., return_value=return_value ) IF ( return_value /= 0 ) THEN CALL internal_message( 'error', routine_name // & ': init dimension "' // TRIM( dim_name ) // '"' ) ENDIF END SUBROUTINE binary_init_dimension !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Initialize variable. Write information of variable into file header. !--------------------------------------------------------------------------------------------------! SUBROUTINE binary_init_variable( mode, file_id, var_id, var_name, var_type, & var_dim_ids, is_global, return_value ) CHARACTER(LEN=charlen) :: out_str !< output string CHARACTER(LEN=charlen), INTENT(IN) :: var_name !< name of variable CHARACTER(LEN=charlen), INTENT(IN) :: var_type !< data type of variable CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_variable' !< name of this routine INTEGER(iwp), INTENT(IN) :: file_id !< file ID INTEGER(iwp), INTENT(OUT) :: var_id !< variable ID INTEGER(iwp), INTENT(OUT) :: return_value !< return value INTEGER(iwp), DIMENSION(:), INTENT(IN) :: var_dim_ids !< list of dimension IDs used by variable LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE) return_value = 0 CALL internal_message( 'debug', routine_name // ': init variable ' // TRIM( var_name ) ) !-- Check mode (not required, added for compatibility reasons only) IF ( TRIM( mode ) == mode_binary ) CONTINUE !-- Check if variable is global (not required, added for compatibility reasons only) IF ( is_global ) CONTINUE !-- Assign variable ID var_id = files_highest_var_id( file_id ) + 1 files_highest_var_id( file_id ) = var_id !-- Write variable information in file out_str = 'variable' WRITE( file_id ) out_str WRITE( file_id ) var_name WRITE( file_id ) var_id WRITE( file_id ) var_type WRITE( file_id ) SIZE( var_dim_ids ) WRITE( file_id ) var_dim_ids END SUBROUTINE binary_init_variable !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Leave file definition state. !--------------------------------------------------------------------------------------------------! SUBROUTINE binary_init_end( file_id, return_value ) CHARACTER(LEN=charlen) :: out_str !< output string CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_end' !< name of this routine INTEGER(iwp), INTENT(IN) :: file_id !< file ID INTEGER(iwp), INTENT(OUT) :: return_value !< return value return_value = 0 WRITE( temp_string, * ) file_id CALL internal_message( 'debug', & routine_name // & ': finalize file definition (file_id=' // TRIM( temp_string ) // ')' ) out_str = '*** end file header ***' WRITE( file_id ) out_str END SUBROUTINE binary_init_end !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Write variable to file. !--------------------------------------------------------------------------------------------------! SUBROUTINE binary_write_variable( & file_id, var_id, bounds_start, bounds_end, bounds_origin, & do_output, is_global, & var_int8_0d, var_int8_1d, var_int8_2d, var_int8_3d, & var_int16_0d, var_int16_1d, var_int16_2d, var_int16_3d, & var_int32_0d, var_int32_1d, var_int32_2d, var_int32_3d, & var_intwp_0d, var_intwp_1d, var_intwp_2d, var_intwp_3d, & var_real32_0d, var_real32_1d, var_real32_2d, var_real32_3d, & var_real64_0d, var_real64_1d, var_real64_2d, var_real64_3d, & var_realwp_0d, var_realwp_1d, var_realwp_2d, var_realwp_3d, & return_value ) CHARACTER(LEN=charlen) :: out_str !< output string CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_write_variable' !< name of this routine INTEGER(iwp), INTENT(IN) :: file_id !< file ID INTEGER(iwp), INTENT(OUT) :: return_value !< return value INTEGER(iwp), INTENT(IN) :: var_id !< variable ID INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_origin !< starting index of each dimension INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_end !< ending index of variable INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds_start !< starting index of variable INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL :: var_int8_0d !< output variable INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int8_1d !< output variable INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int8_2d !< output variable INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int8_3d !< output variable INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL :: var_int16_0d !< output variable INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int16_1d !< output variable INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int16_2d !< output variable INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int16_3d !< output variable INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL :: var_int32_0d !< output variable INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_int32_1d !< output variable INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_int32_2d !< output variable INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_int32_3d !< output variable INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL :: var_intwp_0d !< output variable INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_intwp_1d !< output variable INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_intwp_2d !< output variable INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_intwp_3d !< output variable LOGICAL, INTENT(IN) :: do_output !< write output only if do_output = true LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE) REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: var_real32_0d !< output variable REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_real32_1d !< output variable REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_real32_2d !< output variable REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_real32_3d !< output variable REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL :: var_real64_0d !< output variable REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_real64_1d !< output variable REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_real64_2d !< output variable REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_real64_3d !< output variable REAL(wp), POINTER, INTENT(IN), OPTIONAL :: var_realwp_0d !< output variable REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: var_realwp_1d !< output variable REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: var_realwp_2d !< output variable REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: var_realwp_3d !< output variable return_value = 0 WRITE( temp_string, '(": write variable ",I6," into file ",I6)' ) var_id, file_id CALL internal_message( 'debug', routine_name // TRIM( temp_string ) ) IF ( is_global ) CONTINUE ! reqired to prevent compiler warning IF ( do_output ) THEN WRITE( file_id ) var_id WRITE( file_id ) bounds_start WRITE( file_id ) bounds_end WRITE( file_id ) bounds_origin !-- 8bit integer output IF ( PRESENT( var_int8_0d ) ) THEN out_str = 'int8' WRITE( file_id ) out_str WRITE( file_id ) var_int8_0d ELSEIF ( PRESENT( var_int8_1d ) ) THEN out_str = 'int8' WRITE( file_id ) out_str WRITE( file_id ) var_int8_1d ELSEIF ( PRESENT( var_int8_2d ) ) THEN out_str = 'int8' WRITE( file_id ) out_str WRITE( file_id ) var_int8_2d ELSEIF ( PRESENT( var_int8_3d ) ) THEN out_str = 'int8' WRITE( file_id ) out_str WRITE( file_id ) var_int8_3d !-- 16bit integer output ELSEIF ( PRESENT( var_int16_0d ) ) THEN out_str = 'int16' WRITE( file_id ) out_str WRITE( file_id ) var_int16_0d ELSEIF ( PRESENT( var_int16_1d ) ) THEN out_str = 'int16' WRITE( file_id ) out_str WRITE( file_id ) var_int16_1d ELSEIF ( PRESENT( var_int16_2d ) ) THEN out_str = 'int16' WRITE( file_id ) out_str WRITE( file_id ) var_int16_2d ELSEIF ( PRESENT( var_int16_3d ) ) THEN out_str = 'int16' WRITE( file_id ) out_str WRITE( file_id ) var_int16_3d !-- 32bit integer output ELSEIF ( PRESENT( var_int32_0d ) ) THEN out_str = 'int32' WRITE( file_id ) out_str WRITE( file_id ) var_int32_0d ELSEIF ( PRESENT( var_int32_1d ) ) THEN out_str = 'int32' WRITE( file_id ) out_str WRITE( file_id ) var_int32_1d ELSEIF ( PRESENT( var_int32_2d ) ) THEN out_str = 'int32' WRITE( file_id ) out_str WRITE( file_id ) var_int32_2d ELSEIF ( PRESENT( var_int32_3d ) ) THEN out_str = 'int32' WRITE( file_id ) out_str WRITE( file_id ) var_int32_3d !-- working-precision integer output ELSEIF ( PRESENT( var_intwp_0d ) ) THEN out_str = 'intwp' WRITE( file_id ) out_str WRITE( file_id ) var_intwp_0d ELSEIF ( PRESENT( var_intwp_1d ) ) THEN out_str = 'intwp' WRITE( file_id ) out_str WRITE( file_id ) var_intwp_1d ELSEIF ( PRESENT( var_intwp_2d ) ) THEN out_str = 'intwp' WRITE( file_id ) out_str WRITE( file_id ) var_intwp_2d ELSEIF ( PRESENT( var_intwp_3d ) ) THEN out_str = 'intwp' WRITE( file_id ) out_str WRITE( file_id ) var_intwp_3d !-- 32bit real output ELSEIF ( PRESENT( var_real32_0d ) ) THEN out_str = 'real32' WRITE( file_id ) out_str WRITE( file_id ) var_real32_0d ELSEIF ( PRESENT( var_real32_1d ) ) THEN out_str = 'real32' WRITE( file_id ) out_str WRITE( file_id ) var_real32_1d ELSEIF ( PRESENT( var_real32_2d ) ) THEN out_str = 'real32' WRITE( file_id ) out_str WRITE( file_id ) var_real32_2d ELSEIF ( PRESENT( var_real32_3d ) ) THEN out_str = 'real32' WRITE( file_id ) out_str WRITE( file_id ) var_real32_3d !-- 64bit real output ELSEIF ( PRESENT( var_real64_0d ) ) THEN out_str = 'real64' WRITE( file_id ) out_str WRITE( file_id ) var_real64_0d ELSEIF ( PRESENT( var_real64_1d ) ) THEN out_str = 'real64' WRITE( file_id ) out_str WRITE( file_id ) var_real64_1d ELSEIF ( PRESENT( var_real64_2d ) ) THEN out_str = 'real64' WRITE( file_id ) out_str WRITE( file_id ) var_real64_2d ELSEIF ( PRESENT( var_real64_3d ) ) THEN out_str = 'real64' WRITE( file_id ) out_str WRITE( file_id ) var_real64_3d !-- working-precision real output ELSEIF ( PRESENT( var_realwp_0d ) ) THEN out_str = 'realwp' WRITE( file_id ) out_str WRITE( file_id ) var_realwp_0d ELSEIF ( PRESENT( var_realwp_1d ) ) THEN out_str = 'realwp' WRITE( file_id ) out_str WRITE( file_id ) var_realwp_1d ELSEIF ( PRESENT( var_realwp_2d ) ) THEN out_str = 'realwp' WRITE( file_id ) out_str WRITE( file_id ) var_realwp_2d ELSEIF ( PRESENT( var_realwp_3d ) ) THEN out_str = 'realwp' WRITE( file_id ) out_str WRITE( file_id ) var_realwp_3d ELSE return_value = 1 CALL internal_message( 'error', routine_name // ': no values given' ) ENDIF ENDIF END SUBROUTINE binary_write_variable !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Close opened files. !--------------------------------------------------------------------------------------------------! SUBROUTINE binary_finalize( file_id, return_value ) CHARACTER(LEN=charlen) :: out_str !< output string CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_finalize' !< name of this routine INTEGER(iwp), INTENT(IN) :: file_id !< file ID INTEGER(iwp), INTENT(OUT) :: return_value !< return value IF ( config_file_open ) THEN out_str = '*** end config file ***' WRITE( config_file_unit ) out_str CLOSE( config_file_unit, IOSTAT=return_value ) IF ( return_value /= 0 ) THEN CALL internal_message( 'error', routine_name // ': cannot close configuration file' ) ELSE config_file_open = .FALSE. ENDIF ELSE return_value = 0 ENDIF IF ( return_value == 0 ) THEN WRITE(temp_string,*) file_id CALL internal_message( 'debug', routine_name // & ': close file (file_id=' // TRIM( temp_string ) // ')' ) CLOSE( file_id, IOSTAT=return_value ) IF ( return_value /= 0 ) THEN WRITE(temp_string,*) file_id CALL internal_message( 'error', & routine_name // & ': cannot close file (file_id=' // TRIM( temp_string ) // ')' ) ENDIF ENDIF END SUBROUTINE binary_finalize !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Message routine writing debug information into the debug file !> or creating the error message string. !--------------------------------------------------------------------------------------------------! SUBROUTINE internal_message( level, string ) CHARACTER(LEN=*), INTENT(IN) :: level !< message importance level CHARACTER(LEN=*), INTENT(IN) :: string !< message string IF ( TRIM( level ) == 'error' ) THEN WRITE( internal_error_message, '(A,A)' ) ': ', string ELSEIF ( TRIM( level ) == 'debug' .AND. print_debug_output ) THEN WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string FLUSH( debug_output_unit ) ENDIF END SUBROUTINE internal_message !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Return the last created error message. !--------------------------------------------------------------------------------------------------! SUBROUTINE binary_get_error_message( error_message ) CHARACTER(LEN=800), INTENT(OUT) :: error_message !< return error message to main program error_message = internal_error_message END SUBROUTINE binary_get_error_message END MODULE data_output_binary_module