!> @file data_output_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_module.f90 4124 2019-07-26 14:22:39Z gronemeier $
! Initial revision
!
!
! Authors:
! --------
!> @author Tobias Gronemeier
!> @author Helge Knoop
!
!--------------------------------------------------------------------------------------------------!
! Description:
! ------------
!> Data-output module to handle output of variables into output files.
!>
!> The module first creates an interal database containing all meta data of all
!> output quantities. Output files are then inititialized and prepared for
!> storing data, which are finally written to file.
!>
!> @todo Convert variable if type of given values do not fit specified type.
!> @todo Remove iwp from index (and similar) variables.
!--------------------------------------------------------------------------------------------------!
MODULE data_output_module
USE kinds
USE data_output_netcdf4_module, &
ONLY: netcdf4_init_dimension, &
netcdf4_get_error_message, &
netcdf4_init_end, &
netcdf4_init_module, &
netcdf4_init_variable, &
netcdf4_finalize, &
netcdf4_open_file, &
netcdf4_write_attribute, &
netcdf4_write_variable
USE data_output_binary_module, &
ONLY: 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
IMPLICIT NONE
INTEGER(iwp), PARAMETER :: charlen = 100_iwp !< maximum length of character variables
TYPE attribute_type
CHARACTER(LEN=charlen) :: data_type = '' !< data type
CHARACTER(LEN=charlen) :: name !< attribute name
CHARACTER(LEN=charlen) :: value_char !< attribute value if character
INTEGER(KIND=1) :: value_int8 !< attribute value if 8bit integer
INTEGER(KIND=2) :: value_int16 !< attribute value if 16bit integer
INTEGER(KIND=4) :: value_int32 !< attribute value if 32bit integer
REAL(KIND=4) :: value_real32 !< attribute value if 32bit real
REAL(KIND=8) :: value_real64 !< attribute value if 64bit real
END TYPE attribute_type
TYPE variable_type
CHARACTER(LEN=charlen) :: data_type = '' !< data type
CHARACTER(LEN=charlen) :: name !< variable name
INTEGER(iwp) :: id = -1 !< id within file
LOGICAL :: is_global = .FALSE. !< true if global variable
CHARACTER(LEN=charlen), DIMENSION(:), ALLOCATABLE :: dimension_names !< list of dimension names
INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: dimension_ids !< list of dimension ids
TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes
END TYPE variable_type
TYPE dimension_type
CHARACTER(LEN=charlen) :: data_type = '' !< data type
CHARACTER(LEN=charlen) :: name !< dimension name
INTEGER(iwp) :: id = -1 !< dimension id within file
INTEGER(iwp) :: length !< length of dimension
INTEGER(iwp) :: length_mask !< length of masked dimension
INTEGER(iwp) :: var_id = -1 !< associated variable id within file
LOGICAL :: is_masked = .FALSE. !< true if masked
INTEGER(iwp), DIMENSION(2) :: bounds !< lower and upper bound of dimension
INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: masked_indices !< list of masked indices of dimension
INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: masked_values_int8 !< masked dimension values if 16bit integer
INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: masked_values_int16 !< masked dimension values if 16bit integer
INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_int32 !< masked dimension values if 32bit integer
INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: masked_values_intwp !< masked dimension values if working-precision int
INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: values_int8 !< dimension values if 16bit integer
INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: values_int16 !< dimension values if 16bit integer
INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: values_int32 !< dimension values if 32bit integer
INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: values_intwp !< dimension values if working-precision integer
LOGICAL, DIMENSION(:), ALLOCATABLE :: mask !< mask
REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_real32 !< masked dimension values if 32bit real
REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: masked_values_real64 !< masked dimension values if 64bit real
REAL(wp), DIMENSION(:), ALLOCATABLE :: masked_values_realwp !< masked dimension values if working-precision real
REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: values_real32 !< dimension values if 32bit real
REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: values_real64 !< dimension values if 64bit real
REAL(wp), DIMENSION(:), ALLOCATABLE :: values_realwp !< dimension values if working-precision real
TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes
END TYPE dimension_type
TYPE file_type
CHARACTER(LEN=charlen) :: format = '' !< file format
CHARACTER(LEN=charlen) :: name = '' !< file name
INTEGER(iwp) :: id = -1 !< id of file
LOGICAL :: is_init = .FALSE. !< true if initialized
TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes
TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dimensions !< list of dimensions
TYPE(variable_type), DIMENSION(:), ALLOCATABLE :: variables !< list of variables
END TYPE file_type
CHARACTER(LEN=charlen) :: output_file_format = 'binary' !< file format (namelist parameter)
CHARACTER(LEN=charlen) :: output_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) :: debug_output_unit !< Fortran Unit Number of the debug-output file
INTEGER :: nf = 0 !< number of files
INTEGER :: master_rank = 0 !< master rank for tasks to be executed by single PE only
INTEGER :: output_group_comm !< MPI communicator addressing all MPI ranks which participate in output
INTEGER(iwp), PARAMETER :: no_var_id = -1 !< value of var_id if no variable is selected
LOGICAL :: print_debug_output = .FALSE. !< if true, debug output is printed
TYPE(file_type), DIMENSION(:), ALLOCATABLE :: files !< file list
SAVE
PRIVATE
!> Initialize the data-output module
INTERFACE dom_init
MODULE PROCEDURE dom_init
END INTERFACE dom_init
!> Add files to database
INTERFACE dom_def_file
MODULE PROCEDURE dom_def_file
END INTERFACE dom_def_file
!> Add dimensions to database
INTERFACE dom_def_dim
MODULE PROCEDURE dom_def_dim
END INTERFACE dom_def_dim
!> Add variables to database
INTERFACE dom_def_var
MODULE PROCEDURE dom_def_var
END INTERFACE dom_def_var
!> Add attributes to database
INTERFACE dom_def_att
MODULE PROCEDURE dom_def_att_char
MODULE PROCEDURE dom_def_att_int8
MODULE PROCEDURE dom_def_att_int16
MODULE PROCEDURE dom_def_att_int32
MODULE PROCEDURE dom_def_att_real32
MODULE PROCEDURE dom_def_att_real64
END INTERFACE dom_def_att
!> Prepare for output: evaluate database and create files
INTERFACE dom_start_output
MODULE PROCEDURE dom_start_output
END INTERFACE dom_start_output
!> Write variables to file
INTERFACE dom_write_var
MODULE PROCEDURE dom_write_var
END INTERFACE dom_write_var
!> Last actions required for output befor termination
INTERFACE dom_finalize_output
MODULE PROCEDURE dom_finalize_output
END INTERFACE dom_finalize_output
!> Return error message
INTERFACE dom_get_error_message
MODULE PROCEDURE dom_get_error_message
END INTERFACE dom_get_error_message
PUBLIC &
dom_database_debug_output, &
dom_def_att, &
dom_def_dim, &
dom_def_file, &
dom_def_var, &
dom_finalize_output, &
dom_get_error_message, &
dom_init, &
dom_start_output, &
dom_write_var
CONTAINS
!--------------------------------------------------------------------------------------------------!
! Description:
! ------------
!> Initialize data-output module
!--------------------------------------------------------------------------------------------------!
SUBROUTINE dom_init( file_suffix_of_output_group, mpi_comm_of_output_group, master_output_rank, &
program_debug_output_unit, debug_output )
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_suffix_of_output_group !< file-name suffix added to each file;
!> must be unique for each output group
INTEGER, INTENT(IN), OPTIONAL :: master_output_rank !< MPI rank executing tasks which must
!> be executed by a single PE only
INTEGER, INTENT(IN) :: mpi_comm_of_output_group !< MPI communicator specifying the MPI group
!> which participate in the output
INTEGER, INTENT(IN) :: program_debug_output_unit !< file unit number for debug output
LOGICAL, INTENT(IN) :: debug_output !< if true, debug output is printed
IF ( PRESENT( file_suffix_of_output_group ) ) output_file_suffix = file_suffix_of_output_group
IF ( PRESENT( master_output_rank ) ) master_rank = master_output_rank
output_group_comm = mpi_comm_of_output_group
debug_output_unit = program_debug_output_unit
print_debug_output = debug_output
CALL binary_init_module( output_file_suffix, output_group_comm, master_rank, &
debug_output_unit, debug_output, no_var_id )
CALL netcdf4_init_module( output_file_suffix, output_group_comm, master_rank, &
debug_output_unit, debug_output, no_var_id )
END SUBROUTINE dom_init
!--------------------------------------------------------------------------------------------------!
! Description:
! ------------
!> Debugging output. Print contents of output database to debug_output_unit.
!--------------------------------------------------------------------------------------------------!
SUBROUTINE dom_database_debug_output
CHARACTER(LEN=*), PARAMETER :: separation_string = '---' !< string separating blocks in output
CHARACTER(LEN=50) :: format1 !< format for write statements
CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_database_debug_output' !< name of this routine
INTEGER :: f !< loop index
INTEGER, PARAMETER :: indent_depth = 3 !< space per indentation
INTEGER :: indent_level !< indentation level
INTEGER, PARAMETER :: max_keyname_length = 6 !< length of longest key name
INTEGER :: natt !< number of attributes
INTEGER :: ndim !< number of dimensions
INTEGER :: nvar !< number of variables
CALL internal_message( 'debug', routine_name // ': write data base to debug output' )
WRITE( debug_output_unit, '(A)' ) 'DOM data base:'
WRITE( debug_output_unit, '(A)' ) REPEAT( separation_string // ' ', 4 )
IF ( .NOT. ALLOCATED( files ) .OR. nf == 0 ) THEN
WRITE( debug_output_unit, '(A)' ) 'database is empty'
ELSE
indent_level = 1
WRITE( format1, '(A,I3,A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A,T', &
indent_level * indent_depth + 1 + max_keyname_length, &
',(": ")'
DO f = 1, nf
natt = 0
ndim = 0
nvar = 0
IF ( ALLOCATED( files(f)%attributes ) ) natt = SIZE( files(f)%attributes )
IF ( ALLOCATED( files(f)%dimensions ) ) ndim = SIZE( files(f)%dimensions )
IF ( ALLOCATED( files(f)%variables ) ) nvar = SIZE( files(f)%variables )
WRITE( debug_output_unit, '(A)' ) 'file:'
WRITE( debug_output_unit, TRIM( format1 ) // ',A)' ) 'name', TRIM( files(f)%name )
WRITE( debug_output_unit, TRIM( format1 ) // ',A)' ) 'format', TRIM( files(f)%format )
WRITE( debug_output_unit, TRIM( format1 ) // ',I7)' ) 'id', files(f)%id
WRITE( debug_output_unit, TRIM( format1 ) // ',L1)' ) 'is init', files(f)%is_init
WRITE( debug_output_unit, TRIM( format1 ) // ',I7)' ) '#atts', natt
WRITE( debug_output_unit, TRIM( format1 ) // ',I7)' ) '#dims', ndim
WRITE( debug_output_unit, TRIM( format1 ) // ',I7)' ) '#vars', nvar
IF ( natt /= 0 ) CALL print_attributes( indent_level, files(f)%attributes )
IF ( ndim /= 0 ) CALL print_dimensions( indent_level, files(f)%dimensions )
IF ( nvar /= 0 ) CALL print_variables( indent_level, files(f)%variables )
WRITE( debug_output_unit, '(/A/)' ) REPEAT( separation_string // ' ', 4 )
ENDDO
ENDIF
CONTAINS
!--------------------------------------------------------------------------------------------!
! Description:
! ------------
!> Print list of attributes.
!--------------------------------------------------------------------------------------------!
SUBROUTINE print_attributes( indent_level, attributes )
CHARACTER(LEN=50) :: format1 !< format for write statements
CHARACTER(LEN=50) :: format2 !< format for write statements
INTEGER :: i !< loop index
INTEGER, INTENT(IN) :: indent_level !< indentation level
INTEGER, PARAMETER :: max_keyname_length = 6 !< length of longest key name
INTEGER :: nelement !< number of elements to print
TYPE(attribute_type), DIMENSION(:), INTENT(IN) :: attributes !< list of attributes
WRITE( format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
WRITE( format2, '(A,I3,A,I3,A)' ) &
'(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
WRITE( debug_output_unit, TRIM( format1 ) // ',A)' ) REPEAT( separation_string // ' ', 4 )
WRITE( debug_output_unit, TRIM( format1 ) // ')' ) 'attributes:'
nelement = SIZE( attributes )
DO i = 1, nelement
WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
'name', TRIM( attributes(i)%name )
WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
'type', TRIM( attributes(i)%data_type )
IF ( TRIM( attributes(i)%data_type ) == 'char' ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
'value', TRIM( attributes(i)%value_char )
ELSEIF ( TRIM( attributes(i)%data_type ) == 'int8' ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I4)' ) &
'value', attributes(i)%value_int8
ELSEIF ( TRIM( attributes(i)%data_type ) == 'int16' ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I6)' ) &
'value', attributes(i)%value_int16
ELSEIF ( TRIM( attributes(i)%data_type ) == 'int32' ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I11)' ) &
'value', attributes(i)%value_int32
ELSEIF ( TRIM( attributes(i)%data_type ) == 'real32' ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',E14.7)' ) &
'value', attributes(i)%value_real32
ELSEIF ( TRIM(attributes(i)%data_type) == 'real64' ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',E22.15)' ) &
'value', attributes(i)%value_real64
ENDIF
IF ( i < nelement ) &
WRITE( debug_output_unit, TRIM( format1 ) // ')' ) separation_string
ENDDO
END SUBROUTINE print_attributes
!--------------------------------------------------------------------------------------------!
! Description:
! ------------
!> Print list of dimensions.
!--------------------------------------------------------------------------------------------!
SUBROUTINE print_dimensions( indent_level, dimensions )
CHARACTER(LEN=50) :: format1 !< format for write statements
CHARACTER(LEN=50) :: format2 !< format for write statements
INTEGER :: i !< loop index
INTEGER, INTENT(IN) :: indent_level !< indentation level
INTEGER :: j !< loop index
INTEGER, PARAMETER :: max_keyname_length = 15 !< length of longest key name
INTEGER :: nelement !< number of elements to print
LOGICAL :: is_masked !< true if dimension is masked
TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< list of dimensions
WRITE( format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
WRITE( format2, '(A,I3,A,I3,A)' ) &
'(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
WRITE( debug_output_unit, TRIM( format1 ) // ',A)' ) REPEAT( separation_string // ' ', 4 )
WRITE( debug_output_unit, TRIM( format1 ) // ')' ) 'dimensions:'
nelement = SIZE( dimensions )
DO i = 1, nelement
is_masked = dimensions(i)%is_masked
!-- Print general information
WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
'name', TRIM( dimensions(i)%name )
WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
'type', TRIM( dimensions(i)%data_type )
WRITE( debug_output_unit, TRIM( format2 ) // ',I7)' ) &
'id', dimensions(i)%id
WRITE( debug_output_unit, TRIM( format2 ) // ',I7)' ) &
'length', dimensions(i)%length
WRITE( debug_output_unit, TRIM( format2 ) // ',I7,A,I7)' ) &
'bounds', dimensions(i)%bounds(1), ',', dimensions(i)%bounds(2)
WRITE( debug_output_unit, TRIM( format2 ) // ',L1)' ) &
'is masked', dimensions(i)%is_masked
!-- Print information about mask
IF ( is_masked ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I7)' ) &
'masked length', dimensions(i)%length_mask
WRITE( debug_output_unit, TRIM( format2 ) // ',L1)', ADVANCE='no' ) &
'mask', dimensions(i)%mask(dimensions(i)%bounds(1))
DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
WRITE( debug_output_unit, '(A,L1)', ADVANCE='no' ) ',', dimensions(i)%mask(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
WRITE( debug_output_unit, TRIM( format2 ) // ',I6)', ADVANCE='no' ) &
'masked indices', dimensions(i)%masked_indices(0)
DO j = 1, dimensions(i)%length_mask-1
WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
',', dimensions(i)%masked_indices(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
ENDIF
!-- Print saved values
IF ( ALLOCATED( dimensions(i)%values_int8 ) ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I4)', ADVANCE='no' ) &
'values', dimensions(i)%values_int8(dimensions(i)%bounds(1))
DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) &
',', dimensions(i)%values_int8(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
IF ( is_masked ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I4)', ADVANCE='no' ) &
'masked values', dimensions(i)%masked_values_int8(0)
DO j = 1, dimensions(i)%length_mask-1
WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) &
',', dimensions(i)%masked_values_int8(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
ENDIF
ELSEIF ( ALLOCATED( dimensions(i)%values_int16 ) ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I6)', ADVANCE='no' ) &
'values', dimensions(i)%values_int16(dimensions(i)%bounds(1))
DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
',', dimensions(i)%values_int16(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
IF ( is_masked ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I6)', ADVANCE='no' ) &
'masked values', dimensions(i)%masked_values_int16(0)
DO j = 1, dimensions(i)%length_mask-1
WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) &
',', dimensions(i)%masked_values_int16(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
ENDIF
ELSEIF ( ALLOCATED( dimensions(i)%values_int32 ) ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I11)', ADVANCE='no' ) &
'values', dimensions(i)%values_int32(dimensions(i)%bounds(1))
DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
',', dimensions(i)%values_int32(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
IF ( is_masked ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I11)', ADVANCE='no' ) &
'masked values', dimensions(i)%masked_values_int32(0)
DO j = 1, dimensions(i)%length_mask-1
WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
',', dimensions(i)%masked_values_int32(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
ENDIF
ELSEIF ( ALLOCATED( dimensions(i)%values_intwp ) ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I11)', ADVANCE='no' ) &
'values', dimensions(i)%values_intwp(dimensions(i)%bounds(1))
DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
',', dimensions(i)%values_intwp(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
IF ( is_masked ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',I11)', ADVANCE='no' ) &
'masked values', dimensions(i)%masked_values_intwp(0)
DO j = 1, dimensions(i)%length_mask-1
WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) &
',', dimensions(i)%masked_values_intwp(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
ENDIF
ELSEIF ( ALLOCATED( dimensions(i)%values_real32 ) ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',E14.7)', ADVANCE='no' ) &
'values', dimensions(i)%values_real32(dimensions(i)%bounds(1))
DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) &
',', dimensions(i)%values_real32(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
IF ( is_masked ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',E14.7)', ADVANCE='no' ) &
'masked values', dimensions(i)%masked_values_real32(0)
DO j = 1, dimensions(i)%length_mask-1
WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) &
',', dimensions(i)%masked_values_real32(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
ENDIF
ELSEIF ( ALLOCATED( dimensions(i)%values_real64 ) ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',E22.15)', ADVANCE='no' ) &
'values', dimensions(i)%values_real64(dimensions(i)%bounds(1))
DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
',', dimensions(i)%values_real64(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
IF ( is_masked ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',E22.15)', ADVANCE='no' ) &
'masked values', dimensions(i)%masked_values_real64(0)
DO j = 1, dimensions(i)%length_mask-1
WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
',', dimensions(i)%masked_values_real64(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
ENDIF
ELSEIF ( ALLOCATED( dimensions(i)%values_realwp ) ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',E22.15)', ADVANCE='no' ) &
'values', dimensions(i)%values_realwp(dimensions(i)%bounds(1))
DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2)
WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
',', dimensions(i)%values_realwp(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
IF ( is_masked ) THEN
WRITE( debug_output_unit, TRIM( format2 ) // ',E22.15)', ADVANCE='no' ) &
'masked values', dimensions(i)%masked_values_realwp(0)
DO j = 1, dimensions(i)%length_mask-1
WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) &
',', dimensions(i)%masked_values_realwp(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
ENDIF
ENDIF
IF ( ALLOCATED( dimensions(i)%attributes ) ) &
CALL print_attributes( indent_level+1, dimensions(i)%attributes )
IF ( i < nelement ) &
WRITE( debug_output_unit, TRIM( format1 ) // ')' ) separation_string
ENDDO
END SUBROUTINE print_dimensions
!--------------------------------------------------------------------------------------------!
! Description:
! ------------
!> Print list of variables.
!--------------------------------------------------------------------------------------------!
SUBROUTINE print_variables( indent_level, variables )
CHARACTER(LEN=50) :: format1 !< format for write statements
CHARACTER(LEN=50) :: format2 !< format for write statements
INTEGER :: i !< loop index
INTEGER, INTENT(IN) :: indent_level !< indentation level
INTEGER :: j !< loop index
INTEGER, PARAMETER :: max_keyname_length = 16 !< length of longest key name
INTEGER :: nelement !< number of elements to print
TYPE(variable_type), DIMENSION(:), INTENT(IN) :: variables !< list of variables
WRITE( format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A'
WRITE( format2, '(A,I3,A,I3,A)' ) &
'(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', &
( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")'
WRITE( debug_output_unit, TRIM( format1 ) // ',A)' ) REPEAT( separation_string // ' ', 4 )
WRITE( debug_output_unit, TRIM( format1 ) // ')' ) 'variables:'
nelement = SIZE( variables )
DO i = 1, nelement
WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
'name', TRIM( variables(i)%name )
WRITE( debug_output_unit, TRIM( format2 ) // ',A)' ) &
'type', TRIM( variables(i)%data_type )
WRITE( debug_output_unit, TRIM( format2 ) // ',I7)' ) &
'id', variables(i)%id
WRITE( debug_output_unit, TRIM( format2 ) // ',L1)' ) &
'is global', variables(i)%is_global
WRITE( debug_output_unit, TRIM( format2 ) // ',A)', ADVANCE='no' ) &
'dimension names', TRIM( variables(i)%dimension_names(1) )
DO j = 2, SIZE( variables(i)%dimension_names )
WRITE( debug_output_unit, '(A,A)', ADVANCE='no' ) &
',', TRIM( variables(i)%dimension_names(j) )
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
WRITE( debug_output_unit, TRIM( format2 ) // ',I7)', ADVANCE='no' ) &
'dimension ids', variables(i)%dimension_ids(1)
DO j = 2, SIZE( variables(i)%dimension_names )
WRITE( debug_output_unit, '(A,I7)', ADVANCE='no' ) &
',', variables(i)%dimension_ids(j)
ENDDO
WRITE( debug_output_unit, '(A)' ) '' ! write line-end
IF ( ALLOCATED( variables(i)%attributes ) ) &
CALL print_attributes( indent_level+1, variables(i)%attributes )
IF ( i < nelement ) &
WRITE( debug_output_unit, TRIM( format1 ) // ')' ) separation_string
ENDDO
END SUBROUTINE print_variables
END SUBROUTINE dom_database_debug_output
!--------------------------------------------------------------------------------------------------!
! Description:
! ------------
!> Define output file.
!--------------------------------------------------------------------------------------------------!
FUNCTION dom_def_file( filename, format ) RESULT( return_value )
CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file to be created
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: format !< format of file to be created
CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_file' !< name of this routine
INTEGER(iwp) :: f !< loop index
INTEGER(iwp) :: return_value !< return value
TYPE(file_type), DIMENSION(:), ALLOCATABLE :: files_tmp !< temporary file list
return_value = 0
CALL internal_message( 'debug', routine_name // ': define file "' // TRIM( filename ) // '"' )
!-- Allocate file list or extend it by 1
IF ( .NOT. ALLOCATED( files ) ) THEN
nf = 1
ALLOCATE( files(nf) )
ELSE
nf = SIZE( files )
!-- Check if file already exists
DO f = 1, nf
IF ( files(f)%name == TRIM( filename ) ) THEN
return_value = 1
CALL internal_message( 'error', routine_name // ': file "' // TRIM( filename ) // &
'" already exists' )
EXIT
ENDIF
ENDDO
!-- Extend file list
IF ( return_value == 0 ) THEN
ALLOCATE( files_tmp(nf) )
files_tmp = files
DEALLOCATE( files )
nf = nf + 1
ALLOCATE( files(nf) )
files(:nf-1) = files_tmp
DEALLOCATE( files_tmp )
ENDIF
ENDIF
!-- Add new file to database
IF ( return_value == 0 ) THEN
files(nf)%name = TRIM( filename )
IF ( PRESENT( format ) ) THEN
files(nf)%format = TRIM( format )
ELSE
files(nf)%format = TRIM( output_file_format )
ENDIF
ENDIF
END FUNCTION dom_def_file
!--------------------------------------------------------------------------------------------------!
! Description:
! ------------
!> Define dimension of type integer.
!>
!> @todo Convert given values into selected output_type.
!--------------------------------------------------------------------------------------------------!
FUNCTION dom_def_dim( filename, name, output_type, bounds, &
values_int8, values_int16, values_int32, values_intwp, &
values_real32, values_real64, values_realwp, &
mask ) RESULT( return_value )
CHARACTER(LEN=*), INTENT(IN) :: filename !< name of file
CHARACTER(LEN=*), INTENT(IN) :: name !< name of dimension
CHARACTER(LEN=*), INTENT(IN) :: output_type !< data type of dimension variable in output file
CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_dim' !< name of this routine
INTEGER(iwp) :: d !< loop index
INTEGER(iwp) :: f !< loop index
INTEGER(iwp) :: i !< loop index
INTEGER(iwp) :: j !< loop index
INTEGER(iwp) :: ndim !< number of dimensions in file
INTEGER(iwp) :: return_value !< return value
INTEGER(iwp), DIMENSION(:), INTENT(IN) :: bounds !< lower and upper bound of dimension variable
INTEGER(KIND=1), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int8 !< values of dimension
INTEGER(KIND=2), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int16 !< values of dimension
INTEGER(KIND=4), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int32 !< values of dimension
INTEGER(iwp), DIMENSION(:), INTENT(IN), OPTIONAL :: values_intwp !< values of dimension
LOGICAL, DIMENSION(:), INTENT(IN), OPTIONAL :: mask !< mask of dimesion
REAL(KIND=4), DIMENSION(:), INTENT(IN), OPTIONAL :: values_real32 !< values of dimension
REAL(KIND=8), DIMENSION(:), INTENT(IN), OPTIONAL :: values_real64 !< values of dimension
REAL(wp), DIMENSION(:), INTENT(IN), OPTIONAL :: values_realwp !< values of dimension
TYPE(dimension_type) :: dimension !< new dimension
TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dims_tmp !< temporary dimension list
return_value = 0
CALL internal_message( 'debug', routine_name // &
': define dimension "' // TRIM( name ) // &
'" in file "' // TRIM( filename ) // '"' )
dimension%name = TRIM( name )
dimension%data_type = TRIM( output_type )
!-- Check dimension bounds and allocate dimension according to bounds
IF ( SIZE( bounds ) == 1 ) THEN
!-- Dimension has only lower bound, which means it changes its size
!-- during simulation.
!-- Set length to -1 as indicator.
dimension%bounds(:) = bounds(1)
dimension%length = -1_iwp
IF ( PRESENT( mask ) ) THEN
return_value = 1
CALL internal_message( 'error', routine_name // &
': unlimited dimension "' // TRIM( name ) // &
'" in file "' // TRIM( filename ) // '" cannot be masked' )
ENDIF
ELSEIF ( SIZE( bounds ) == 2 ) THEN
dimension%bounds = bounds
dimension%length = bounds(2) - bounds(1) + 1
!-- Save dimension values
IF ( PRESENT( values_int8 ) ) THEN
ALLOCATE( dimension%values_int8(dimension%bounds(1):dimension%bounds(2)) )
IF ( SIZE( values_int8 ) == dimension%length ) THEN
dimension%values_int8 = values_int8
ELSEIF ( SIZE( values_int8 ) == 1 ) THEN
dimension%values_int8(:) = values_int8
ELSE
return_value = 2
ENDIF
ELSEIF( PRESENT( values_int16 ) ) THEN
ALLOCATE( dimension%values_int16(dimension%bounds(1):dimension%bounds(2)) )
IF ( SIZE( values_int16 ) == dimension%length ) THEN
dimension%values_int16 = values_int16
ELSEIF ( SIZE( values_int16 ) == 1 ) THEN
dimension%values_int16(:) = values_int16
ELSE
return_value = 2
ENDIF
ELSEIF( PRESENT( values_int32 ) ) THEN
ALLOCATE( dimension%values_int32(dimension%bounds(1):dimension%bounds(2)) )
IF ( SIZE( values_int32 ) == dimension%length ) THEN
dimension%values_int32 = values_int32
ELSEIF ( SIZE( values_int32 ) == 1 ) THEN
dimension%values_int32(:) = values_int32
ELSE
return_value = 2
ENDIF
ELSEIF( PRESENT( values_intwp ) ) THEN
ALLOCATE( dimension%values_intwp(dimension%bounds(1):dimension%bounds(2)) )
IF ( SIZE( values_intwp ) == dimension%length ) THEN
dimension%values_intwp = values_intwp
ELSEIF ( SIZE( values_intwp ) == 1 ) THEN
dimension%values_intwp(:) = values_intwp
ELSE
return_value = 2
ENDIF
ELSEIF( PRESENT( values_real32 ) ) THEN
ALLOCATE( dimension%values_real32(dimension%bounds(1):dimension%bounds(2)) )
IF ( SIZE( values_real32 ) == dimension%length ) THEN
dimension%values_real32 = values_real32
ELSEIF ( SIZE( values_real32 ) == 1 ) THEN
dimension%values_real32(:) = values_real32
ELSE
return_value = 2
ENDIF
ELSEIF( PRESENT( values_real64 ) ) THEN
ALLOCATE( dimension%values_real64(dimension%bounds(1):dimension%bounds(2)) )
IF ( SIZE( values_real64 ) == dimension%length ) THEN
dimension%values_real64 = values_real64
ELSEIF ( SIZE( values_real64 ) == 1 ) THEN
dimension%values_real64(:) = values_real64
ELSE
return_value = 2
ENDIF
ELSEIF( PRESENT( values_realwp ) ) THEN
ALLOCATE( dimension%values_realwp(dimension%bounds(1):dimension%bounds(2)) )
IF ( SIZE( values_realwp ) == dimension%length ) THEN
dimension%values_realwp = values_realwp
ELSEIF ( SIZE( values_realwp ) == 1 ) THEN
dimension%values_realwp(:) = values_realwp
ELSE
return_value = 2
ENDIF
ELSE
return_value = 1
CALL internal_message( 'error', routine_name // ': ' // &
TRIM( name ) // ': no values given' )
ENDIF
IF ( return_value == 2 ) THEN
return_value = 1
CALL internal_message( 'error', routine_name // &
': dimension ' // TRIM( name ) // &
': number of values and given bounds do not match' )
ENDIF
!-- Initialize mask
IF ( PRESENT( mask ) .AND. return_value == 0 ) THEN
dimension%is_masked = .TRUE.
IF ( dimension%length == SIZE( mask ) ) THEN
dimension%length_mask = COUNT( mask )
ALLOCATE( dimension%mask(dimension%bounds(1):dimension%bounds(2)) )
ALLOCATE( dimension%masked_indices(0:dimension%length_mask-1) )
dimension%mask = mask
!-- Save masked positions and masked values
IF ( ALLOCATED( dimension%values_int8 ) ) THEN
ALLOCATE( dimension%masked_values_int8(0:dimension%length_mask-1) )
j = 0
DO i = 0, dimension%length-1
IF ( dimension%mask(i) ) THEN
dimension%masked_values_int8(j) = dimension%values_int8(i)
dimension%masked_indices(j) = i
j = j + 1
ENDIF
ENDDO
ELSEIF ( ALLOCATED( dimension%values_int16 ) ) THEN
ALLOCATE( dimension%masked_values_int16(0:dimension%length_mask-1) )
j = 0
DO i = 0, dimension%length-1
IF ( dimension%mask(i) ) THEN
dimension%masked_values_int16(j) = dimension%values_int16(i)
dimension%masked_indices(j) = i
j = j + 1
ENDIF
ENDDO
ELSEIF ( ALLOCATED( dimension%values_int32 ) ) THEN
ALLOCATE( dimension%masked_values_int32(0:dimension%length_mask-1) )
j = 0
DO i = 0, dimension%length-1
IF ( dimension%mask(i) ) THEN
dimension%masked_values_int32(j) = dimension%values_int32(i)
dimension%masked_indices(j) = i
j = j + 1
ENDIF
ENDDO
ELSEIF ( ALLOCATED( dimension%values_intwp ) ) THEN
ALLOCATE( dimension%masked_values_intwp(0:dimension%length_mask-1) )
j = 0
DO i = 0, dimension%length-1
IF ( dimension%mask(i) ) THEN
dimension%masked_values_intwp(j) = dimension%values_intwp(i)
dimension%masked_indices(j) = i
j = j + 1
ENDIF
ENDDO
ELSEIF ( ALLOCATED( dimension%values_real32 ) ) THEN
ALLOCATE( dimension%masked_values_real32(0:dimension%length_mask-1) )
j = 0
DO i = 0, dimension%length-1
IF ( dimension%mask(i) ) THEN
dimension%masked_values_real32(j) = dimension%values_real32(i)
dimension%masked_indices(j) = i
j = j + 1
ENDIF
ENDDO
ELSEIF ( ALLOCATED(dimension%values_real64) ) THEN
ALLOCATE( dimension%masked_values_real64(0:dimension%length_mask-1) )
j = 0
DO i = 0, dimension%length-1
IF ( dimension%mask(i) ) THEN
dimension%masked_values_real64(j) = dimension%values_real64(i)
dimension%masked_indices(j) = i
j = j + 1
ENDIF
ENDDO
ELSEIF ( ALLOCATED(dimension%values_realwp) ) THEN
ALLOCATE( dimension%masked_values_realwp(0:dimension%length_mask-1) )
j = 0
DO i = dimension%bounds(1), dimension%bounds(2) !> @todo change loop also for other data types
IF ( dimension%mask(i) ) THEN
dimension%masked_values_realwp(j) = dimension%values_realwp(i)
dimension%masked_indices(j) = i
j = j + 1
ENDIF
ENDDO
ENDIF
ELSE
return_value = 1
CALL internal_message( 'error', routine_name // &
': dimension ' // TRIM( name ) // &
': size of mask and given bounds do not match' )
ENDIF
ENDIF
ELSE
return_value = 1
CALL internal_message( 'error', routine_name // &
': at least one but no more than two bounds must be given ' // &
'(dimension "' // TRIM( name ) // &
'", file "' // TRIM( filename ) // &
'")!' )
ENDIF
!-- Add dimension to database
IF ( return_value == 0 ) THEN
DO f = 1, nf
IF ( TRIM( filename ) == files(f)%name ) THEN
IF ( files(f)%is_init ) THEN
return_value = 1
CALL internal_message( 'error', &
routine_name // ': file "' // TRIM( filename ) // &
'" is already initialized. No further dimension definition allowed!' )
EXIT
ELSEIF ( .NOT. ALLOCATED( files(f)%dimensions ) ) THEN
ndim = 1
ALLOCATE( files(f)%dimensions(ndim) )
ELSE
!-- Check if any variable of the same name as the new dimension is already defined
IF ( ALLOCATED( files(f)%variables ) ) THEN
DO i = 1, SIZE( files(f)%variables )
IF ( files(f)%variables(i)%name == dimension%name ) THEN
return_value = 1
CALL internal_message( 'error', routine_name // &
': file "' // TRIM( filename ) // &
'" already has a variable of name "' // &
TRIM( dimension%name ) // '" defined. ' // &
'Defining a dimension of the same ' // &
'name is not allowed.' )
EXIT
ENDIF
ENDDO
ENDIF
IF ( return_value == 0 ) THEN
!-- Check if dimension already exists in file
ndim = SIZE( files(f)%dimensions )
DO d = 1, ndim
IF ( files(f)%dimensions(d)%name == dimension%name ) THEN
return_value = 1
CALL internal_message( 'error', &
routine_name // &
': dimension "' // TRIM( name ) // &
'" already exists in file "' // TRIM( filename ) // '"' )
EXIT
ENDIF
ENDDO
!-- Extend dimension list
IF ( return_value == 0 ) THEN
ALLOCATE( dims_tmp(ndim) )
dims_tmp = files(f)%dimensions
DEALLOCATE( files(f)%dimensions )
ndim = ndim + 1
ALLOCATE( files(f)%dimensions(ndim) )
files(f)%dimensions(:ndim-1) = dims_tmp
DEALLOCATE( dims_tmp )
ENDIF
ENDIF
ENDIF
!-- Add new dimension to database
IF ( return_value == 0 ) files(f)%dimensions(ndim) = dimension
EXIT
ENDIF
ENDDO
IF ( f > nf ) THEN
return_value = 1
CALL internal_message( 'error', routine_name // &
': file not found (dimension "' // TRIM( name ) // &
'", file "' // TRIM( filename ) // '")!' )
ENDIF
ENDIF
END FUNCTION dom_def_dim
!--------------------------------------------------------------------------------------------------!
! Description:
! ------------
!> Add variable to database.
!> Example call:
!> dom_def_var( filename = 'DATA_OUTPUT_3D', &
!> name = 'u', &
!> dimension_names = (/'x ', 'y ', 'z ', 'time'/), &
!> output_type = 'real32' )
!> @note The order of dimensions must match in reversed order to the dimensions of the
!> corresponding variable array. The last given dimension can also be non-existent within the
!> variable array if at any given call of 'dom_write_var' for this variable, the last
!> dimension has only a single index.
!> Hence, the array 'u' must be allocated with dimension 'x' as its last dimension, preceded
!> by 'y', then 'z', and 'time' being the first dimension. If at any given write statement,
!> only a single index of dimension 'time' is to be written, the dimension can be non-present
!> in the variable array leaving dimension 'z' as the first dimension.
!> So, the variable array needs to be allocated like either:
!> ALLOCATE( u(