!> @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 4147 2019-08-07 09:42:31Z suehring $ ! corrected indentation according to coding standard ! ! 4141 2019-08-05 12:24:51Z 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. !> After defining all meta data, the output files are initialized and prepared for writing. When !> writing is finished, files can be finalized and closed. !> The order of calls are as follows: !> 1. Initialize the module via !> 'dom_init' !> 2. Define output files via (multiple calls of) !> 'dom_def_file', 'dom_def_att', 'dom_def_dim', 'dom_def_var' !> 3. Leave definition stage via !> 'dom_def_end' !> 4. Write output data into file via !> 'dom_write_var' !> 5. Finalize the output via !> 'dom_finalize_output' !> If any routine exits with a non-zero return value, the error message of the last encountered !> error can be fetched via 'dom_get_error_message'. !> For debugging purposes, the content of the database can be written to the debug output via !> 'dom_database_debug_output'. !> !> @todo Convert variable if type of given values do not fit specified type. !--------------------------------------------------------------------------------------------------! MODULE data_output_module USE kinds USE data_output_netcdf4_module, & ONLY: netcdf4_init_dimension, & netcdf4_get_error_message, & netcdf4_stop_file_header_definition, & 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_stop_file_header_definition, & binary_init_module, & binary_init_variable, & binary_open_file, & binary_write_attribute, & binary_write_variable IMPLICIT NONE INTEGER, PARAMETER :: charlen = 100 !< maximum length of character variables INTEGER, PARAMETER :: no_id = -1 !< default ID if no ID was assigned 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 :: id = no_id !< id within file LOGICAL :: is_global = .FALSE. !< true if global variable CHARACTER(LEN=charlen), DIMENSION(:), ALLOCATABLE :: dimension_names !< list of dimension names used by variable INTEGER, DIMENSION(:), ALLOCATABLE :: dimension_ids !< list of dimension ids used by variable 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 :: id = no_id !< dimension id within file INTEGER :: length !< length of dimension INTEGER :: length_mask !< length of masked dimension INTEGER :: variable_id = no_id !< associated variable id within file LOGICAL :: is_masked = .FALSE. !< true if masked INTEGER, DIMENSION(2) :: bounds !< lower and upper bound of dimension INTEGER, 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 :: id = no_id !< 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_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 :: debug_output_unit !< Fortran Unit Number of the debug-output file INTEGER :: nfiles = 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 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_def_end MODULE PROCEDURE dom_def_end END INTERFACE dom_def_end !> 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 !> Write database to debug output INTERFACE dom_database_debug_output MODULE PROCEDURE dom_database_debug_output END INTERFACE dom_database_debug_output PUBLIC & dom_init, & dom_def_file, & dom_def_dim, & dom_def_var, & dom_def_att, & dom_def_end, & dom_write_var, & dom_finalize_output, & dom_get_error_message, & dom_database_debug_output CONTAINS !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Initialize data-output module. !> Provide some general information of the main program. !> The optional argument 'file_suffix_of_output_group' defines a file suffix which is added to all !> output files. If multiple output groups (groups of MPI ranks, defined by !> 'mpi_comm_of_output_group') exist, a unique file suffix must be given for each group. This !> prevents that multiple groups try to open and write to the same output file. !--------------------------------------------------------------------------------------------------! 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_id ) CALL netcdf4_init_module( output_file_suffix, output_group_comm, master_rank, & debug_output_unit, debug_output, no_id ) END SUBROUTINE dom_init !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Define output file. !> Example call: !> status = dom_def_file( 'my_output_file_name', 'binary' ) !--------------------------------------------------------------------------------------------------! FUNCTION dom_def_file( file_name, file_format ) RESULT( return_value ) CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file to be created CHARACTER(LEN=*), INTENT(IN) :: file_format !< format of file to be created CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_file' !< name of this routine INTEGER :: f !< loop index INTEGER :: 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( file_name ) // '"' ) ! !-- Allocate file list or extend it by 1 IF ( .NOT. ALLOCATED( files ) ) THEN nfiles = 1 ALLOCATE( files(nfiles) ) ELSE nfiles = SIZE( files ) ! !-- Check if file already exists DO f = 1, nfiles IF ( files(f)%name == TRIM( file_name ) ) THEN return_value = 1 CALL internal_message( 'error', routine_name // & ': file "' // TRIM( file_name ) // '" already exists' ) EXIT ENDIF ENDDO ! !-- Extend file list IF ( return_value == 0 ) THEN ALLOCATE( files_tmp(nfiles) ) files_tmp = files DEALLOCATE( files ) nfiles = nfiles + 1 ALLOCATE( files(nfiles) ) files(:nfiles-1) = files_tmp DEALLOCATE( files_tmp ) ENDIF ENDIF ! !-- Add new file to database IF ( return_value == 0 ) THEN files(nfiles)%name = TRIM( file_name ) files(nfiles)%format = TRIM( file_format ) ENDIF END FUNCTION dom_def_file !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Define dimension. !> Dimensions can either be limited (a lower and upper bound is given) or unlimited (only a lower !> bound is given). Also, instead of providing all values of the dimension, a single value can be !> given which is then used to fill the entire dimension. !> An optional mask can be given to mask limited dimensions. !> Example call: !> - fixed dimension with 100 entries (values known): !> status = dom_def_dim( file_name='my_output_file_name', dimension_name='my_dimension', & !> output_type='real32', bounds=(/1,100/), & !> values_real32=my_dim(1:100), mask=my_dim_mask(1:100) ) !> - fixed dimension with 50 entries (values not yet known): !> status = dom_def_dim( file_name='my_output_file_name', dimension_name='my_dimension', & !> output_type='int32', bounds=(/0,49/), & !> values_int32=(/fill_value/) ) !> - masked dimension with 75 entries: !> status = dom_def_dim( file_name='my_output_file_name', dimension_name='my_dimension', & !> output_type='real64', bounds=(/101,175/), & !> values_real64=my_dim(1:75), mask=my_dim_mask(1:75) ) !> - unlimited dimension: !> status = dom_def_dim( file_name='my_output_file_name', dimension_name='my_dimension', & !> output_type='real32', bounds=(/1/), & !> values_real32=(/fill_value/) ) !> !> @todo Convert given values into selected output_type. !--------------------------------------------------------------------------------------------------! FUNCTION dom_def_dim( file_name, dimension_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) :: file_name !< name of file CHARACTER(LEN=*), INTENT(IN) :: dimension_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 :: d !< loop index INTEGER :: f !< loop index INTEGER :: i !< loop index INTEGER :: j !< loop index INTEGER :: ndims !< number of dimensions in file INTEGER :: return_value !< return value INTEGER, 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 :: dimensions_tmp !< temporary dimension list return_value = 0 CALL internal_message( 'debug', routine_name // & ': define dimension ' // & '(dimension "' // TRIM( dimension_name ) // & '", file "' // TRIM( file_name ) // '")' ) dimension%name = TRIM( dimension_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 IF ( PRESENT( mask ) ) THEN return_value = 1 CALL internal_message( 'error', routine_name // & ': unlimited dimensions cannot be masked ' // & '(dimension "' // TRIM( dimension_name ) // & '", file "' // TRIM( file_name ) // '")!' ) 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(1) 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(1) 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(1) 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(1) 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(1) 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(1) 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(1) ELSE return_value = 2 ENDIF ELSE return_value = 1 CALL internal_message( 'error', routine_name // & ': no values given ' // & '(dimension "' // TRIM( dimension_name ) // & '", file "' // TRIM( file_name ) // '")!' ) ENDIF IF ( return_value == 2 ) THEN return_value = 1 CALL internal_message( 'error', routine_name // & ': number of values and given bounds do not match ' // & '(dimension "' // TRIM( dimension_name ) // & '", file "' // TRIM( file_name ) // '")!' ) ENDIF ! !-- Initialize mask IF ( PRESENT( mask ) .AND. return_value == 0 ) THEN IF ( dimension%length == SIZE( mask ) ) THEN IF ( ALL( mask ) ) THEN CALL internal_message( 'debug', routine_name // & ': mask contains only TRUE values. Ignoring mask ' // & '(dimension "' // TRIM( dimension_name ) // & '", file "' // TRIM( file_name ) // '")!' ) ELSE dimension%is_masked = .TRUE. 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 = dimension%bounds(1), dimension%bounds(2) 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 = dimension%bounds(1), dimension%bounds(2) 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 =dimension%bounds(1), dimension%bounds(2) 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 = dimension%bounds(1), dimension%bounds(2) 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 = dimension%bounds(1), dimension%bounds(2) 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 = dimension%bounds(1), dimension%bounds(2) 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) 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 ENDIF ! if not all mask = true ELSE return_value = 1 CALL internal_message( 'error', routine_name // & ': size of mask and given bounds do not match ' // & '(dimension "' // TRIM( dimension_name ) // & '", file "' // TRIM( file_name ) // '")!' ) 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( dimension_name ) // & '", file "' // TRIM( file_name ) // '")!' ) ENDIF ! !-- Add dimension to database IF ( return_value == 0 ) THEN DO f = 1, nfiles IF ( TRIM( file_name ) == files(f)%name ) THEN IF ( files(f)%is_init ) THEN return_value = 1 CALL internal_message( 'error', routine_name // & ': file already initialized. ' // & 'No further dimension definition allowed ' // & '(dimension "' // TRIM( dimension_name ) // & '", file "' // TRIM( file_name ) // '")!' ) EXIT ELSEIF ( .NOT. ALLOCATED( files(f)%dimensions ) ) THEN ndims = 1 ALLOCATE( files(f)%dimensions(ndims) ) 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 already has a variable of this name defined. ' // & 'Defining a dimension of the same name is not allowed ' // & '(dimension "' // TRIM( dimension_name ) // & '", file "' // TRIM( file_name ) // '")!' ) EXIT ENDIF ENDDO ENDIF IF ( return_value == 0 ) THEN ! !-- Check if dimension already exists in file ndims = SIZE( files(f)%dimensions ) DO d = 1, ndims IF ( files(f)%dimensions(d)%name == dimension%name ) THEN return_value = 1 CALL internal_message( 'error', routine_name // & ': dimension already exists in file ' // & '(dimension "' // TRIM( dimension_name ) // & '", file "' // TRIM( file_name ) // '")!' ) EXIT ENDIF ENDDO ! !-- Extend dimension list IF ( return_value == 0 ) THEN ALLOCATE( dimensions_tmp(ndims) ) dimensions_tmp = files(f)%dimensions DEALLOCATE( files(f)%dimensions ) ndims = ndims + 1 ALLOCATE( files(f)%dimensions(ndims) ) files(f)%dimensions(:ndims-1) = dimensions_tmp DEALLOCATE( dimensions_tmp ) ENDIF ENDIF ENDIF ! !-- Add new dimension to database IF ( return_value == 0 ) files(f)%dimensions(ndims) = dimension EXIT ENDIF ENDDO IF ( f > nfiles ) THEN return_value = 1 CALL internal_message( 'error', routine_name // & ': file not found (dimension "' // TRIM( dimension_name ) // & '", file "' // TRIM( file_name ) // '")!' ) ENDIF ENDIF END FUNCTION dom_def_dim !--------------------------------------------------------------------------------------------------! ! Description: ! ------------ !> Add variable to database. !> If a variable is identical for each MPI rank, the optional argument 'is_global' should be set to !> TRUE. This flags the variable to be a global variable and is later only written once by the !> master output rank. !> Example call: !> dom_def_var( file_name = 'my_output_file_name', & !> variable_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(