!> @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(