Changeset 4147 for palm/trunk/SOURCE/data_output_module.f90
- Timestamp:
- Aug 7, 2019 9:42:31 AM (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/data_output_module.f90
r4141 r4147 25 25 ! ----------------- 26 26 ! $Id$ 27 ! corrected indentation according to coding standard 28 ! 29 ! 4141 2019-08-05 12:24:51Z gronemeier 27 30 ! Initial revision 28 31 ! … … 59 62 !> @todo Convert variable if type of given values do not fit specified type. 60 63 !--------------------------------------------------------------------------------------------------! 61 MODULE data_output_module62 63 USE kinds64 65 USE data_output_netcdf4_module, &66 ONLY: netcdf4_init_dimension, &67 netcdf4_get_error_message, &68 netcdf4_stop_file_header_definition, &69 netcdf4_init_module, &70 netcdf4_init_variable, &71 netcdf4_finalize, &72 netcdf4_open_file, &73 netcdf4_write_attribute, &74 netcdf4_write_variable75 76 USE data_output_binary_module, &77 ONLY: binary_finalize, &78 binary_get_error_message, &79 binary_init_dimension, &80 binary_stop_file_header_definition, &81 binary_init_module, &82 binary_init_variable, &83 binary_open_file, &84 binary_write_attribute, &85 binary_write_variable86 87 IMPLICIT NONE88 89 INTEGER, PARAMETER :: charlen = 100 !< maximum length of character variables90 INTEGER, PARAMETER :: no_id = -1 !< default ID if no ID was assigned91 92 TYPE attribute_type93 CHARACTER(LEN=charlen) :: data_type = '' !< data type94 CHARACTER(LEN=charlen) :: name !< attribute name95 CHARACTER(LEN=charlen) :: value_char !< attribute value if character96 INTEGER(KIND=1) :: value_int8 !< attribute value if 8bit integer97 INTEGER(KIND=2) :: value_int16 !< attribute value if 16bit integer98 INTEGER(KIND=4) :: value_int32 !< attribute value if 32bit integer99 REAL(KIND=4) :: value_real32 !< attribute value if 32bit real100 REAL(KIND=8) :: value_real64 !< attribute value if 64bit real101 END TYPE attribute_type102 103 TYPE variable_type104 CHARACTER(LEN=charlen) :: data_type = '' !< data type105 CHARACTER(LEN=charlen) :: name !< variable name106 INTEGER :: id = no_id !< id within file107 LOGICAL :: is_global = .FALSE. !< true if global variable108 CHARACTER(LEN=charlen), DIMENSION(:), ALLOCATABLE :: dimension_names !< list of dimension names used by variable109 INTEGER, DIMENSION(:), ALLOCATABLE :: dimension_ids !< list of dimension ids used by variable110 TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes111 END TYPE variable_type112 113 TYPE dimension_type114 CHARACTER(LEN=charlen) :: data_type = '' !< data type115 CHARACTER(LEN=charlen) :: name !< dimension name116 INTEGER :: id = no_id !< dimension id within file117 INTEGER :: length !< length of dimension118 INTEGER :: length_mask !< length of masked dimension119 INTEGER :: variable_id = no_id !< associated variable id within file120 LOGICAL :: is_masked = .FALSE. !< true if masked121 INTEGER, DIMENSION(2) :: bounds !< lower and upper bound of dimension122 INTEGER, DIMENSION(:), ALLOCATABLE :: masked_indices !< list of masked indices of dimension123 INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: masked_values_int8 !< masked dimension values if 16bit integer124 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: masked_values_int16 !< masked dimension values if 16bit integer125 INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_int32 !< masked dimension values if 32bit integer126 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: masked_values_intwp !< masked dimension values if working-precision int127 INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: values_int8 !< dimension values if 16bit integer128 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: values_int16 !< dimension values if 16bit integer129 INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: values_int32 !< dimension values if 32bit integer130 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: values_intwp !< dimension values if working-precision integer131 LOGICAL, DIMENSION(:), ALLOCATABLE :: mask !< mask132 REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_real32 !< masked dimension values if 32bit real133 REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: masked_values_real64 !< masked dimension values if 64bit real134 REAL(wp), DIMENSION(:), ALLOCATABLE :: masked_values_realwp !< masked dimension values if working-precision real135 REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: values_real32 !< dimension values if 32bit real136 REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: values_real64 !< dimension values if 64bit real137 REAL(wp), DIMENSION(:), ALLOCATABLE :: values_realwp !< dimension values if working-precision real138 TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes139 END TYPE dimension_type140 141 TYPE file_type142 CHARACTER(LEN=charlen) :: format = '' !< file format143 CHARACTER(LEN=charlen) :: name = '' !< file name144 INTEGER :: id = no_id !< id of file145 LOGICAL :: is_init = .FALSE. !< true if initialized146 TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes147 TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dimensions !< list of dimensions148 TYPE(variable_type), DIMENSION(:), ALLOCATABLE :: variables !< list of variables149 END TYPE file_type150 151 152 CHARACTER(LEN=charlen) :: output_file_suffix = '' !< file suffix added to each file name153 CHARACTER(LEN=800) :: internal_error_message = '' !< string containing the last error message154 CHARACTER(LEN=800) :: temp_string !< dummy string155 156 INTEGER :: debug_output_unit !< Fortran Unit Number of the debug-output file157 INTEGER :: nfiles = 0 !< number of files158 INTEGER :: master_rank = 0 !< master rank for tasks to be executed by single PE only159 INTEGER :: output_group_comm !< MPI communicator addressing all MPI ranks which participate in output160 161 LOGICAL :: print_debug_output = .FALSE. !< if true, debug output is printed162 163 TYPE(file_type), DIMENSION(:), ALLOCATABLE :: files !< file list164 165 SAVE166 167 PRIVATE168 169 !> Initialize the data-output module170 INTERFACE dom_init171 MODULE PROCEDURE dom_init172 END INTERFACE dom_init173 174 !> Add files to database175 INTERFACE dom_def_file176 MODULE PROCEDURE dom_def_file177 END INTERFACE dom_def_file178 179 !> Add dimensions to database180 INTERFACE dom_def_dim181 MODULE PROCEDURE dom_def_dim182 END INTERFACE dom_def_dim183 184 !> Add variables to database185 INTERFACE dom_def_var186 MODULE PROCEDURE dom_def_var187 END INTERFACE dom_def_var188 189 !> Add attributes to database190 INTERFACE dom_def_att191 MODULE PROCEDURE dom_def_att_char192 MODULE PROCEDURE dom_def_att_int8193 MODULE PROCEDURE dom_def_att_int16194 MODULE PROCEDURE dom_def_att_int32195 MODULE PROCEDURE dom_def_att_real32196 MODULE PROCEDURE dom_def_att_real64197 END INTERFACE dom_def_att198 199 !> Prepare for output: evaluate database and create files200 INTERFACE dom_def_end201 MODULE PROCEDURE dom_def_end202 END INTERFACE dom_def_end203 204 !> Write variables to file205 INTERFACE dom_write_var206 MODULE PROCEDURE dom_write_var207 END INTERFACE dom_write_var208 209 !> Last actions required for output befor termination210 INTERFACE dom_finalize_output211 MODULE PROCEDURE dom_finalize_output212 END INTERFACE dom_finalize_output213 214 !> Return error message215 INTERFACE dom_get_error_message216 MODULE PROCEDURE dom_get_error_message217 END INTERFACE dom_get_error_message218 219 !> Write database to debug output220 INTERFACE dom_database_debug_output221 MODULE PROCEDURE dom_database_debug_output222 END INTERFACE dom_database_debug_output223 224 PUBLIC &225 dom_init, &226 dom_def_file, &227 dom_def_dim, &228 dom_def_var, &229 dom_def_att, &230 dom_def_end, &231 dom_write_var, &232 dom_finalize_output, &233 dom_get_error_message, &234 dom_database_debug_output235 236 CONTAINS64 MODULE data_output_module 65 66 USE kinds 67 68 USE data_output_netcdf4_module, & 69 ONLY: netcdf4_init_dimension, & 70 netcdf4_get_error_message, & 71 netcdf4_stop_file_header_definition, & 72 netcdf4_init_module, & 73 netcdf4_init_variable, & 74 netcdf4_finalize, & 75 netcdf4_open_file, & 76 netcdf4_write_attribute, & 77 netcdf4_write_variable 78 79 USE data_output_binary_module, & 80 ONLY: binary_finalize, & 81 binary_get_error_message, & 82 binary_init_dimension, & 83 binary_stop_file_header_definition, & 84 binary_init_module, & 85 binary_init_variable, & 86 binary_open_file, & 87 binary_write_attribute, & 88 binary_write_variable 89 90 IMPLICIT NONE 91 92 INTEGER, PARAMETER :: charlen = 100 !< maximum length of character variables 93 INTEGER, PARAMETER :: no_id = -1 !< default ID if no ID was assigned 94 95 TYPE attribute_type 96 CHARACTER(LEN=charlen) :: data_type = '' !< data type 97 CHARACTER(LEN=charlen) :: name !< attribute name 98 CHARACTER(LEN=charlen) :: value_char !< attribute value if character 99 INTEGER(KIND=1) :: value_int8 !< attribute value if 8bit integer 100 INTEGER(KIND=2) :: value_int16 !< attribute value if 16bit integer 101 INTEGER(KIND=4) :: value_int32 !< attribute value if 32bit integer 102 REAL(KIND=4) :: value_real32 !< attribute value if 32bit real 103 REAL(KIND=8) :: value_real64 !< attribute value if 64bit real 104 END TYPE attribute_type 105 106 TYPE variable_type 107 CHARACTER(LEN=charlen) :: data_type = '' !< data type 108 CHARACTER(LEN=charlen) :: name !< variable name 109 INTEGER :: id = no_id !< id within file 110 LOGICAL :: is_global = .FALSE. !< true if global variable 111 CHARACTER(LEN=charlen), DIMENSION(:), ALLOCATABLE :: dimension_names !< list of dimension names used by variable 112 INTEGER, DIMENSION(:), ALLOCATABLE :: dimension_ids !< list of dimension ids used by variable 113 TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes 114 END TYPE variable_type 115 116 TYPE dimension_type 117 CHARACTER(LEN=charlen) :: data_type = '' !< data type 118 CHARACTER(LEN=charlen) :: name !< dimension name 119 INTEGER :: id = no_id !< dimension id within file 120 INTEGER :: length !< length of dimension 121 INTEGER :: length_mask !< length of masked dimension 122 INTEGER :: variable_id = no_id !< associated variable id within file 123 LOGICAL :: is_masked = .FALSE. !< true if masked 124 INTEGER, DIMENSION(2) :: bounds !< lower and upper bound of dimension 125 INTEGER, DIMENSION(:), ALLOCATABLE :: masked_indices !< list of masked indices of dimension 126 INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: masked_values_int8 !< masked dimension values if 16bit integer 127 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: masked_values_int16 !< masked dimension values if 16bit integer 128 INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_int32 !< masked dimension values if 32bit integer 129 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: masked_values_intwp !< masked dimension values if working-precision int 130 INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE :: values_int8 !< dimension values if 16bit integer 131 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE :: values_int16 !< dimension values if 16bit integer 132 INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE :: values_int32 !< dimension values if 32bit integer 133 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: values_intwp !< dimension values if working-precision integer 134 LOGICAL, DIMENSION(:), ALLOCATABLE :: mask !< mask 135 REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: masked_values_real32 !< masked dimension values if 32bit real 136 REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: masked_values_real64 !< masked dimension values if 64bit real 137 REAL(wp), DIMENSION(:), ALLOCATABLE :: masked_values_realwp !< masked dimension values if working-precision real 138 REAL(KIND=4), DIMENSION(:), ALLOCATABLE :: values_real32 !< dimension values if 32bit real 139 REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: values_real64 !< dimension values if 64bit real 140 REAL(wp), DIMENSION(:), ALLOCATABLE :: values_realwp !< dimension values if working-precision real 141 TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes 142 END TYPE dimension_type 143 144 TYPE file_type 145 CHARACTER(LEN=charlen) :: format = '' !< file format 146 CHARACTER(LEN=charlen) :: name = '' !< file name 147 INTEGER :: id = no_id !< id of file 148 LOGICAL :: is_init = .FALSE. !< true if initialized 149 TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: attributes !< list of attributes 150 TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dimensions !< list of dimensions 151 TYPE(variable_type), DIMENSION(:), ALLOCATABLE :: variables !< list of variables 152 END TYPE file_type 153 154 155 CHARACTER(LEN=charlen) :: output_file_suffix = '' !< file suffix added to each file name 156 CHARACTER(LEN=800) :: internal_error_message = '' !< string containing the last error message 157 CHARACTER(LEN=800) :: temp_string !< dummy string 158 159 INTEGER :: debug_output_unit !< Fortran Unit Number of the debug-output file 160 INTEGER :: nfiles = 0 !< number of files 161 INTEGER :: master_rank = 0 !< master rank for tasks to be executed by single PE only 162 INTEGER :: output_group_comm !< MPI communicator addressing all MPI ranks which participate in output 163 164 LOGICAL :: print_debug_output = .FALSE. !< if true, debug output is printed 165 166 TYPE(file_type), DIMENSION(:), ALLOCATABLE :: files !< file list 167 168 SAVE 169 170 PRIVATE 171 172 !> Initialize the data-output module 173 INTERFACE dom_init 174 MODULE PROCEDURE dom_init 175 END INTERFACE dom_init 176 177 !> Add files to database 178 INTERFACE dom_def_file 179 MODULE PROCEDURE dom_def_file 180 END INTERFACE dom_def_file 181 182 !> Add dimensions to database 183 INTERFACE dom_def_dim 184 MODULE PROCEDURE dom_def_dim 185 END INTERFACE dom_def_dim 186 187 !> Add variables to database 188 INTERFACE dom_def_var 189 MODULE PROCEDURE dom_def_var 190 END INTERFACE dom_def_var 191 192 !> Add attributes to database 193 INTERFACE dom_def_att 194 MODULE PROCEDURE dom_def_att_char 195 MODULE PROCEDURE dom_def_att_int8 196 MODULE PROCEDURE dom_def_att_int16 197 MODULE PROCEDURE dom_def_att_int32 198 MODULE PROCEDURE dom_def_att_real32 199 MODULE PROCEDURE dom_def_att_real64 200 END INTERFACE dom_def_att 201 202 !> Prepare for output: evaluate database and create files 203 INTERFACE dom_def_end 204 MODULE PROCEDURE dom_def_end 205 END INTERFACE dom_def_end 206 207 !> Write variables to file 208 INTERFACE dom_write_var 209 MODULE PROCEDURE dom_write_var 210 END INTERFACE dom_write_var 211 212 !> Last actions required for output befor termination 213 INTERFACE dom_finalize_output 214 MODULE PROCEDURE dom_finalize_output 215 END INTERFACE dom_finalize_output 216 217 !> Return error message 218 INTERFACE dom_get_error_message 219 MODULE PROCEDURE dom_get_error_message 220 END INTERFACE dom_get_error_message 221 222 !> Write database to debug output 223 INTERFACE dom_database_debug_output 224 MODULE PROCEDURE dom_database_debug_output 225 END INTERFACE dom_database_debug_output 226 227 PUBLIC & 228 dom_init, & 229 dom_def_file, & 230 dom_def_dim, & 231 dom_def_var, & 232 dom_def_att, & 233 dom_def_end, & 234 dom_write_var, & 235 dom_finalize_output, & 236 dom_get_error_message, & 237 dom_database_debug_output 238 239 CONTAINS 237 240 238 241 … … 247 250 !> prevents that multiple groups try to open and write to the same output file. 248 251 !--------------------------------------------------------------------------------------------------! 249 SUBROUTINE dom_init( file_suffix_of_output_group, mpi_comm_of_output_group, master_output_rank, &250 program_debug_output_unit, debug_output )251 252 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_suffix_of_output_group !< file-name suffix added to each file;253 !> must be unique for each output group254 255 INTEGER, INTENT(IN), OPTIONAL :: master_output_rank !< MPI rank executing tasks which must256 !> be executed by a single PE only257 INTEGER, INTENT(IN) :: mpi_comm_of_output_group !< MPI communicator specifying the MPI group258 !> which participate in the output259 INTEGER, INTENT(IN) :: program_debug_output_unit !< file unit number for debug output260 261 LOGICAL, INTENT(IN) :: debug_output !< if true, debug output is printed262 263 264 IF ( PRESENT( file_suffix_of_output_group ) ) output_file_suffix = file_suffix_of_output_group265 IF ( PRESENT( master_output_rank ) ) master_rank = master_output_rank266 267 output_group_comm = mpi_comm_of_output_group268 269 debug_output_unit = program_debug_output_unit270 print_debug_output = debug_output271 272 CALL binary_init_module( output_file_suffix, output_group_comm, master_rank, &273 debug_output_unit, debug_output, no_id )274 275 CALL netcdf4_init_module( output_file_suffix, output_group_comm, master_rank, &276 debug_output_unit, debug_output, no_id )277 278 END SUBROUTINE dom_init252 SUBROUTINE dom_init( file_suffix_of_output_group, mpi_comm_of_output_group, master_output_rank, & 253 program_debug_output_unit, debug_output ) 254 255 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_suffix_of_output_group !< file-name suffix added to each file; 256 !> must be unique for each output group 257 258 INTEGER, INTENT(IN), OPTIONAL :: master_output_rank !< MPI rank executing tasks which must 259 !> be executed by a single PE only 260 INTEGER, INTENT(IN) :: mpi_comm_of_output_group !< MPI communicator specifying the MPI group 261 !> which participate in the output 262 INTEGER, INTENT(IN) :: program_debug_output_unit !< file unit number for debug output 263 264 LOGICAL, INTENT(IN) :: debug_output !< if true, debug output is printed 265 266 267 IF ( PRESENT( file_suffix_of_output_group ) ) output_file_suffix = file_suffix_of_output_group 268 IF ( PRESENT( master_output_rank ) ) master_rank = master_output_rank 269 270 output_group_comm = mpi_comm_of_output_group 271 272 debug_output_unit = program_debug_output_unit 273 print_debug_output = debug_output 274 275 CALL binary_init_module( output_file_suffix, output_group_comm, master_rank, & 276 debug_output_unit, debug_output, no_id ) 277 278 CALL netcdf4_init_module( output_file_suffix, output_group_comm, master_rank, & 279 debug_output_unit, debug_output, no_id ) 280 281 END SUBROUTINE dom_init 279 282 280 283 !--------------------------------------------------------------------------------------------------! … … 285 288 !> status = dom_def_file( 'my_output_file_name', 'binary' ) 286 289 !--------------------------------------------------------------------------------------------------! 287 FUNCTION dom_def_file( file_name, file_format ) RESULT( return_value ) 288 289 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file to be created 290 CHARACTER(LEN=*), INTENT(IN) :: file_format !< format of file to be created 291 292 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_file' !< name of this routine 293 294 INTEGER :: f !< loop index 295 INTEGER :: return_value !< return value 296 297 TYPE(file_type), DIMENSION(:), ALLOCATABLE :: files_tmp !< temporary file list 298 299 300 return_value = 0 301 302 CALL internal_message( 'debug', routine_name // ': define file "' // TRIM( file_name ) // '"' ) 303 304 !-- Allocate file list or extend it by 1 305 IF ( .NOT. ALLOCATED( files ) ) THEN 306 307 nfiles = 1 308 ALLOCATE( files(nfiles) ) 309 310 ELSE 311 312 nfiles = SIZE( files ) 313 !-- Check if file already exists 314 DO f = 1, nfiles 315 IF ( files(f)%name == TRIM( file_name ) ) THEN 316 return_value = 1 317 CALL internal_message( 'error', routine_name // & 318 ': file "' // TRIM( file_name ) // '" already exists' ) 319 EXIT 320 ENDIF 321 ENDDO 322 323 !-- Extend file list 324 IF ( return_value == 0 ) THEN 325 ALLOCATE( files_tmp(nfiles) ) 326 files_tmp = files 327 DEALLOCATE( files ) 328 nfiles = nfiles + 1 329 ALLOCATE( files(nfiles) ) 330 files(:nfiles-1) = files_tmp 331 DEALLOCATE( files_tmp ) 332 ENDIF 333 334 ENDIF 335 336 !-- Add new file to database 337 IF ( return_value == 0 ) THEN 338 files(nfiles)%name = TRIM( file_name ) 339 files(nfiles)%format = TRIM( file_format ) 340 ENDIF 341 342 END FUNCTION dom_def_file 290 FUNCTION dom_def_file( file_name, file_format ) RESULT( return_value ) 291 292 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file to be created 293 CHARACTER(LEN=*), INTENT(IN) :: file_format !< format of file to be created 294 295 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_file' !< name of this routine 296 297 INTEGER :: f !< loop index 298 INTEGER :: return_value !< return value 299 300 TYPE(file_type), DIMENSION(:), ALLOCATABLE :: files_tmp !< temporary file list 301 302 303 return_value = 0 304 305 CALL internal_message( 'debug', routine_name // ': define file "' // TRIM( file_name ) // '"' ) 306 ! 307 !-- Allocate file list or extend it by 1 308 IF ( .NOT. ALLOCATED( files ) ) THEN 309 310 nfiles = 1 311 ALLOCATE( files(nfiles) ) 312 313 ELSE 314 315 nfiles = SIZE( files ) 316 ! 317 !-- Check if file already exists 318 DO f = 1, nfiles 319 IF ( files(f)%name == TRIM( file_name ) ) THEN 320 return_value = 1 321 CALL internal_message( 'error', routine_name // & 322 ': file "' // TRIM( file_name ) // '" already exists' ) 323 EXIT 324 ENDIF 325 ENDDO 326 ! 327 !-- Extend file list 328 IF ( return_value == 0 ) THEN 329 ALLOCATE( files_tmp(nfiles) ) 330 files_tmp = files 331 DEALLOCATE( files ) 332 nfiles = nfiles + 1 333 ALLOCATE( files(nfiles) ) 334 files(:nfiles-1) = files_tmp 335 DEALLOCATE( files_tmp ) 336 ENDIF 337 338 ENDIF 339 ! 340 !-- Add new file to database 341 IF ( return_value == 0 ) THEN 342 files(nfiles)%name = TRIM( file_name ) 343 files(nfiles)%format = TRIM( file_format ) 344 ENDIF 345 346 END FUNCTION dom_def_file 343 347 344 348 !--------------------------------------------------------------------------------------------------! … … 370 374 !> @todo Convert given values into selected output_type. 371 375 !--------------------------------------------------------------------------------------------------! 372 FUNCTION dom_def_dim( file_name, dimension_name, output_type, bounds, & 373 values_int8, values_int16, values_int32, values_intwp, & 374 values_real32, values_real64, values_realwp, & 375 mask ) RESULT( return_value ) 376 377 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 378 CHARACTER(LEN=*), INTENT(IN) :: dimension_name !< name of dimension 379 CHARACTER(LEN=*), INTENT(IN) :: output_type !< data type of dimension variable in output file 380 381 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_dim' !< name of this routine 382 383 INTEGER :: d !< loop index 384 INTEGER :: f !< loop index 385 INTEGER :: i !< loop index 386 INTEGER :: j !< loop index 387 INTEGER :: ndims !< number of dimensions in file 388 INTEGER :: return_value !< return value 389 390 INTEGER, DIMENSION(:), INTENT(IN) :: bounds !< lower and upper bound of dimension variable 391 INTEGER(KIND=1), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int8 !< values of dimension 392 INTEGER(KIND=2), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int16 !< values of dimension 393 INTEGER(KIND=4), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int32 !< values of dimension 394 INTEGER(iwp), DIMENSION(:), INTENT(IN), OPTIONAL :: values_intwp !< values of dimension 395 396 LOGICAL, DIMENSION(:), INTENT(IN), OPTIONAL :: mask !< mask of dimesion 397 398 REAL(KIND=4), DIMENSION(:), INTENT(IN), OPTIONAL :: values_real32 !< values of dimension 399 REAL(KIND=8), DIMENSION(:), INTENT(IN), OPTIONAL :: values_real64 !< values of dimension 400 REAL(wp), DIMENSION(:), INTENT(IN), OPTIONAL :: values_realwp !< values of dimension 401 402 TYPE(dimension_type) :: dimension !< new dimension 403 TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dimensions_tmp !< temporary dimension list 404 405 406 return_value = 0 407 408 CALL internal_message( 'debug', routine_name // & 409 ': define dimension ' // & 410 '(dimension "' // TRIM( dimension_name ) // & 411 '", file "' // TRIM( file_name ) // '")' ) 412 413 dimension%name = TRIM( dimension_name ) 414 dimension%data_type = TRIM( output_type ) 415 416 !-- Check dimension bounds and allocate dimension according to bounds 417 IF ( SIZE( bounds ) == 1 ) THEN 418 419 !-- Dimension has only lower bound, which means it changes its size 420 !-- during simulation. 421 !-- Set length to -1 as indicator. 422 dimension%bounds(:) = bounds(1) 423 dimension%length = -1 424 425 IF ( PRESENT( mask ) ) THEN 426 return_value = 1 427 CALL internal_message( 'error', routine_name // & 428 ': unlimited dimensions cannot be masked ' // & 429 '(dimension "' // TRIM( dimension_name ) // & 430 '", file "' // TRIM( file_name ) // '")!' ) 431 ENDIF 432 433 ELSEIF ( SIZE( bounds ) == 2 ) THEN 434 435 dimension%bounds = bounds 436 dimension%length = bounds(2) - bounds(1) + 1 437 438 !-- Save dimension values 439 IF ( PRESENT( values_int8 ) ) THEN 440 ALLOCATE( dimension%values_int8(dimension%bounds(1):dimension%bounds(2)) ) 441 IF ( SIZE( values_int8 ) == dimension%length ) THEN 442 dimension%values_int8 = values_int8 443 ELSEIF ( SIZE( values_int8 ) == 1 ) THEN 444 dimension%values_int8(:) = values_int8(1) 445 ELSE 446 return_value = 2 447 ENDIF 448 ELSEIF( PRESENT( values_int16 ) ) THEN 449 ALLOCATE( dimension%values_int16(dimension%bounds(1):dimension%bounds(2)) ) 450 IF ( SIZE( values_int16 ) == dimension%length ) THEN 451 dimension%values_int16 = values_int16 452 ELSEIF ( SIZE( values_int16 ) == 1 ) THEN 453 dimension%values_int16(:) = values_int16(1) 454 ELSE 455 return_value = 2 456 ENDIF 457 ELSEIF( PRESENT( values_int32 ) ) THEN 458 ALLOCATE( dimension%values_int32(dimension%bounds(1):dimension%bounds(2)) ) 459 IF ( SIZE( values_int32 ) == dimension%length ) THEN 460 dimension%values_int32 = values_int32 461 ELSEIF ( SIZE( values_int32 ) == 1 ) THEN 462 dimension%values_int32(:) = values_int32(1) 463 ELSE 464 return_value = 2 465 ENDIF 466 ELSEIF( PRESENT( values_intwp ) ) THEN 467 ALLOCATE( dimension%values_intwp(dimension%bounds(1):dimension%bounds(2)) ) 468 IF ( SIZE( values_intwp ) == dimension%length ) THEN 469 dimension%values_intwp = values_intwp 470 ELSEIF ( SIZE( values_intwp ) == 1 ) THEN 471 dimension%values_intwp(:) = values_intwp(1) 472 ELSE 473 return_value = 2 474 ENDIF 475 ELSEIF( PRESENT( values_real32 ) ) THEN 476 ALLOCATE( dimension%values_real32(dimension%bounds(1):dimension%bounds(2)) ) 477 IF ( SIZE( values_real32 ) == dimension%length ) THEN 478 dimension%values_real32 = values_real32 479 ELSEIF ( SIZE( values_real32 ) == 1 ) THEN 480 dimension%values_real32(:) = values_real32(1) 481 ELSE 482 return_value = 2 483 ENDIF 484 ELSEIF( PRESENT( values_real64 ) ) THEN 485 ALLOCATE( dimension%values_real64(dimension%bounds(1):dimension%bounds(2)) ) 486 IF ( SIZE( values_real64 ) == dimension%length ) THEN 487 dimension%values_real64 = values_real64 488 ELSEIF ( SIZE( values_real64 ) == 1 ) THEN 489 dimension%values_real64(:) = values_real64(1) 490 ELSE 491 return_value = 2 492 ENDIF 493 ELSEIF( PRESENT( values_realwp ) ) THEN 494 ALLOCATE( dimension%values_realwp(dimension%bounds(1):dimension%bounds(2)) ) 495 IF ( SIZE( values_realwp ) == dimension%length ) THEN 496 dimension%values_realwp = values_realwp 497 ELSEIF ( SIZE( values_realwp ) == 1 ) THEN 498 dimension%values_realwp(:) = values_realwp(1) 499 ELSE 500 return_value = 2 501 ENDIF 502 ELSE 503 return_value = 1 504 CALL internal_message( 'error', routine_name // & 505 ': no values given ' // & 506 '(dimension "' // TRIM( dimension_name ) // & 507 '", file "' // TRIM( file_name ) // '")!' ) 508 ENDIF 509 510 IF ( return_value == 2 ) THEN 511 return_value = 1 512 CALL internal_message( 'error', routine_name // & 513 ': number of values and given bounds do not match ' // & 514 '(dimension "' // TRIM( dimension_name ) // & 515 '", file "' // TRIM( file_name ) // '")!' ) 516 ENDIF 517 518 !-- Initialize mask 519 IF ( PRESENT( mask ) .AND. return_value == 0 ) THEN 520 521 IF ( dimension%length == SIZE( mask ) ) THEN 522 523 IF ( ALL( mask ) ) THEN 524 525 CALL internal_message( 'debug', routine_name // & 526 ': mask contains only TRUE values. Ignoring mask ' // & 527 '(dimension "' // TRIM( dimension_name ) // & 528 '", file "' // TRIM( file_name ) // '")!' ) 529 530 ELSE 531 532 dimension%is_masked = .TRUE. 533 dimension%length_mask = COUNT( mask ) 534 535 ALLOCATE( dimension%mask(dimension%bounds(1):dimension%bounds(2)) ) 536 ALLOCATE( dimension%masked_indices(0:dimension%length_mask-1) ) 537 538 dimension%mask = mask 539 540 !-- Save masked positions and masked values 541 IF ( ALLOCATED( dimension%values_int8 ) ) THEN 542 543 ALLOCATE( dimension%masked_values_int8(0:dimension%length_mask-1) ) 544 j = 0 545 DO i = dimension%bounds(1), dimension%bounds(2) 546 IF ( dimension%mask(i) ) THEN 547 dimension%masked_values_int8(j) = dimension%values_int8(i) 548 dimension%masked_indices(j) = i 549 j = j + 1 550 ENDIF 551 ENDDO 552 553 ELSEIF ( ALLOCATED( dimension%values_int16 ) ) THEN 554 555 ALLOCATE( dimension%masked_values_int16(0:dimension%length_mask-1) ) 556 j = 0 557 DO i = dimension%bounds(1), dimension%bounds(2) 558 IF ( dimension%mask(i) ) THEN 559 dimension%masked_values_int16(j) = dimension%values_int16(i) 560 dimension%masked_indices(j) = i 561 j = j + 1 562 ENDIF 563 ENDDO 564 565 ELSEIF ( ALLOCATED( dimension%values_int32 ) ) THEN 566 567 ALLOCATE( dimension%masked_values_int32(0:dimension%length_mask-1) ) 568 j = 0 569 DO i =dimension%bounds(1), dimension%bounds(2) 570 IF ( dimension%mask(i) ) THEN 571 dimension%masked_values_int32(j) = dimension%values_int32(i) 572 dimension%masked_indices(j) = i 573 j = j + 1 574 ENDIF 575 ENDDO 576 577 ELSEIF ( ALLOCATED( dimension%values_intwp ) ) THEN 578 579 ALLOCATE( dimension%masked_values_intwp(0:dimension%length_mask-1) ) 580 j = 0 581 DO i = dimension%bounds(1), dimension%bounds(2) 582 IF ( dimension%mask(i) ) THEN 583 dimension%masked_values_intwp(j) = dimension%values_intwp(i) 584 dimension%masked_indices(j) = i 585 j = j + 1 586 ENDIF 587 ENDDO 588 589 ELSEIF ( ALLOCATED( dimension%values_real32 ) ) THEN 590 591 ALLOCATE( dimension%masked_values_real32(0:dimension%length_mask-1) ) 592 j = 0 593 DO i = dimension%bounds(1), dimension%bounds(2) 594 IF ( dimension%mask(i) ) THEN 595 dimension%masked_values_real32(j) = dimension%values_real32(i) 596 dimension%masked_indices(j) = i 597 j = j + 1 598 ENDIF 599 ENDDO 600 601 ELSEIF ( ALLOCATED(dimension%values_real64) ) THEN 602 603 ALLOCATE( dimension%masked_values_real64(0:dimension%length_mask-1) ) 604 j = 0 605 DO i = dimension%bounds(1), dimension%bounds(2) 606 IF ( dimension%mask(i) ) THEN 607 dimension%masked_values_real64(j) = dimension%values_real64(i) 608 dimension%masked_indices(j) = i 609 j = j + 1 610 ENDIF 611 ENDDO 612 613 ELSEIF ( ALLOCATED(dimension%values_realwp) ) THEN 614 615 ALLOCATE( dimension%masked_values_realwp(0:dimension%length_mask-1) ) 616 j = 0 617 DO i = dimension%bounds(1), dimension%bounds(2) 618 IF ( dimension%mask(i) ) THEN 619 dimension%masked_values_realwp(j) = dimension%values_realwp(i) 620 dimension%masked_indices(j) = i 621 j = j + 1 622 ENDIF 623 ENDDO 624 625 ENDIF 626 627 ENDIF ! if not all mask = true 628 629 ELSE 630 return_value = 1 631 CALL internal_message( 'error', routine_name // & 632 ': size of mask and given bounds do not match ' // & 633 '(dimension "' // TRIM( dimension_name ) // & 634 '", file "' // TRIM( file_name ) // '")!' ) 635 ENDIF 636 637 ENDIF 638 639 ELSE 640 641 return_value = 1 642 CALL internal_message( 'error', routine_name // & 643 ': at least one but no more than two bounds must be given ' // & 644 '(dimension "' // TRIM( dimension_name ) // & 645 '", file "' // TRIM( file_name ) // '")!' ) 646 647 ENDIF 648 649 !-- Add dimension to database 650 IF ( return_value == 0 ) THEN 651 652 DO f = 1, nfiles 653 654 IF ( TRIM( file_name ) == files(f)%name ) THEN 655 656 IF ( files(f)%is_init ) THEN 657 658 return_value = 1 659 CALL internal_message( 'error', routine_name // & 660 ': file already initialized. ' // & 661 'No further dimension definition allowed ' // & 662 '(dimension "' // TRIM( dimension_name ) // & 663 '", file "' // TRIM( file_name ) // '")!' ) 664 EXIT 665 666 ELSEIF ( .NOT. ALLOCATED( files(f)%dimensions ) ) THEN 667 668 ndims = 1 669 ALLOCATE( files(f)%dimensions(ndims) ) 670 671 ELSE 672 673 !-- Check if any variable of the same name as the new dimension is already defined 674 IF ( ALLOCATED( files(f)%variables ) ) THEN 675 DO i = 1, SIZE( files(f)%variables ) 676 IF ( files(f)%variables(i)%name == dimension%name ) THEN 677 return_value = 1 678 CALL internal_message( 'error', routine_name // & 679 ': file already has a variable of this name defined. ' // & 680 'Defining a dimension of the same name is not allowed ' // & 681 '(dimension "' // TRIM( dimension_name ) // & 682 '", file "' // TRIM( file_name ) // '")!' ) 683 EXIT 684 ENDIF 685 ENDDO 686 ENDIF 687 688 IF ( return_value == 0 ) THEN 689 !-- Check if dimension already exists in file 690 ndims = SIZE( files(f)%dimensions ) 691 692 DO d = 1, ndims 693 IF ( files(f)%dimensions(d)%name == dimension%name ) THEN 694 return_value = 1 695 CALL internal_message( 'error', routine_name // & 696 ': dimension already exists in file ' // & 697 '(dimension "' // TRIM( dimension_name ) // & 698 '", file "' // TRIM( file_name ) // '")!' ) 699 EXIT 700 ENDIF 701 ENDDO 702 703 !-- Extend dimension list 704 IF ( return_value == 0 ) THEN 705 ALLOCATE( dimensions_tmp(ndims) ) 706 dimensions_tmp = files(f)%dimensions 707 DEALLOCATE( files(f)%dimensions ) 708 ndims = ndims + 1 709 ALLOCATE( files(f)%dimensions(ndims) ) 710 files(f)%dimensions(:ndims-1) = dimensions_tmp 711 DEALLOCATE( dimensions_tmp ) 712 ENDIF 713 ENDIF 714 715 ENDIF 716 717 !-- Add new dimension to database 718 IF ( return_value == 0 ) files(f)%dimensions(ndims) = dimension 719 720 EXIT 721 722 ENDIF 723 ENDDO 724 725 IF ( f > nfiles ) THEN 726 return_value = 1 727 CALL internal_message( 'error', routine_name // & 728 ': file not found (dimension "' // TRIM( dimension_name ) // & 729 '", file "' // TRIM( file_name ) // '")!' ) 730 ENDIF 731 732 ENDIF 733 734 END FUNCTION dom_def_dim 376 FUNCTION dom_def_dim( file_name, dimension_name, output_type, bounds, & 377 values_int8, values_int16, values_int32, values_intwp, & 378 values_real32, values_real64, values_realwp, & 379 mask ) RESULT( return_value ) 380 381 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 382 CHARACTER(LEN=*), INTENT(IN) :: dimension_name !< name of dimension 383 CHARACTER(LEN=*), INTENT(IN) :: output_type !< data type of dimension variable in output file 384 385 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_dim' !< name of this routine 386 387 INTEGER :: d !< loop index 388 INTEGER :: f !< loop index 389 INTEGER :: i !< loop index 390 INTEGER :: j !< loop index 391 INTEGER :: ndims !< number of dimensions in file 392 INTEGER :: return_value !< return value 393 394 INTEGER, DIMENSION(:), INTENT(IN) :: bounds !< lower and upper bound of dimension variable 395 INTEGER(KIND=1), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int8 !< values of dimension 396 INTEGER(KIND=2), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int16 !< values of dimension 397 INTEGER(KIND=4), DIMENSION(:), INTENT(IN), OPTIONAL :: values_int32 !< values of dimension 398 INTEGER(iwp), DIMENSION(:), INTENT(IN), OPTIONAL :: values_intwp !< values of dimension 399 400 LOGICAL, DIMENSION(:), INTENT(IN), OPTIONAL :: mask !< mask of dimesion 401 402 REAL(KIND=4), DIMENSION(:), INTENT(IN), OPTIONAL :: values_real32 !< values of dimension 403 REAL(KIND=8), DIMENSION(:), INTENT(IN), OPTIONAL :: values_real64 !< values of dimension 404 REAL(wp), DIMENSION(:), INTENT(IN), OPTIONAL :: values_realwp !< values of dimension 405 406 TYPE(dimension_type) :: dimension !< new dimension 407 TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dimensions_tmp !< temporary dimension list 408 409 410 return_value = 0 411 412 CALL internal_message( 'debug', routine_name // & 413 ': define dimension ' // & 414 '(dimension "' // TRIM( dimension_name ) // & 415 '", file "' // TRIM( file_name ) // '")' ) 416 417 dimension%name = TRIM( dimension_name ) 418 dimension%data_type = TRIM( output_type ) 419 ! 420 !-- Check dimension bounds and allocate dimension according to bounds 421 IF ( SIZE( bounds ) == 1 ) THEN 422 ! 423 !-- Dimension has only lower bound, which means it changes its size 424 !-- during simulation. 425 !-- Set length to -1 as indicator. 426 dimension%bounds(:) = bounds(1) 427 dimension%length = -1 428 429 IF ( PRESENT( mask ) ) THEN 430 return_value = 1 431 CALL internal_message( 'error', routine_name // & 432 ': unlimited dimensions cannot be masked ' // & 433 '(dimension "' // TRIM( dimension_name ) // & 434 '", file "' // TRIM( file_name ) // '")!' ) 435 ENDIF 436 437 ELSEIF ( SIZE( bounds ) == 2 ) THEN 438 439 dimension%bounds = bounds 440 dimension%length = bounds(2) - bounds(1) + 1 441 ! 442 !-- Save dimension values 443 IF ( PRESENT( values_int8 ) ) THEN 444 ALLOCATE( dimension%values_int8(dimension%bounds(1):dimension%bounds(2)) ) 445 IF ( SIZE( values_int8 ) == dimension%length ) THEN 446 dimension%values_int8 = values_int8 447 ELSEIF ( SIZE( values_int8 ) == 1 ) THEN 448 dimension%values_int8(:) = values_int8(1) 449 ELSE 450 return_value = 2 451 ENDIF 452 ELSEIF( PRESENT( values_int16 ) ) THEN 453 ALLOCATE( dimension%values_int16(dimension%bounds(1):dimension%bounds(2)) ) 454 IF ( SIZE( values_int16 ) == dimension%length ) THEN 455 dimension%values_int16 = values_int16 456 ELSEIF ( SIZE( values_int16 ) == 1 ) THEN 457 dimension%values_int16(:) = values_int16(1) 458 ELSE 459 return_value = 2 460 ENDIF 461 ELSEIF( PRESENT( values_int32 ) ) THEN 462 ALLOCATE( dimension%values_int32(dimension%bounds(1):dimension%bounds(2)) ) 463 IF ( SIZE( values_int32 ) == dimension%length ) THEN 464 dimension%values_int32 = values_int32 465 ELSEIF ( SIZE( values_int32 ) == 1 ) THEN 466 dimension%values_int32(:) = values_int32(1) 467 ELSE 468 return_value = 2 469 ENDIF 470 ELSEIF( PRESENT( values_intwp ) ) THEN 471 ALLOCATE( dimension%values_intwp(dimension%bounds(1):dimension%bounds(2)) ) 472 IF ( SIZE( values_intwp ) == dimension%length ) THEN 473 dimension%values_intwp = values_intwp 474 ELSEIF ( SIZE( values_intwp ) == 1 ) THEN 475 dimension%values_intwp(:) = values_intwp(1) 476 ELSE 477 return_value = 2 478 ENDIF 479 ELSEIF( PRESENT( values_real32 ) ) THEN 480 ALLOCATE( dimension%values_real32(dimension%bounds(1):dimension%bounds(2)) ) 481 IF ( SIZE( values_real32 ) == dimension%length ) THEN 482 dimension%values_real32 = values_real32 483 ELSEIF ( SIZE( values_real32 ) == 1 ) THEN 484 dimension%values_real32(:) = values_real32(1) 485 ELSE 486 return_value = 2 487 ENDIF 488 ELSEIF( PRESENT( values_real64 ) ) THEN 489 ALLOCATE( dimension%values_real64(dimension%bounds(1):dimension%bounds(2)) ) 490 IF ( SIZE( values_real64 ) == dimension%length ) THEN 491 dimension%values_real64 = values_real64 492 ELSEIF ( SIZE( values_real64 ) == 1 ) THEN 493 dimension%values_real64(:) = values_real64(1) 494 ELSE 495 return_value = 2 496 ENDIF 497 ELSEIF( PRESENT( values_realwp ) ) THEN 498 ALLOCATE( dimension%values_realwp(dimension%bounds(1):dimension%bounds(2)) ) 499 IF ( SIZE( values_realwp ) == dimension%length ) THEN 500 dimension%values_realwp = values_realwp 501 ELSEIF ( SIZE( values_realwp ) == 1 ) THEN 502 dimension%values_realwp(:) = values_realwp(1) 503 ELSE 504 return_value = 2 505 ENDIF 506 ELSE 507 return_value = 1 508 CALL internal_message( 'error', routine_name // & 509 ': no values given ' // & 510 '(dimension "' // TRIM( dimension_name ) // & 511 '", file "' // TRIM( file_name ) // '")!' ) 512 ENDIF 513 514 IF ( return_value == 2 ) THEN 515 return_value = 1 516 CALL internal_message( 'error', routine_name // & 517 ': number of values and given bounds do not match ' // & 518 '(dimension "' // TRIM( dimension_name ) // & 519 '", file "' // TRIM( file_name ) // '")!' ) 520 ENDIF 521 ! 522 !-- Initialize mask 523 IF ( PRESENT( mask ) .AND. return_value == 0 ) THEN 524 525 IF ( dimension%length == SIZE( mask ) ) THEN 526 527 IF ( ALL( mask ) ) THEN 528 529 CALL internal_message( 'debug', routine_name // & 530 ': mask contains only TRUE values. Ignoring mask ' // & 531 '(dimension "' // TRIM( dimension_name ) // & 532 '", file "' // TRIM( file_name ) // '")!' ) 533 534 ELSE 535 536 dimension%is_masked = .TRUE. 537 dimension%length_mask = COUNT( mask ) 538 539 ALLOCATE( dimension%mask(dimension%bounds(1):dimension%bounds(2)) ) 540 ALLOCATE( dimension%masked_indices(0:dimension%length_mask-1) ) 541 542 dimension%mask = mask 543 ! 544 !-- Save masked positions and masked values 545 IF ( ALLOCATED( dimension%values_int8 ) ) THEN 546 547 ALLOCATE( dimension%masked_values_int8(0:dimension%length_mask-1) ) 548 j = 0 549 DO i = dimension%bounds(1), dimension%bounds(2) 550 IF ( dimension%mask(i) ) THEN 551 dimension%masked_values_int8(j) = dimension%values_int8(i) 552 dimension%masked_indices(j) = i 553 j = j + 1 554 ENDIF 555 ENDDO 556 557 ELSEIF ( ALLOCATED( dimension%values_int16 ) ) THEN 558 559 ALLOCATE( dimension%masked_values_int16(0:dimension%length_mask-1) ) 560 j = 0 561 DO i = dimension%bounds(1), dimension%bounds(2) 562 IF ( dimension%mask(i) ) THEN 563 dimension%masked_values_int16(j) = dimension%values_int16(i) 564 dimension%masked_indices(j) = i 565 j = j + 1 566 ENDIF 567 ENDDO 568 569 ELSEIF ( ALLOCATED( dimension%values_int32 ) ) THEN 570 571 ALLOCATE( dimension%masked_values_int32(0:dimension%length_mask-1) ) 572 j = 0 573 DO i =dimension%bounds(1), dimension%bounds(2) 574 IF ( dimension%mask(i) ) THEN 575 dimension%masked_values_int32(j) = dimension%values_int32(i) 576 dimension%masked_indices(j) = i 577 j = j + 1 578 ENDIF 579 ENDDO 580 581 ELSEIF ( ALLOCATED( dimension%values_intwp ) ) THEN 582 583 ALLOCATE( dimension%masked_values_intwp(0:dimension%length_mask-1) ) 584 j = 0 585 DO i = dimension%bounds(1), dimension%bounds(2) 586 IF ( dimension%mask(i) ) THEN 587 dimension%masked_values_intwp(j) = dimension%values_intwp(i) 588 dimension%masked_indices(j) = i 589 j = j + 1 590 ENDIF 591 ENDDO 592 593 ELSEIF ( ALLOCATED( dimension%values_real32 ) ) THEN 594 595 ALLOCATE( dimension%masked_values_real32(0:dimension%length_mask-1) ) 596 j = 0 597 DO i = dimension%bounds(1), dimension%bounds(2) 598 IF ( dimension%mask(i) ) THEN 599 dimension%masked_values_real32(j) = dimension%values_real32(i) 600 dimension%masked_indices(j) = i 601 j = j + 1 602 ENDIF 603 ENDDO 604 605 ELSEIF ( ALLOCATED(dimension%values_real64) ) THEN 606 607 ALLOCATE( dimension%masked_values_real64(0:dimension%length_mask-1) ) 608 j = 0 609 DO i = dimension%bounds(1), dimension%bounds(2) 610 IF ( dimension%mask(i) ) THEN 611 dimension%masked_values_real64(j) = dimension%values_real64(i) 612 dimension%masked_indices(j) = i 613 j = j + 1 614 ENDIF 615 ENDDO 616 617 ELSEIF ( ALLOCATED(dimension%values_realwp) ) THEN 618 619 ALLOCATE( dimension%masked_values_realwp(0:dimension%length_mask-1) ) 620 j = 0 621 DO i = dimension%bounds(1), dimension%bounds(2) 622 IF ( dimension%mask(i) ) THEN 623 dimension%masked_values_realwp(j) = dimension%values_realwp(i) 624 dimension%masked_indices(j) = i 625 j = j + 1 626 ENDIF 627 ENDDO 628 629 ENDIF 630 631 ENDIF ! if not all mask = true 632 633 ELSE 634 return_value = 1 635 CALL internal_message( 'error', routine_name // & 636 ': size of mask and given bounds do not match ' // & 637 '(dimension "' // TRIM( dimension_name ) // & 638 '", file "' // TRIM( file_name ) // '")!' ) 639 ENDIF 640 641 ENDIF 642 643 ELSE 644 645 return_value = 1 646 CALL internal_message( 'error', routine_name // & 647 ': at least one but no more than two bounds must be given ' // & 648 '(dimension "' // TRIM( dimension_name ) // & 649 '", file "' // TRIM( file_name ) // '")!' ) 650 651 ENDIF 652 ! 653 !-- Add dimension to database 654 IF ( return_value == 0 ) THEN 655 656 DO f = 1, nfiles 657 658 IF ( TRIM( file_name ) == files(f)%name ) THEN 659 660 IF ( files(f)%is_init ) THEN 661 662 return_value = 1 663 CALL internal_message( 'error', routine_name // & 664 ': file already initialized. ' // & 665 'No further dimension definition allowed ' // & 666 '(dimension "' // TRIM( dimension_name ) // & 667 '", file "' // TRIM( file_name ) // '")!' ) 668 EXIT 669 670 ELSEIF ( .NOT. ALLOCATED( files(f)%dimensions ) ) THEN 671 672 ndims = 1 673 ALLOCATE( files(f)%dimensions(ndims) ) 674 675 ELSE 676 ! 677 !-- Check if any variable of the same name as the new dimension is already defined 678 IF ( ALLOCATED( files(f)%variables ) ) THEN 679 DO i = 1, SIZE( files(f)%variables ) 680 IF ( files(f)%variables(i)%name == dimension%name ) THEN 681 return_value = 1 682 CALL internal_message( 'error', routine_name // & 683 ': file already has a variable of this name defined. ' // & 684 'Defining a dimension of the same name is not allowed ' // & 685 '(dimension "' // TRIM( dimension_name ) // & 686 '", file "' // TRIM( file_name ) // '")!' ) 687 EXIT 688 ENDIF 689 ENDDO 690 ENDIF 691 692 IF ( return_value == 0 ) THEN 693 ! 694 !-- Check if dimension already exists in file 695 ndims = SIZE( files(f)%dimensions ) 696 697 DO d = 1, ndims 698 IF ( files(f)%dimensions(d)%name == dimension%name ) THEN 699 return_value = 1 700 CALL internal_message( 'error', routine_name // & 701 ': dimension already exists in file ' // & 702 '(dimension "' // TRIM( dimension_name ) // & 703 '", file "' // TRIM( file_name ) // '")!' ) 704 EXIT 705 ENDIF 706 ENDDO 707 ! 708 !-- Extend dimension list 709 IF ( return_value == 0 ) THEN 710 ALLOCATE( dimensions_tmp(ndims) ) 711 dimensions_tmp = files(f)%dimensions 712 DEALLOCATE( files(f)%dimensions ) 713 ndims = ndims + 1 714 ALLOCATE( files(f)%dimensions(ndims) ) 715 files(f)%dimensions(:ndims-1) = dimensions_tmp 716 DEALLOCATE( dimensions_tmp ) 717 ENDIF 718 ENDIF 719 720 ENDIF 721 ! 722 !-- Add new dimension to database 723 IF ( return_value == 0 ) files(f)%dimensions(ndims) = dimension 724 725 EXIT 726 727 ENDIF 728 ENDDO 729 730 IF ( f > nfiles ) THEN 731 return_value = 1 732 CALL internal_message( 'error', routine_name // & 733 ': file not found (dimension "' // TRIM( dimension_name ) // & 734 '", file "' // TRIM( file_name ) // '")!' ) 735 ENDIF 736 737 ENDIF 738 739 END FUNCTION dom_def_dim 735 740 736 741 !--------------------------------------------------------------------------------------------------! … … 759 764 !> ALLOCATE( u(<z>,<y>,<x>) ) 760 765 !--------------------------------------------------------------------------------------------------! 761 FUNCTION dom_def_var( file_name, variable_name, dimension_names, output_type, is_global ) & 762 RESULT( return_value ) 763 764 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 765 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 766 CHARACTER(LEN=*), INTENT(IN) :: output_type !< data type of variable 767 768 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_var' !< name of this routine 769 770 CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: dimension_names !< list of dimension names 771 772 INTEGER :: d !< loop index 773 INTEGER :: f !< loop index 774 INTEGER :: i !< loop index 775 INTEGER :: nvars !< number of variables in file 776 INTEGER :: return_value !< return value 777 778 LOGICAL :: found !< true if requested dimension is defined in file 779 LOGICAL, INTENT(IN), OPTIONAL :: is_global !< true if variable is global (same on all PE) 780 781 TYPE(variable_type) :: variable !< new variable 782 TYPE(variable_type), DIMENSION(:), ALLOCATABLE :: variables_tmp !< temporary variable list 783 784 785 return_value = 0 786 found = .FALSE. 787 788 CALL internal_message( 'debug', routine_name // & 789 ': define variable (variable "' // TRIM( variable_name ) // & 790 '", file "' // TRIM( file_name ) // '")' ) 791 792 variable%name = TRIM( variable_name ) 793 794 ALLOCATE( variable%dimension_names(SIZE( dimension_names )) ) 795 ALLOCATE( variable%dimension_ids(SIZE( dimension_names )) ) 796 797 variable%dimension_names = dimension_names 798 variable%dimension_ids = -1 799 variable%data_type = TRIM( output_type ) 800 801 IF ( PRESENT( is_global ) ) THEN 802 variable%is_global = is_global 803 ELSE 804 variable%is_global = .FALSE. 805 ENDIF 806 807 !-- Add variable to database 808 DO f = 1, nfiles 809 810 IF ( TRIM( file_name ) == files(f)%name ) THEN 811 812 IF ( files(f)%is_init ) THEN 813 814 return_value = 1 815 CALL internal_message( 'error', routine_name // & 816 ': file already initialized. No further variable definition allowed ' // & 817 '(variable "' // TRIM( variable_name ) // & 818 '", file "' // TRIM( file_name ) // '")!' ) 819 EXIT 820 821 ELSEIF ( ALLOCATED( files(f)%dimensions ) ) THEN 822 823 !-- Check if any dimension of the same name as the new variable is already defined 824 DO d = 1, SIZE( files(f)%dimensions ) 825 IF ( files(f)%dimensions(d)%name == variable%name ) THEN 826 return_value = 1 827 CALL internal_message( 'error', routine_name // & 828 ': file already has a dimension of this name defined. ' // & 829 'Defining a variable of the same name is not allowed ' // & 830 '(variable "' // TRIM( variable_name ) // & 831 '", file "' // TRIM( file_name ) // '")!' ) 832 EXIT 833 ENDIF 834 ENDDO 835 836 !-- Check if dimensions assigned to variable are defined within file 837 IF ( return_value == 0 ) THEN 838 DO i = 1, SIZE( variable%dimension_names ) 839 found = .FALSE. 840 DO d = 1, SIZE( files(f)%dimensions ) 841 IF ( files(f)%dimensions(d)%name == variable%dimension_names(i) ) THEN 842 found = .TRUE. 843 EXIT 844 ENDIF 845 ENDDO 846 IF ( .NOT. found ) THEN 847 return_value = 1 848 CALL internal_message( 'error', routine_name // & 849 ': required dimension "'// TRIM( variable%dimension_names(i) ) // & 850 '" for variable is not defined ' // & 851 '(variable "' // TRIM( variable_name ) // & 852 '", file "' // TRIM( file_name ) // '")!' ) 853 EXIT 854 ENDIF 855 ENDDO 856 ENDIF 857 858 ELSE 859 860 return_value = 1 861 CALL internal_message( 'error', routine_name // & 862 ': no dimensions defined in file. Cannot define variable '// & 863 '(variable "' // TRIM( variable_name ) // & 864 '", file "' // TRIM( file_name ) // '")!' ) 865 866 ENDIF 867 868 IF ( return_value == 0 ) THEN 869 870 !-- Check if variable already exists 871 IF ( .NOT. ALLOCATED( files(f)%variables ) ) THEN 872 873 nvars = 1 874 ALLOCATE( files(f)%variables(nvars) ) 875 876 ELSE 877 878 nvars = SIZE( files(f)%variables ) 879 DO i = 1, nvars 880 IF ( files(f)%variables(i)%name == variable%name ) THEN 881 return_value = 1 882 CALL internal_message( 'error', routine_name // & 883 ': variable already exists '// & 884 '(variable "' // TRIM( variable_name ) // & 885 '", file "' // TRIM( file_name ) // '")!' ) 886 EXIT 887 ENDIF 888 ENDDO 889 890 IF ( return_value == 0 ) THEN 891 !-- Extend variable list 892 ALLOCATE( variables_tmp(nvars) ) 893 variables_tmp = files(f)%variables 894 DEALLOCATE( files(f)%variables ) 895 nvars = nvars + 1 896 ALLOCATE( files(f)%variables(nvars) ) 897 files(f)%variables(:nvars-1) = variables_tmp 898 DEALLOCATE( variables_tmp ) 899 ENDIF 900 901 ENDIF 902 903 !-- Add new variable to database 904 IF ( return_value == 0 ) files(f)%variables(nvars) = variable 905 906 ENDIF 907 908 EXIT 909 910 ENDIF 911 912 ENDDO 913 914 IF ( f > nfiles ) THEN 915 return_value = 1 916 CALL internal_message( 'error', routine_name // & 917 ': file not found (variable "' // TRIM( variable_name ) // & 918 '", file "' // TRIM( file_name ) // '")!' ) 919 ENDIF 920 921 END FUNCTION dom_def_var 766 FUNCTION dom_def_var( file_name, variable_name, dimension_names, output_type, is_global ) & 767 RESULT( return_value ) 768 769 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 770 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 771 CHARACTER(LEN=*), INTENT(IN) :: output_type !< data type of variable 772 773 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_var' !< name of this routine 774 775 CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: dimension_names !< list of dimension names 776 777 INTEGER :: d !< loop index 778 INTEGER :: f !< loop index 779 INTEGER :: i !< loop index 780 INTEGER :: nvars !< number of variables in file 781 INTEGER :: return_value !< return value 782 783 LOGICAL :: found !< true if requested dimension is defined in file 784 LOGICAL, INTENT(IN), OPTIONAL :: is_global !< true if variable is global (same on all PE) 785 786 TYPE(variable_type) :: variable !< new variable 787 TYPE(variable_type), DIMENSION(:), ALLOCATABLE :: variables_tmp !< temporary variable list 788 789 790 return_value = 0 791 found = .FALSE. 792 793 CALL internal_message( 'debug', routine_name // & 794 ': define variable (variable "' // TRIM( variable_name ) // & 795 '", file "' // TRIM( file_name ) // '")' ) 796 797 variable%name = TRIM( variable_name ) 798 799 ALLOCATE( variable%dimension_names(SIZE( dimension_names )) ) 800 ALLOCATE( variable%dimension_ids(SIZE( dimension_names )) ) 801 802 variable%dimension_names = dimension_names 803 variable%dimension_ids = -1 804 variable%data_type = TRIM( output_type ) 805 806 IF ( PRESENT( is_global ) ) THEN 807 variable%is_global = is_global 808 ELSE 809 variable%is_global = .FALSE. 810 ENDIF 811 ! 812 !-- Add variable to database 813 DO f = 1, nfiles 814 815 IF ( TRIM( file_name ) == files(f)%name ) THEN 816 817 IF ( files(f)%is_init ) THEN 818 819 return_value = 1 820 CALL internal_message( 'error', routine_name // & 821 ': file already initialized. No further variable definition allowed ' // & 822 '(variable "' // TRIM( variable_name ) // & 823 '", file "' // TRIM( file_name ) // '")!' ) 824 EXIT 825 826 ELSEIF ( ALLOCATED( files(f)%dimensions ) ) THEN 827 ! 828 !-- Check if any dimension of the same name as the new variable is already defined 829 DO d = 1, SIZE( files(f)%dimensions ) 830 IF ( files(f)%dimensions(d)%name == variable%name ) THEN 831 return_value = 1 832 CALL internal_message( 'error', routine_name // & 833 ': file already has a dimension of this name defined. ' // & 834 'Defining a variable of the same name is not allowed ' // & 835 '(variable "' // TRIM( variable_name ) // & 836 '", file "' // TRIM( file_name ) // '")!' ) 837 EXIT 838 ENDIF 839 ENDDO 840 ! 841 !-- Check if dimensions assigned to variable are defined within file 842 IF ( return_value == 0 ) THEN 843 DO i = 1, SIZE( variable%dimension_names ) 844 found = .FALSE. 845 DO d = 1, SIZE( files(f)%dimensions ) 846 IF ( files(f)%dimensions(d)%name == variable%dimension_names(i) ) THEN 847 found = .TRUE. 848 EXIT 849 ENDIF 850 ENDDO 851 IF ( .NOT. found ) THEN 852 return_value = 1 853 CALL internal_message( 'error', routine_name // & 854 ': required dimension "'// TRIM( variable%dimension_names(i) ) // & 855 '" for variable is not defined ' // & 856 '(variable "' // TRIM( variable_name ) // & 857 '", file "' // TRIM( file_name ) // '")!' ) 858 EXIT 859 ENDIF 860 ENDDO 861 ENDIF 862 863 ELSE 864 865 return_value = 1 866 CALL internal_message( 'error', routine_name // & 867 ': no dimensions defined in file. Cannot define variable '// & 868 '(variable "' // TRIM( variable_name ) // & 869 '", file "' // TRIM( file_name ) // '")!' ) 870 871 ENDIF 872 873 IF ( return_value == 0 ) THEN 874 ! 875 !-- Check if variable already exists 876 IF ( .NOT. ALLOCATED( files(f)%variables ) ) THEN 877 878 nvars = 1 879 ALLOCATE( files(f)%variables(nvars) ) 880 881 ELSE 882 883 nvars = SIZE( files(f)%variables ) 884 DO i = 1, nvars 885 IF ( files(f)%variables(i)%name == variable%name ) THEN 886 return_value = 1 887 CALL internal_message( 'error', routine_name // & 888 ': variable already exists '// & 889 '(variable "' // TRIM( variable_name ) // & 890 '", file "' // TRIM( file_name ) // '")!' ) 891 EXIT 892 ENDIF 893 ENDDO 894 895 IF ( return_value == 0 ) THEN 896 ! 897 !-- Extend variable list 898 ALLOCATE( variables_tmp(nvars) ) 899 variables_tmp = files(f)%variables 900 DEALLOCATE( files(f)%variables ) 901 nvars = nvars + 1 902 ALLOCATE( files(f)%variables(nvars) ) 903 files(f)%variables(:nvars-1) = variables_tmp 904 DEALLOCATE( variables_tmp ) 905 ENDIF 906 907 ENDIF 908 ! 909 !-- Add new variable to database 910 IF ( return_value == 0 ) files(f)%variables(nvars) = variable 911 912 ENDIF 913 914 EXIT 915 916 ENDIF 917 918 ENDDO 919 920 IF ( f > nfiles ) THEN 921 return_value = 1 922 CALL internal_message( 'error', routine_name // & 923 ': file not found (variable "' // TRIM( variable_name ) // & 924 '", file "' // TRIM( file_name ) // '")!' ) 925 ENDIF 926 927 END FUNCTION dom_def_var 922 928 923 929 !--------------------------------------------------------------------------------------------------! … … 946 952 !> value=' and this part was appended', append=.TRUE. ) 947 953 !--------------------------------------------------------------------------------------------------! 948 FUNCTION dom_def_att_char( file_name, variable_name, attribute_name, value, append ) &949 RESULT( return_value )950 951 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file952 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute953 CHARACTER(LEN=*), INTENT(IN) :: value !< attribute value954 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable955 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name956 957 ! CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_char' !< name of routine958 959 INTEGER :: return_value !< return value960 961 LOGICAL :: append_internal !< same as 'append'962 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value963 964 TYPE(attribute_type) :: attribute !< new attribute965 966 967 return_value = 0968 969 IF ( PRESENT( append ) ) THEN970 append_internal = append971 ELSE972 append_internal = .FALSE.973 ENDIF974 975 attribute%name = TRIM( attribute_name )976 attribute%data_type = 'char'977 attribute%value_char = TRIM( value )978 979 IF ( PRESENT( variable_name ) ) THEN980 variable_name_internal = TRIM( variable_name )981 ELSE982 variable_name_internal = ''983 ENDIF984 985 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &986 variable_name=TRIM( variable_name_internal ), &987 attribute=attribute, append=append_internal )988 989 END FUNCTION dom_def_att_char954 FUNCTION dom_def_att_char( file_name, variable_name, attribute_name, value, append ) & 955 RESULT( return_value ) 956 957 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 958 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 959 CHARACTER(LEN=*), INTENT(IN) :: value !< attribute value 960 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable 961 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name 962 963 ! CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_char' !< name of routine 964 965 INTEGER :: return_value !< return value 966 967 LOGICAL :: append_internal !< same as 'append' 968 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value 969 970 TYPE(attribute_type) :: attribute !< new attribute 971 972 973 return_value = 0 974 975 IF ( PRESENT( append ) ) THEN 976 append_internal = append 977 ELSE 978 append_internal = .FALSE. 979 ENDIF 980 981 attribute%name = TRIM( attribute_name ) 982 attribute%data_type = 'char' 983 attribute%value_char = TRIM( value ) 984 985 IF ( PRESENT( variable_name ) ) THEN 986 variable_name_internal = TRIM( variable_name ) 987 ELSE 988 variable_name_internal = '' 989 ENDIF 990 991 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 992 variable_name=TRIM( variable_name_internal ), & 993 attribute=attribute, append=append_internal ) 994 995 END FUNCTION dom_def_att_char 990 996 991 997 !--------------------------------------------------------------------------------------------------! … … 1008 1014 !> value=1_1 ) 1009 1015 !--------------------------------------------------------------------------------------------------! 1010 FUNCTION dom_def_att_int8( file_name, variable_name, attribute_name, value, append ) &1011 RESULT( return_value )1012 1013 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file1014 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute1015 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable1016 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name1017 1018 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int8' !< name of routine1019 1020 INTEGER(KIND=1), INTENT(IN) :: value !< attribute value1021 1022 INTEGER :: return_value !< return value1023 1024 LOGICAL :: append_internal !< same as 'append'1025 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value1026 1027 TYPE(attribute_type) :: attribute !< new attribute1028 1029 1030 return_value = 01031 1032 IF ( PRESENT( variable_name ) ) THEN1033 variable_name_internal = TRIM( variable_name )1034 ELSE1035 variable_name_internal = ''1036 ENDIF1037 1038 IF ( PRESENT( append ) ) THEN1039 IF ( append ) THEN1040 return_value = 11041 CALL internal_message( 'error', routine_name // &1042 ': numeric attribute cannot be appended ' // &1043 '(attribute "' // TRIM( attribute_name ) // &1044 '", variable "' // TRIM( variable_name_internal ) // &1045 '", file "' // TRIM( file_name ) // '")!' )1046 ENDIF1047 ENDIF1048 1049 IF ( return_value == 0 ) THEN1050 append_internal = .FALSE.1051 1052 attribute%name = TRIM( attribute_name )1053 attribute%data_type = 'int8'1054 attribute%value_int8 = value1055 1056 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &1057 variable_name=TRIM( variable_name_internal ), &1058 attribute=attribute, append=append_internal )1059 ENDIF1060 1061 END FUNCTION dom_def_att_int81016 FUNCTION dom_def_att_int8( file_name, variable_name, attribute_name, value, append ) & 1017 RESULT( return_value ) 1018 1019 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1020 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 1021 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable 1022 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name 1023 1024 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int8' !< name of routine 1025 1026 INTEGER(KIND=1), INTENT(IN) :: value !< attribute value 1027 1028 INTEGER :: return_value !< return value 1029 1030 LOGICAL :: append_internal !< same as 'append' 1031 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value 1032 1033 TYPE(attribute_type) :: attribute !< new attribute 1034 1035 1036 return_value = 0 1037 1038 IF ( PRESENT( variable_name ) ) THEN 1039 variable_name_internal = TRIM( variable_name ) 1040 ELSE 1041 variable_name_internal = '' 1042 ENDIF 1043 1044 IF ( PRESENT( append ) ) THEN 1045 IF ( append ) THEN 1046 return_value = 1 1047 CALL internal_message( 'error', routine_name // & 1048 ': numeric attribute cannot be appended ' // & 1049 '(attribute "' // TRIM( attribute_name ) // & 1050 '", variable "' // TRIM( variable_name_internal ) // & 1051 '", file "' // TRIM( file_name ) // '")!' ) 1052 ENDIF 1053 ENDIF 1054 1055 IF ( return_value == 0 ) THEN 1056 append_internal = .FALSE. 1057 1058 attribute%name = TRIM( attribute_name ) 1059 attribute%data_type = 'int8' 1060 attribute%value_int8 = value 1061 1062 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 1063 variable_name=TRIM( variable_name_internal ), & 1064 attribute=attribute, append=append_internal ) 1065 ENDIF 1066 1067 END FUNCTION dom_def_att_int8 1062 1068 1063 1069 !--------------------------------------------------------------------------------------------------! … … 1080 1086 !> value=1_2 ) 1081 1087 !--------------------------------------------------------------------------------------------------! 1082 FUNCTION dom_def_att_int16( file_name, variable_name, attribute_name, value, append ) &1083 RESULT( return_value )1084 1085 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file1086 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute1087 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable1088 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name1089 1090 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int16' !< name of routine1091 1092 INTEGER(KIND=2), INTENT(IN) :: value !< attribute value1093 1094 INTEGER :: return_value !< return value1095 1096 LOGICAL :: append_internal !< same as 'append'1097 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value1098 1099 TYPE(attribute_type) :: attribute !< new attribute1100 1101 1102 return_value = 01103 1104 IF ( PRESENT( variable_name ) ) THEN1105 variable_name_internal = TRIM( variable_name )1106 ELSE1107 variable_name_internal = ''1108 ENDIF1109 1110 IF ( PRESENT( append ) ) THEN1111 IF ( append ) THEN1112 return_value = 11113 CALL internal_message( 'error', routine_name // &1114 ': numeric attribute cannot be appended ' // &1115 '(attribute "' // TRIM( attribute_name ) // &1116 '", variable "' // TRIM( variable_name_internal ) // &1117 '", file "' // TRIM( file_name ) // '")!' )1118 ENDIF1119 ENDIF1120 1121 IF ( return_value == 0 ) THEN1122 append_internal = .FALSE.1123 1124 attribute%name = TRIM( attribute_name )1125 attribute%data_type = 'int16'1126 attribute%value_int16 = value1127 1128 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &1129 variable_name=TRIM( variable_name_internal ), &1130 attribute=attribute, append=append_internal )1131 ENDIF1132 1133 END FUNCTION dom_def_att_int161088 FUNCTION dom_def_att_int16( file_name, variable_name, attribute_name, value, append ) & 1089 RESULT( return_value ) 1090 1091 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1092 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 1093 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable 1094 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name 1095 1096 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int16' !< name of routine 1097 1098 INTEGER(KIND=2), INTENT(IN) :: value !< attribute value 1099 1100 INTEGER :: return_value !< return value 1101 1102 LOGICAL :: append_internal !< same as 'append' 1103 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value 1104 1105 TYPE(attribute_type) :: attribute !< new attribute 1106 1107 1108 return_value = 0 1109 1110 IF ( PRESENT( variable_name ) ) THEN 1111 variable_name_internal = TRIM( variable_name ) 1112 ELSE 1113 variable_name_internal = '' 1114 ENDIF 1115 1116 IF ( PRESENT( append ) ) THEN 1117 IF ( append ) THEN 1118 return_value = 1 1119 CALL internal_message( 'error', routine_name // & 1120 ': numeric attribute cannot be appended ' // & 1121 '(attribute "' // TRIM( attribute_name ) // & 1122 '", variable "' // TRIM( variable_name_internal ) // & 1123 '", file "' // TRIM( file_name ) // '")!' ) 1124 ENDIF 1125 ENDIF 1126 1127 IF ( return_value == 0 ) THEN 1128 append_internal = .FALSE. 1129 1130 attribute%name = TRIM( attribute_name ) 1131 attribute%data_type = 'int16' 1132 attribute%value_int16 = value 1133 1134 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 1135 variable_name=TRIM( variable_name_internal ), & 1136 attribute=attribute, append=append_internal ) 1137 ENDIF 1138 1139 END FUNCTION dom_def_att_int16 1134 1140 1135 1141 !--------------------------------------------------------------------------------------------------! … … 1152 1158 !> value=1_4 ) 1153 1159 !--------------------------------------------------------------------------------------------------! 1154 FUNCTION dom_def_att_int32( file_name, variable_name, attribute_name, value, append ) &1155 RESULT( return_value )1156 1157 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file1158 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute1159 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable1160 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name1161 1162 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int32' !< name of routine1163 1164 INTEGER(KIND=4), INTENT(IN) :: value !< attribute value1165 1166 INTEGER :: return_value !< return value1167 1168 LOGICAL :: append_internal !< same as 'append'1169 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value1170 1171 TYPE(attribute_type) :: attribute !< new attribute1172 1173 1174 return_value = 01175 1176 IF ( PRESENT( variable_name ) ) THEN1177 variable_name_internal = TRIM( variable_name )1178 ELSE1179 variable_name_internal = ''1180 ENDIF1181 1182 IF ( PRESENT( append ) ) THEN1183 IF ( append ) THEN1184 return_value = 11185 CALL internal_message( 'error', routine_name // &1186 ': numeric attribute cannot be appended ' // &1187 '(attribute "' // TRIM( attribute_name ) // &1188 '", variable "' // TRIM( variable_name_internal ) // &1189 '", file "' // TRIM( file_name ) // '")!' )1190 ENDIF1191 ENDIF1192 1193 IF ( return_value == 0 ) THEN1194 append_internal = .FALSE.1195 1196 attribute%name = TRIM( attribute_name )1197 attribute%data_type = 'int32'1198 attribute%value_int32 = value1199 1200 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &1201 variable_name=TRIM( variable_name_internal ), &1202 attribute=attribute, append=append_internal )1203 ENDIF1204 1205 END FUNCTION dom_def_att_int321160 FUNCTION dom_def_att_int32( file_name, variable_name, attribute_name, value, append ) & 1161 RESULT( return_value ) 1162 1163 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1164 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 1165 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable 1166 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name 1167 1168 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_int32' !< name of routine 1169 1170 INTEGER(KIND=4), INTENT(IN) :: value !< attribute value 1171 1172 INTEGER :: return_value !< return value 1173 1174 LOGICAL :: append_internal !< same as 'append' 1175 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value 1176 1177 TYPE(attribute_type) :: attribute !< new attribute 1178 1179 1180 return_value = 0 1181 1182 IF ( PRESENT( variable_name ) ) THEN 1183 variable_name_internal = TRIM( variable_name ) 1184 ELSE 1185 variable_name_internal = '' 1186 ENDIF 1187 1188 IF ( PRESENT( append ) ) THEN 1189 IF ( append ) THEN 1190 return_value = 1 1191 CALL internal_message( 'error', routine_name // & 1192 ': numeric attribute cannot be appended ' // & 1193 '(attribute "' // TRIM( attribute_name ) // & 1194 '", variable "' // TRIM( variable_name_internal ) // & 1195 '", file "' // TRIM( file_name ) // '")!' ) 1196 ENDIF 1197 ENDIF 1198 1199 IF ( return_value == 0 ) THEN 1200 append_internal = .FALSE. 1201 1202 attribute%name = TRIM( attribute_name ) 1203 attribute%data_type = 'int32' 1204 attribute%value_int32 = value 1205 1206 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 1207 variable_name=TRIM( variable_name_internal ), & 1208 attribute=attribute, append=append_internal ) 1209 ENDIF 1210 1211 END FUNCTION dom_def_att_int32 1206 1212 1207 1213 !--------------------------------------------------------------------------------------------------! … … 1224 1230 !> value=1.0_4 ) 1225 1231 !--------------------------------------------------------------------------------------------------! 1226 FUNCTION dom_def_att_real32( file_name, variable_name, attribute_name, value, append ) &1227 RESULT( return_value )1228 1229 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file1230 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute1231 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable1232 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name1233 1234 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real32' !< name of routine1235 1236 INTEGER :: return_value !< return value1237 1238 LOGICAL :: append_internal !< same as 'append'1239 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value1240 1241 REAL(KIND=4), INTENT(IN) :: value !< attribute value1242 1243 TYPE(attribute_type) :: attribute !< new attribute1244 1245 1246 return_value = 01247 1248 IF ( PRESENT( variable_name ) ) THEN1249 variable_name_internal = TRIM( variable_name )1250 ELSE1251 variable_name_internal = ''1252 ENDIF1253 1254 IF ( PRESENT( append ) ) THEN1255 IF ( append ) THEN1256 return_value = 11257 CALL internal_message( 'error', routine_name // &1258 ': numeric attribute cannot be appended ' // &1259 '(attribute "' // TRIM( attribute_name ) // &1260 '", variable "' // TRIM( variable_name_internal ) // &1261 '", file "' // TRIM( file_name ) // '")!' )1262 ENDIF1263 ENDIF1264 1265 IF ( return_value == 0 ) THEN1266 append_internal = .FALSE.1267 1268 attribute%name = TRIM( attribute_name )1269 attribute%data_type = 'real32'1270 attribute%value_real32 = value1271 1272 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &1273 variable_name=TRIM( variable_name_internal ), &1274 attribute=attribute, append=append_internal )1275 ENDIF1276 1277 END FUNCTION dom_def_att_real321232 FUNCTION dom_def_att_real32( file_name, variable_name, attribute_name, value, append ) & 1233 RESULT( return_value ) 1234 1235 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1236 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 1237 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable 1238 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name 1239 1240 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real32' !< name of routine 1241 1242 INTEGER :: return_value !< return value 1243 1244 LOGICAL :: append_internal !< same as 'append' 1245 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value 1246 1247 REAL(KIND=4), INTENT(IN) :: value !< attribute value 1248 1249 TYPE(attribute_type) :: attribute !< new attribute 1250 1251 1252 return_value = 0 1253 1254 IF ( PRESENT( variable_name ) ) THEN 1255 variable_name_internal = TRIM( variable_name ) 1256 ELSE 1257 variable_name_internal = '' 1258 ENDIF 1259 1260 IF ( PRESENT( append ) ) THEN 1261 IF ( append ) THEN 1262 return_value = 1 1263 CALL internal_message( 'error', routine_name // & 1264 ': numeric attribute cannot be appended ' // & 1265 '(attribute "' // TRIM( attribute_name ) // & 1266 '", variable "' // TRIM( variable_name_internal ) // & 1267 '", file "' // TRIM( file_name ) // '")!' ) 1268 ENDIF 1269 ENDIF 1270 1271 IF ( return_value == 0 ) THEN 1272 append_internal = .FALSE. 1273 1274 attribute%name = TRIM( attribute_name ) 1275 attribute%data_type = 'real32' 1276 attribute%value_real32 = value 1277 1278 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 1279 variable_name=TRIM( variable_name_internal ), & 1280 attribute=attribute, append=append_internal ) 1281 ENDIF 1282 1283 END FUNCTION dom_def_att_real32 1278 1284 1279 1285 !--------------------------------------------------------------------------------------------------! … … 1296 1302 !> value=1.0_8 ) 1297 1303 !--------------------------------------------------------------------------------------------------! 1298 FUNCTION dom_def_att_real64( file_name, variable_name, attribute_name, value, append ) &1299 RESULT( return_value )1300 1301 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file1302 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute1303 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable1304 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name1305 1306 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real64' !< name of routine1307 1308 INTEGER :: return_value !< return value1309 1310 LOGICAL :: append_internal !< same as 'append'1311 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value1312 1313 REAL(KIND=8), INTENT(IN) :: value !< attribute value1314 1315 TYPE(attribute_type) :: attribute !< new attribute1316 1317 1318 return_value = 01319 1320 IF ( PRESENT( variable_name ) ) THEN1321 variable_name_internal = TRIM( variable_name )1322 ELSE1323 variable_name_internal = ''1324 ENDIF1325 1326 IF ( PRESENT( append ) ) THEN1327 IF ( append ) THEN1328 return_value = 11329 CALL internal_message( 'error', routine_name // &1330 ': numeric attribute cannot be appended ' // &1331 '(attribute "' // TRIM( attribute_name ) // &1332 '", variable "' // TRIM( variable_name_internal ) // &1333 '", file "' // TRIM( file_name ) // '")!' )1334 ENDIF1335 ENDIF1336 1337 IF ( return_value == 0 ) THEN1338 append_internal = .FALSE.1339 1340 attribute%name = TRIM( attribute_name )1341 attribute%data_type = 'real64'1342 attribute%value_real64 = value1343 1344 return_value = save_attribute_in_database( file_name=TRIM( file_name ), &1345 variable_name=TRIM( variable_name_internal ), &1346 attribute=attribute, append=append_internal )1347 ENDIF1348 1349 END FUNCTION dom_def_att_real641304 FUNCTION dom_def_att_real64( file_name, variable_name, attribute_name, value, append ) & 1305 RESULT( return_value ) 1306 1307 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1308 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute 1309 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name !< name of variable 1310 CHARACTER(LEN=charlen) :: variable_name_internal !< internal copy of variable_name 1311 1312 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_att_real64' !< name of routine 1313 1314 INTEGER :: return_value !< return value 1315 1316 LOGICAL :: append_internal !< same as 'append' 1317 LOGICAL, INTENT(IN), OPTIONAL :: append !< if true, append value to existing value 1318 1319 REAL(KIND=8), INTENT(IN) :: value !< attribute value 1320 1321 TYPE(attribute_type) :: attribute !< new attribute 1322 1323 1324 return_value = 0 1325 1326 IF ( PRESENT( variable_name ) ) THEN 1327 variable_name_internal = TRIM( variable_name ) 1328 ELSE 1329 variable_name_internal = '' 1330 ENDIF 1331 1332 IF ( PRESENT( append ) ) THEN 1333 IF ( append ) THEN 1334 return_value = 1 1335 CALL internal_message( 'error', routine_name // & 1336 ': numeric attribute cannot be appended ' // & 1337 '(attribute "' // TRIM( attribute_name ) // & 1338 '", variable "' // TRIM( variable_name_internal ) // & 1339 '", file "' // TRIM( file_name ) // '")!' ) 1340 ENDIF 1341 ENDIF 1342 1343 IF ( return_value == 0 ) THEN 1344 append_internal = .FALSE. 1345 1346 attribute%name = TRIM( attribute_name ) 1347 attribute%data_type = 'real64' 1348 attribute%value_real64 = value 1349 1350 return_value = save_attribute_in_database( file_name=TRIM( file_name ), & 1351 variable_name=TRIM( variable_name_internal ), & 1352 attribute=attribute, append=append_internal ) 1353 ENDIF 1354 1355 END FUNCTION dom_def_att_real64 1350 1356 1351 1357 !--------------------------------------------------------------------------------------------------! … … 1357 1363 !> to the files. 1358 1364 !--------------------------------------------------------------------------------------------------! 1359 FUNCTION dom_def_end() RESULT( return_value ) 1360 1361 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_end' !< name of routine 1362 1363 INTEGER :: d !< loop index 1364 INTEGER :: f !< loop index 1365 INTEGER :: return_value !< return value 1366 1367 INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE, TARGET :: values_int8 !< target array for dimension values 1368 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE, TARGET :: values_int16 !< target array for dimension values 1369 INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET :: values_int32 !< target array for dimension values 1370 INTEGER(iwp), DIMENSION(:), ALLOCATABLE, TARGET :: values_intwp !< target array for dimension values 1371 1372 INTEGER(KIND=1), DIMENSION(:), POINTER, CONTIGUOUS :: values_int8_pointer !< pointer to target array 1373 INTEGER(KIND=2), DIMENSION(:), POINTER, CONTIGUOUS :: values_int16_pointer !< pointer to target array 1374 INTEGER(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS :: values_int32_pointer !< pointer to target array 1375 INTEGER(iwp), DIMENSION(:), POINTER, CONTIGUOUS :: values_intwp_pointer !< pointer to target array 1376 1377 REAL(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET :: values_real32 !< target array for dimension values 1378 REAL(KIND=8), DIMENSION(:), ALLOCATABLE, TARGET :: values_real64 !< target array for dimension values 1379 REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET :: values_realwp !< target array for dimension values 1380 1381 REAL(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS :: values_real32_pointer !< pointer to target array 1382 REAL(KIND=8), DIMENSION(:), POINTER, CONTIGUOUS :: values_real64_pointer !< pointer to target array 1383 REAL(wp), DIMENSION(:), POINTER, CONTIGUOUS :: values_realwp_pointer !< pointer to target array 1384 1385 1386 return_value = 0 1387 CALL internal_message( 'debug', routine_name // ': start' ) 1388 1389 !-- Clear database from empty files and unused dimensions 1390 IF ( nfiles > 0 ) return_value = cleanup_database() 1391 1392 IF ( return_value == 0 ) THEN 1393 DO f = 1, nfiles 1394 1395 !-- Skip initialization if file is already initialized 1396 IF ( files(f)%is_init ) CYCLE 1397 1398 CALL internal_message( 'debug', routine_name // ': initialize file "' // & 1399 TRIM( files(f)%name ) // '"' ) 1400 1401 !-- Open file 1402 CALL open_output_file( files(f)%format, files(f)%name, files(f)%id, & 1403 return_value=return_value ) 1404 1405 !-- Initialize file header: 1406 !-- define dimensions and variables and write attributes 1407 IF ( return_value == 0 ) & 1408 CALL init_file_header( files(f), return_value=return_value ) 1409 1410 !-- End file definition 1411 IF ( return_value == 0 ) & 1412 CALL stop_file_header_definition( files(f)%format, files(f)%id, & 1413 files(f)%name, return_value ) 1414 1415 IF ( return_value == 0 ) THEN 1416 1417 !-- Flag file as initialized 1418 files(f)%is_init = .TRUE. 1419 1420 !-- Write dimension values into file 1421 DO d = 1, SIZE( files(f)%dimensions ) 1422 IF ( ALLOCATED( files(f)%dimensions(d)%values_int8 ) ) THEN 1423 ALLOCATE( values_int8(files(f)%dimensions(d)%bounds(1): & 1424 files(f)%dimensions(d)%bounds(2)) ) 1425 values_int8 = files(f)%dimensions(d)%values_int8 1426 values_int8_pointer => values_int8 1427 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1428 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1429 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1430 values_int8_1d=values_int8_pointer ) 1431 DEALLOCATE( values_int8 ) 1432 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int16 ) ) THEN 1433 ALLOCATE( values_int16(files(f)%dimensions(d)%bounds(1): & 1365 FUNCTION dom_def_end() RESULT( return_value ) 1366 1367 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_def_end' !< name of routine 1368 1369 INTEGER :: d !< loop index 1370 INTEGER :: f !< loop index 1371 INTEGER :: return_value !< return value 1372 1373 INTEGER(KIND=1), DIMENSION(:), ALLOCATABLE, TARGET :: values_int8 !< target array for dimension values 1374 INTEGER(KIND=2), DIMENSION(:), ALLOCATABLE, TARGET :: values_int16 !< target array for dimension values 1375 INTEGER(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET :: values_int32 !< target array for dimension values 1376 INTEGER(iwp), DIMENSION(:), ALLOCATABLE, TARGET :: values_intwp !< target array for dimension values 1377 1378 INTEGER(KIND=1), DIMENSION(:), POINTER, CONTIGUOUS :: values_int8_pointer !< pointer to target array 1379 INTEGER(KIND=2), DIMENSION(:), POINTER, CONTIGUOUS :: values_int16_pointer !< pointer to target array 1380 INTEGER(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS :: values_int32_pointer !< pointer to target array 1381 INTEGER(iwp), DIMENSION(:), POINTER, CONTIGUOUS :: values_intwp_pointer !< pointer to target array 1382 1383 REAL(KIND=4), DIMENSION(:), ALLOCATABLE, TARGET :: values_real32 !< target array for dimension values 1384 REAL(KIND=8), DIMENSION(:), ALLOCATABLE, TARGET :: values_real64 !< target array for dimension values 1385 REAL(wp), DIMENSION(:), ALLOCATABLE, TARGET :: values_realwp !< target array for dimension values 1386 1387 REAL(KIND=4), DIMENSION(:), POINTER, CONTIGUOUS :: values_real32_pointer !< pointer to target array 1388 REAL(KIND=8), DIMENSION(:), POINTER, CONTIGUOUS :: values_real64_pointer !< pointer to target array 1389 REAL(wp), DIMENSION(:), POINTER, CONTIGUOUS :: values_realwp_pointer !< pointer to target array 1390 1391 1392 return_value = 0 1393 CALL internal_message( 'debug', routine_name // ': start' ) 1394 ! 1395 !-- Clear database from empty files and unused dimensions 1396 IF ( nfiles > 0 ) return_value = cleanup_database() 1397 1398 IF ( return_value == 0 ) THEN 1399 DO f = 1, nfiles 1400 ! 1401 !-- Skip initialization if file is already initialized 1402 IF ( files(f)%is_init ) CYCLE 1403 1404 CALL internal_message( 'debug', routine_name // ': initialize file "' // & 1405 TRIM( files(f)%name ) // '"' ) 1406 ! 1407 !-- Open file 1408 CALL open_output_file( files(f)%format, files(f)%name, files(f)%id, & 1409 return_value=return_value ) 1410 ! 1411 !-- Initialize file header: 1412 !-- define dimensions and variables and write attributes 1413 IF ( return_value == 0 ) & 1414 CALL init_file_header( files(f), return_value=return_value ) 1415 ! 1416 !-- End file definition 1417 IF ( return_value == 0 ) & 1418 CALL stop_file_header_definition( files(f)%format, files(f)%id, & 1419 files(f)%name, return_value ) 1420 1421 IF ( return_value == 0 ) THEN 1422 ! 1423 !-- Flag file as initialized 1424 files(f)%is_init = .TRUE. 1425 ! 1426 !-- Write dimension values into file 1427 DO d = 1, SIZE( files(f)%dimensions ) 1428 IF ( ALLOCATED( files(f)%dimensions(d)%values_int8 ) ) THEN 1429 ALLOCATE( values_int8(files(f)%dimensions(d)%bounds(1): & 1434 1430 files(f)%dimensions(d)%bounds(2)) ) 1435 values_int16 = files(f)%dimensions(d)%values_int16 1436 values_int16_pointer => values_int16 1437 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1438 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1439 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1440 values_int16_1d=values_int16_pointer ) 1441 DEALLOCATE( values_int16 ) 1442 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int32 ) ) THEN 1443 ALLOCATE( values_int32(files(f)%dimensions(d)%bounds(1): & 1444 files(f)%dimensions(d)%bounds(2)) ) 1445 values_int32 = files(f)%dimensions(d)%values_int32 1446 values_int32_pointer => values_int32 1447 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1448 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1449 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1450 values_int32_1d=values_int32_pointer ) 1451 DEALLOCATE( values_int32 ) 1452 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_intwp ) ) THEN 1453 ALLOCATE( values_intwp(files(f)%dimensions(d)%bounds(1): & 1454 files(f)%dimensions(d)%bounds(2)) ) 1455 values_intwp = files(f)%dimensions(d)%values_intwp 1456 values_intwp_pointer => values_intwp 1457 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1458 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1459 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1460 values_intwp_1d=values_intwp_pointer ) 1461 DEALLOCATE( values_intwp ) 1462 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real32 ) ) THEN 1463 ALLOCATE( values_real32(files(f)%dimensions(d)%bounds(1): & 1431 values_int8 = files(f)%dimensions(d)%values_int8 1432 values_int8_pointer => values_int8 1433 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1434 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1435 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1436 values_int8_1d=values_int8_pointer ) 1437 DEALLOCATE( values_int8 ) 1438 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int16 ) ) THEN 1439 ALLOCATE( values_int16(files(f)%dimensions(d)%bounds(1): & 1464 1440 files(f)%dimensions(d)%bounds(2)) ) 1465 values_real32 = files(f)%dimensions(d)%values_real321466 values_real32_pointer => values_real321467 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &1468 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &1469 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &1470 values_real32_1d=values_real32_pointer )1471 DEALLOCATE( values_real32)1472 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real64) ) THEN1473 ALLOCATE( values_real64(files(f)%dimensions(d)%bounds(1): &1441 values_int16 = files(f)%dimensions(d)%values_int16 1442 values_int16_pointer => values_int16 1443 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1444 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1445 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1446 values_int16_1d=values_int16_pointer ) 1447 DEALLOCATE( values_int16 ) 1448 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_int32 ) ) THEN 1449 ALLOCATE( values_int32(files(f)%dimensions(d)%bounds(1): & 1474 1450 files(f)%dimensions(d)%bounds(2)) ) 1475 values_real64 = files(f)%dimensions(d)%values_real641476 values_real64_pointer => values_real641477 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, &1478 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), &1479 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), &1480 values_real64_1d=values_real64_pointer )1481 DEALLOCATE( values_real64)1482 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_realwp ) ) THEN1483 ALLOCATE( values_realwp(files(f)%dimensions(d)%bounds(1): &1451 values_int32 = files(f)%dimensions(d)%values_int32 1452 values_int32_pointer => values_int32 1453 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1454 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1455 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1456 values_int32_1d=values_int32_pointer ) 1457 DEALLOCATE( values_int32 ) 1458 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_intwp ) ) THEN 1459 ALLOCATE( values_intwp(files(f)%dimensions(d)%bounds(1): & 1484 1460 files(f)%dimensions(d)%bounds(2)) ) 1485 values_realwp = files(f)%dimensions(d)%values_realwp 1486 values_realwp_pointer => values_realwp 1487 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1488 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1489 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1490 values_realwp_1d=values_realwp_pointer ) 1491 DEALLOCATE( values_realwp ) 1492 ENDIF 1493 IF ( return_value /= 0 ) EXIT 1494 ENDDO 1495 1496 ENDIF 1497 1498 IF ( return_value /= 0 ) EXIT 1499 1500 ENDDO 1501 ENDIF 1502 1503 CALL internal_message( 'debug', routine_name // ': finished' ) 1504 1505 END FUNCTION dom_def_end 1461 values_intwp = files(f)%dimensions(d)%values_intwp 1462 values_intwp_pointer => values_intwp 1463 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1464 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1465 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1466 values_intwp_1d=values_intwp_pointer ) 1467 DEALLOCATE( values_intwp ) 1468 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real32 ) ) THEN 1469 ALLOCATE( values_real32(files(f)%dimensions(d)%bounds(1): & 1470 files(f)%dimensions(d)%bounds(2)) ) 1471 values_real32 = files(f)%dimensions(d)%values_real32 1472 values_real32_pointer => values_real32 1473 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1474 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1475 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1476 values_real32_1d=values_real32_pointer ) 1477 DEALLOCATE( values_real32 ) 1478 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_real64 ) ) THEN 1479 ALLOCATE( values_real64(files(f)%dimensions(d)%bounds(1): & 1480 files(f)%dimensions(d)%bounds(2)) ) 1481 values_real64 = files(f)%dimensions(d)%values_real64 1482 values_real64_pointer => values_real64 1483 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1484 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1485 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1486 values_real64_1d=values_real64_pointer ) 1487 DEALLOCATE( values_real64 ) 1488 ELSEIF ( ALLOCATED( files(f)%dimensions(d)%values_realwp ) ) THEN 1489 ALLOCATE( values_realwp(files(f)%dimensions(d)%bounds(1): & 1490 files(f)%dimensions(d)%bounds(2)) ) 1491 values_realwp = files(f)%dimensions(d)%values_realwp 1492 values_realwp_pointer => values_realwp 1493 return_value = dom_write_var( files(f)%name, files(f)%dimensions(d)%name, & 1494 bounds_start=(/ files(f)%dimensions(d)%bounds(1) /), & 1495 bounds_end =(/ files(f)%dimensions(d)%bounds(2) /), & 1496 values_realwp_1d=values_realwp_pointer ) 1497 DEALLOCATE( values_realwp ) 1498 ENDIF 1499 IF ( return_value /= 0 ) EXIT 1500 ENDDO 1501 1502 ENDIF 1503 1504 IF ( return_value /= 0 ) EXIT 1505 1506 ENDDO 1507 ENDIF 1508 1509 CALL internal_message( 'debug', routine_name // ': finished' ) 1510 1511 END FUNCTION dom_def_end 1506 1512 1507 1513 !--------------------------------------------------------------------------------------------------! … … 1526 1532 !> chosen, the values are written to file as given in the 'dom_write_var' call. 1527 1533 !--------------------------------------------------------------------------------------------------! 1528 FUNCTION dom_write_var( file_name, variable_name, bounds_start, bounds_end, & 1529 values_int8_0d, values_int8_1d, values_int8_2d, values_int8_3d, & 1530 values_int16_0d, values_int16_1d, values_int16_2d, values_int16_3d, & 1531 values_int32_0d, values_int32_1d, values_int32_2d, values_int32_3d, & 1532 values_intwp_0d, values_intwp_1d, values_intwp_2d, values_intwp_3d, & 1533 values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, & 1534 values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, & 1535 values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d & 1536 ) RESULT( return_value ) 1537 1538 CHARACTER(LEN=charlen) :: file_format !< file format chosen for file 1539 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1540 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 1541 1542 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_write_var' !< name of routine 1543 1544 INTEGER :: file_id !< file ID 1545 INTEGER :: i !< loop index 1546 INTEGER :: j !< loop index 1547 INTEGER :: k !< loop index 1548 INTEGER :: output_return_value !< return value of a called output routine 1549 INTEGER :: return_value !< return value 1550 INTEGER :: variable_id !< variable ID 1551 1552 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_end !< end index per dimension of variable 1553 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_start !< start index per dimension of variable 1554 INTEGER, DIMENSION(:), ALLOCATABLE :: bounds_origin !< first index of each dimension 1555 INTEGER, DIMENSION(:), ALLOCATABLE :: bounds_start_internal !< start index per dim. for output after masking 1556 INTEGER, DIMENSION(:), ALLOCATABLE :: value_counts !< count of indices to be written per dimension 1557 INTEGER, DIMENSION(:,:), ALLOCATABLE :: masked_indices !< list containing all output indices along a dimension 1558 1559 LOGICAL :: do_output !< true if any data lies within given range of masked dimension 1560 LOGICAL :: is_global !< true if variable is global 1561 1562 INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL :: values_int8_0d !< output variable 1563 INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL :: values_int16_0d !< output variable 1564 INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_int32_0d !< output variable 1565 INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL :: values_intwp_0d !< output variable 1566 INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int8_1d !< output variable 1567 INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int16_1d !< output variable 1568 INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int32_1d !< output variable 1569 INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_intwp_1d !< output variable 1570 INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int8_2d !< output variable 1571 INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int16_2d !< output variable 1572 INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int32_2d !< output variable 1573 INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_intwp_2d !< output variable 1574 INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int8_3d !< output variable 1575 INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int16_3d !< output variable 1576 INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int32_3d !< output variable 1577 INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_intwp_3d !< output variable 1578 1579 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int8_1d_resorted !< resorted output variable 1580 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int16_1d_resorted !< resorted output variable 1581 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int32_1d_resorted !< resorted output variable 1582 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:) :: values_intwp_1d_resorted !< resorted output variable 1583 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int8_2d_resorted !< resorted output variable 1584 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int16_2d_resorted !< resorted output variable 1585 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int32_2d_resorted !< resorted output variable 1586 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_intwp_2d_resorted !< resorted output variable 1587 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int8_3d_resorted !< resorted output variable 1588 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int16_3d_resorted !< resorted output variable 1589 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int32_3d_resorted !< resorted output variable 1590 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_intwp_3d_resorted !< resorted output variable 1591 1592 INTEGER(KIND=1), POINTER :: values_int8_0d_pointer !< pointer to resortet array 1593 INTEGER(KIND=2), POINTER :: values_int16_0d_pointer !< pointer to resortet array 1594 INTEGER(KIND=4), POINTER :: values_int32_0d_pointer !< pointer to resortet array 1595 INTEGER(iwp), POINTER :: values_intwp_0d_pointer !< pointer to resortet array 1596 INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:) :: values_int8_1d_pointer !< pointer to resortet array 1597 INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:) :: values_int16_1d_pointer !< pointer to resortet array 1598 INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:) :: values_int32_1d_pointer !< pointer to resortet array 1599 INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:) :: values_intwp_1d_pointer !< pointer to resortet array 1600 INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_int8_2d_pointer !< pointer to resortet array 1601 INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_int16_2d_pointer !< pointer to resortet array 1602 INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_int32_2d_pointer !< pointer to resortet array 1603 INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_intwp_2d_pointer !< pointer to resortet array 1604 INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_int8_3d_pointer !< pointer to resortet array 1605 INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_int16_3d_pointer !< pointer to resortet array 1606 INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_int32_3d_pointer !< pointer to resortet array 1607 INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_intwp_3d_pointer !< pointer to resortet array 1608 1609 REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_real32_0d !< output variable 1610 REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL :: values_real64_0d !< output variable 1611 REAL(wp), POINTER, INTENT(IN), OPTIONAL :: values_realwp_0d !< output variable 1612 REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real32_1d !< output variable 1613 REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real64_1d !< output variable 1614 REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_realwp_1d !< output variable 1615 REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real32_2d !< output variable 1616 REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real64_2d !< output variable 1617 REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_realwp_2d !< output variable 1618 REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real32_3d !< output variable 1619 REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real64_3d !< output variable 1620 REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_realwp_3d !< output variable 1621 1622 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: values_real32_1d_resorted !< resorted output variable 1623 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:) :: values_real64_1d_resorted !< resorted output variable 1624 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:) :: values_realwp_1d_resorted !< resorted output variable 1625 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_real32_2d_resorted !< resorted output variable 1626 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_real64_2d_resorted !< resorted output variable 1627 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_realwp_2d_resorted !< resorted output variable 1628 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_real32_3d_resorted !< resorted output variable 1629 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_real64_3d_resorted !< resorted output variable 1630 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_realwp_3d_resorted !< resorted output variable 1631 1632 REAL(KIND=4), POINTER :: values_real32_0d_pointer !< pointer to resortet array 1633 REAL(KIND=8), POINTER :: values_real64_0d_pointer !< pointer to resortet array 1634 REAL(wp), POINTER :: values_realwp_0d_pointer !< pointer to resortet array 1635 REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:) :: values_real32_1d_pointer !< pointer to resortet array 1636 REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:) :: values_real64_1d_pointer !< pointer to resortet array 1637 REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:) :: values_realwp_1d_pointer !< pointer to resortet array 1638 REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_real32_2d_pointer !< pointer to resortet array 1639 REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_real64_2d_pointer !< pointer to resortet array 1640 REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_realwp_2d_pointer !< pointer to resortet array 1641 REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_real32_3d_pointer !< pointer to resortet array 1642 REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_real64_3d_pointer !< pointer to resortet array 1643 REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_realwp_3d_pointer !< pointer to resortet array 1644 1645 TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dimension_list !< list of used dimensions of variable 1646 1647 1648 return_value = 0 1649 output_return_value = 0 1650 1651 CALL internal_message( 'debug', routine_name // ': write ' // TRIM( variable_name ) // & 1652 ' into file ' // TRIM( file_name ) ) 1653 1654 !-- Search for variable within file 1655 CALL find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, & 1656 is_global, dimension_list, return_value=return_value ) 1657 1658 IF ( return_value == 0 ) THEN 1659 1660 !-- Check if the correct amount of variable bounds were given 1661 IF ( SIZE( bounds_start ) /= SIZE( dimension_list ) .OR. & 1662 SIZE( bounds_end ) /= SIZE( dimension_list ) ) THEN 1663 return_value = 1 1664 CALL internal_message( 'error', routine_name // & 1665 ': number bounds do not match with ' // & 1666 'number of dimensions of variable ' // & 1667 '(variable "' // TRIM( variable_name ) // & 1668 '", file "' // TRIM( file_name ) // '")!' ) 1669 ENDIF 1670 1671 ENDIF 1672 1673 IF ( return_value == 0 ) THEN 1674 1675 !-- Save starting index (lower bounds) of each dimension 1676 ALLOCATE( bounds_origin(SIZE( dimension_list )) ) 1677 ALLOCATE( bounds_start_internal(SIZE( dimension_list )) ) 1678 ALLOCATE( value_counts(SIZE( dimension_list )) ) 1679 1680 WRITE( temp_string, * ) bounds_start 1681 CALL internal_message( 'debug', routine_name // & 1682 ': file "' // TRIM( file_name ) // & 1683 '", variable "' // TRIM( variable_name ) // & 1684 '", bounds_start =' // TRIM( temp_string ) ) 1685 WRITE( temp_string, * ) bounds_end 1686 CALL internal_message( 'debug', routine_name // & 1687 ': file "' // TRIM( file_name ) // & 1688 '", variable "' // TRIM( variable_name ) // & 1689 '", bounds_end =' // TRIM( temp_string ) ) 1690 1691 !-- Get bounds for masking 1692 CALL get_masked_indices_and_masked_dimension_bounds( dimension_list, & 1693 bounds_start, bounds_end, bounds_start_internal, value_counts, bounds_origin, & 1694 masked_indices ) 1695 1696 do_output = .NOT. ANY( value_counts == 0 ) 1697 1698 WRITE( temp_string, * ) bounds_start_internal 1699 CALL internal_message( 'debug', routine_name // & 1700 ': file "' // TRIM( file_name ) // & 1701 '", variable "' // TRIM( variable_name ) // & 1702 '", bounds_start_internal =' // TRIM( temp_string ) ) 1703 WRITE( temp_string, * ) value_counts 1704 CALL internal_message( 'debug', routine_name // & 1705 ': file "' // TRIM( file_name ) // & 1706 '", variable "' // TRIM( variable_name ) // & 1707 '", value_counts =' // TRIM( temp_string ) ) 1708 1709 !-- Mask and resort variable 1710 !-- 8bit integer output 1711 IF ( PRESENT( values_int8_0d ) ) THEN 1712 values_int8_0d_pointer => values_int8_0d 1713 ELSEIF ( PRESENT( values_int8_1d ) ) THEN 1714 IF ( do_output ) THEN 1715 ALLOCATE( values_int8_1d_resorted(0:value_counts(1)-1) ) 1716 !$OMP PARALLEL PRIVATE (i) 1717 !$OMP DO 1718 DO i = 0, value_counts(1) - 1 1719 values_int8_1d_resorted(i) = values_int8_1d(masked_indices(1,i)) 1720 ENDDO 1721 !$OMP END PARALLEL 1722 ELSE 1723 ALLOCATE( values_int8_1d_resorted(1) ) 1724 values_int8_1d_resorted = 0_1 1725 ENDIF 1726 values_int8_1d_pointer => values_int8_1d_resorted 1727 ELSEIF ( PRESENT( values_int8_2d ) ) THEN 1728 IF ( do_output ) THEN 1729 ALLOCATE( values_int8_2d_resorted(0:value_counts(1)-1, & 1730 0:value_counts(2)-1) ) 1731 !$OMP PARALLEL PRIVATE (i,j) 1732 !$OMP DO 1733 DO i = 0, value_counts(1) - 1 1734 DO j = 0, value_counts(2) - 1 1735 values_int8_2d_resorted(i,j) = values_int8_2d(masked_indices(2,j), & 1736 masked_indices(1,i) ) 1737 ENDDO 1738 ENDDO 1739 !$OMP END PARALLEL 1740 ELSE 1741 ALLOCATE( values_int8_2d_resorted(1,1) ) 1742 values_int8_2d_resorted = 0_1 1743 ENDIF 1744 values_int8_2d_pointer => values_int8_2d_resorted 1745 ELSEIF ( PRESENT( values_int8_3d ) ) THEN 1746 IF ( do_output ) THEN 1747 ALLOCATE( values_int8_3d_resorted(0:value_counts(1)-1, & 1748 0:value_counts(2)-1, & 1749 0:value_counts(3)-1) ) 1750 !$OMP PARALLEL PRIVATE (i,j,k) 1751 !$OMP DO 1752 DO i = 0, value_counts(1) - 1 1753 DO j = 0, value_counts(2) - 1 1754 DO k = 0, value_counts(3) - 1 1755 values_int8_3d_resorted(i,j,k) = values_int8_3d(masked_indices(3,k), & 1756 masked_indices(2,j), & 1757 masked_indices(1,i) ) 1758 ENDDO 1759 ENDDO 1760 ENDDO 1761 !$OMP END PARALLEL 1762 ELSE 1763 ALLOCATE( values_int8_3d_resorted(1,1,1) ) 1764 values_int8_3d_resorted = 0_1 1765 ENDIF 1766 values_int8_3d_pointer => values_int8_3d_resorted 1767 1768 !-- 16bit integer output 1769 ELSEIF ( PRESENT( values_int16_0d ) ) THEN 1770 values_int16_0d_pointer => values_int16_0d 1771 ELSEIF ( PRESENT( values_int16_1d ) ) THEN 1772 IF ( do_output ) THEN 1773 ALLOCATE( values_int16_1d_resorted(0:value_counts(1)-1) ) 1774 !$OMP PARALLEL PRIVATE (i) 1775 !$OMP DO 1776 DO i = 0, value_counts(1) - 1 1777 values_int16_1d_resorted(i) = values_int16_1d(masked_indices(1,i)) 1778 ENDDO 1779 !$OMP END PARALLEL 1780 ELSE 1781 ALLOCATE( values_int16_1d_resorted(1) ) 1782 values_int16_1d_resorted = 0_1 1783 ENDIF 1784 values_int16_1d_pointer => values_int16_1d_resorted 1785 ELSEIF ( PRESENT( values_int16_2d ) ) THEN 1786 IF ( do_output ) THEN 1787 ALLOCATE( values_int16_2d_resorted(0:value_counts(1)-1, & 1534 FUNCTION dom_write_var( file_name, variable_name, bounds_start, bounds_end, & 1535 values_int8_0d, values_int8_1d, values_int8_2d, values_int8_3d, & 1536 values_int16_0d, values_int16_1d, values_int16_2d, values_int16_3d, & 1537 values_int32_0d, values_int32_1d, values_int32_2d, values_int32_3d, & 1538 values_intwp_0d, values_intwp_1d, values_intwp_2d, values_intwp_3d, & 1539 values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, & 1540 values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, & 1541 values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d & 1542 ) RESULT( return_value ) 1543 1544 CHARACTER(LEN=charlen) :: file_format !< file format chosen for file 1545 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 1546 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 1547 1548 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_write_var' !< name of routine 1549 1550 INTEGER :: file_id !< file ID 1551 INTEGER :: i !< loop index 1552 INTEGER :: j !< loop index 1553 INTEGER :: k !< loop index 1554 INTEGER :: output_return_value !< return value of a called output routine 1555 INTEGER :: return_value !< return value 1556 INTEGER :: variable_id !< variable ID 1557 1558 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_end !< end index per dimension of variable 1559 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_start !< start index per dimension of variable 1560 INTEGER, DIMENSION(:), ALLOCATABLE :: bounds_origin !< first index of each dimension 1561 INTEGER, DIMENSION(:), ALLOCATABLE :: bounds_start_internal !< start index per dim. for output after masking 1562 INTEGER, DIMENSION(:), ALLOCATABLE :: value_counts !< count of indices to be written per dimension 1563 INTEGER, DIMENSION(:,:), ALLOCATABLE :: masked_indices !< list containing all output indices along a dimension 1564 1565 LOGICAL :: do_output !< true if any data lies within given range of masked dimension 1566 LOGICAL :: is_global !< true if variable is global 1567 1568 INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL :: values_int8_0d !< output variable 1569 INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL :: values_int16_0d !< output variable 1570 INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_int32_0d !< output variable 1571 INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL :: values_intwp_0d !< output variable 1572 INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int8_1d !< output variable 1573 INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int16_1d !< output variable 1574 INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int32_1d !< output variable 1575 INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_intwp_1d !< output variable 1576 INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int8_2d !< output variable 1577 INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int16_2d !< output variable 1578 INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int32_2d !< output variable 1579 INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_intwp_2d !< output variable 1580 INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int8_3d !< output variable 1581 INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int16_3d !< output variable 1582 INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int32_3d !< output variable 1583 INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_intwp_3d !< output variable 1584 1585 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int8_1d_resorted !< resorted output variable 1586 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int16_1d_resorted !< resorted output variable 1587 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: values_int32_1d_resorted !< resorted output variable 1588 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:) :: values_intwp_1d_resorted !< resorted output variable 1589 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int8_2d_resorted !< resorted output variable 1590 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int16_2d_resorted !< resorted output variable 1591 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_int32_2d_resorted !< resorted output variable 1592 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_intwp_2d_resorted !< resorted output variable 1593 INTEGER(KIND=1), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int8_3d_resorted !< resorted output variable 1594 INTEGER(KIND=2), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int16_3d_resorted !< resorted output variable 1595 INTEGER(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_int32_3d_resorted !< resorted output variable 1596 INTEGER(iwp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_intwp_3d_resorted !< resorted output variable 1597 1598 INTEGER(KIND=1), POINTER :: values_int8_0d_pointer !< pointer to resortet array 1599 INTEGER(KIND=2), POINTER :: values_int16_0d_pointer !< pointer to resortet array 1600 INTEGER(KIND=4), POINTER :: values_int32_0d_pointer !< pointer to resortet array 1601 INTEGER(iwp), POINTER :: values_intwp_0d_pointer !< pointer to resortet array 1602 INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:) :: values_int8_1d_pointer !< pointer to resortet array 1603 INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:) :: values_int16_1d_pointer !< pointer to resortet array 1604 INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:) :: values_int32_1d_pointer !< pointer to resortet array 1605 INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:) :: values_intwp_1d_pointer !< pointer to resortet array 1606 INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_int8_2d_pointer !< pointer to resortet array 1607 INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_int16_2d_pointer !< pointer to resortet array 1608 INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_int32_2d_pointer !< pointer to resortet array 1609 INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_intwp_2d_pointer !< pointer to resortet array 1610 INTEGER(KIND=1), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_int8_3d_pointer !< pointer to resortet array 1611 INTEGER(KIND=2), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_int16_3d_pointer !< pointer to resortet array 1612 INTEGER(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_int32_3d_pointer !< pointer to resortet array 1613 INTEGER(iwp), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_intwp_3d_pointer !< pointer to resortet array 1614 1615 REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_real32_0d !< output variable 1616 REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL :: values_real64_0d !< output variable 1617 REAL(wp), POINTER, INTENT(IN), OPTIONAL :: values_realwp_0d !< output variable 1618 REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real32_1d !< output variable 1619 REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real64_1d !< output variable 1620 REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_realwp_1d !< output variable 1621 REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real32_2d !< output variable 1622 REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real64_2d !< output variable 1623 REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_realwp_2d !< output variable 1624 REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real32_3d !< output variable 1625 REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real64_3d !< output variable 1626 REAL(wp), POINTER, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_realwp_3d !< output variable 1627 1628 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:) :: values_real32_1d_resorted !< resorted output variable 1629 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:) :: values_real64_1d_resorted !< resorted output variable 1630 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:) :: values_realwp_1d_resorted !< resorted output variable 1631 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_real32_2d_resorted !< resorted output variable 1632 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_real64_2d_resorted !< resorted output variable 1633 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:) :: values_realwp_2d_resorted !< resorted output variable 1634 REAL(KIND=4), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_real32_3d_resorted !< resorted output variable 1635 REAL(KIND=8), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_real64_3d_resorted !< resorted output variable 1636 REAL(wp), TARGET, ALLOCATABLE, DIMENSION(:,:,:) :: values_realwp_3d_resorted !< resorted output variable 1637 1638 REAL(KIND=4), POINTER :: values_real32_0d_pointer !< pointer to resortet array 1639 REAL(KIND=8), POINTER :: values_real64_0d_pointer !< pointer to resortet array 1640 REAL(wp), POINTER :: values_realwp_0d_pointer !< pointer to resortet array 1641 REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:) :: values_real32_1d_pointer !< pointer to resortet array 1642 REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:) :: values_real64_1d_pointer !< pointer to resortet array 1643 REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:) :: values_realwp_1d_pointer !< pointer to resortet array 1644 REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_real32_2d_pointer !< pointer to resortet array 1645 REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_real64_2d_pointer !< pointer to resortet array 1646 REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:,:) :: values_realwp_2d_pointer !< pointer to resortet array 1647 REAL(KIND=4), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_real32_3d_pointer !< pointer to resortet array 1648 REAL(KIND=8), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_real64_3d_pointer !< pointer to resortet array 1649 REAL(wp), POINTER, CONTIGUOUS, DIMENSION(:,:,:) :: values_realwp_3d_pointer !< pointer to resortet array 1650 1651 TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: dimension_list !< list of used dimensions of variable 1652 1653 1654 return_value = 0 1655 output_return_value = 0 1656 1657 CALL internal_message( 'debug', routine_name // ': write ' // TRIM( variable_name ) // & 1658 ' into file ' // TRIM( file_name ) ) 1659 ! 1660 !-- Search for variable within file 1661 CALL find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, & 1662 is_global, dimension_list, return_value=return_value ) 1663 1664 IF ( return_value == 0 ) THEN 1665 ! 1666 !-- Check if the correct amount of variable bounds were given 1667 IF ( SIZE( bounds_start ) /= SIZE( dimension_list ) .OR. & 1668 SIZE( bounds_end ) /= SIZE( dimension_list ) ) THEN 1669 return_value = 1 1670 CALL internal_message( 'error', routine_name // & 1671 ': number bounds do not match with ' // & 1672 'number of dimensions of variable ' // & 1673 '(variable "' // TRIM( variable_name ) // & 1674 '", file "' // TRIM( file_name ) // '")!' ) 1675 ENDIF 1676 1677 ENDIF 1678 1679 IF ( return_value == 0 ) THEN 1680 ! 1681 !-- Save starting index (lower bounds) of each dimension 1682 ALLOCATE( bounds_origin(SIZE( dimension_list )) ) 1683 ALLOCATE( bounds_start_internal(SIZE( dimension_list )) ) 1684 ALLOCATE( value_counts(SIZE( dimension_list )) ) 1685 1686 WRITE( temp_string, * ) bounds_start 1687 CALL internal_message( 'debug', routine_name // & 1688 ': file "' // TRIM( file_name ) // & 1689 '", variable "' // TRIM( variable_name ) // & 1690 '", bounds_start =' // TRIM( temp_string ) ) 1691 WRITE( temp_string, * ) bounds_end 1692 CALL internal_message( 'debug', routine_name // & 1693 ': file "' // TRIM( file_name ) // & 1694 '", variable "' // TRIM( variable_name ) // & 1695 '", bounds_end =' // TRIM( temp_string ) ) 1696 ! 1697 !-- Get bounds for masking 1698 CALL get_masked_indices_and_masked_dimension_bounds( dimension_list, & 1699 bounds_start, bounds_end, bounds_start_internal, value_counts, bounds_origin, & 1700 masked_indices ) 1701 1702 do_output = .NOT. ANY( value_counts == 0 ) 1703 1704 WRITE( temp_string, * ) bounds_start_internal 1705 CALL internal_message( 'debug', routine_name // & 1706 ': file "' // TRIM( file_name ) // & 1707 '", variable "' // TRIM( variable_name ) // & 1708 '", bounds_start_internal =' // TRIM( temp_string ) ) 1709 WRITE( temp_string, * ) value_counts 1710 CALL internal_message( 'debug', routine_name // & 1711 ': file "' // TRIM( file_name ) // & 1712 '", variable "' // TRIM( variable_name ) // & 1713 '", value_counts =' // TRIM( temp_string ) ) 1714 ! 1715 !-- Mask and resort variable 1716 !-- 8bit integer output 1717 IF ( PRESENT( values_int8_0d ) ) THEN 1718 values_int8_0d_pointer => values_int8_0d 1719 ELSEIF ( PRESENT( values_int8_1d ) ) THEN 1720 IF ( do_output ) THEN 1721 ALLOCATE( values_int8_1d_resorted(0:value_counts(1)-1) ) 1722 !$OMP PARALLEL PRIVATE (i) 1723 !$OMP DO 1724 DO i = 0, value_counts(1) - 1 1725 values_int8_1d_resorted(i) = values_int8_1d(masked_indices(1,i)) 1726 ENDDO 1727 !$OMP END PARALLEL 1728 ELSE 1729 ALLOCATE( values_int8_1d_resorted(1) ) 1730 values_int8_1d_resorted = 0_1 1731 ENDIF 1732 values_int8_1d_pointer => values_int8_1d_resorted 1733 ELSEIF ( PRESENT( values_int8_2d ) ) THEN 1734 IF ( do_output ) THEN 1735 ALLOCATE( values_int8_2d_resorted(0:value_counts(1)-1, & 1788 1736 0:value_counts(2)-1) ) 1789 !$OMP PARALLEL PRIVATE (i,j)1790 !$OMP DO1791 DO i = 0, value_counts(1) - 11792 DO j = 0, value_counts(2) - 11793 values_int16_2d_resorted(i,j) = values_int16_2d(masked_indices(2,j), &1794 masked_indices(1,i))1795 ENDDO1796 ENDDO1797 !$OMP END PARALLEL1798 ELSE1799 ALLOCATE( values_int16_2d_resorted(1,1) )1800 values_int16_2d_resorted = 0_11801 ENDIF1802 values_int16_2d_pointer => values_int16_2d_resorted1803 ELSEIF ( PRESENT( values_int16_3d ) ) THEN1804 IF ( do_output ) THEN1805 ALLOCATE( values_int16_3d_resorted(0:value_counts(1)-1, &1737 !$OMP PARALLEL PRIVATE (i,j) 1738 !$OMP DO 1739 DO i = 0, value_counts(1) - 1 1740 DO j = 0, value_counts(2) - 1 1741 values_int8_2d_resorted(i,j) = values_int8_2d(masked_indices(2,j), & 1742 masked_indices(1,i) ) 1743 ENDDO 1744 ENDDO 1745 !$OMP END PARALLEL 1746 ELSE 1747 ALLOCATE( values_int8_2d_resorted(1,1) ) 1748 values_int8_2d_resorted = 0_1 1749 ENDIF 1750 values_int8_2d_pointer => values_int8_2d_resorted 1751 ELSEIF ( PRESENT( values_int8_3d ) ) THEN 1752 IF ( do_output ) THEN 1753 ALLOCATE( values_int8_3d_resorted(0:value_counts(1)-1, & 1806 1754 0:value_counts(2)-1, & 1807 1755 0:value_counts(3)-1) ) 1808 !$OMP PARALLEL PRIVATE (i,j,k) 1809 !$OMP DO 1810 DO i = 0, value_counts(1) - 1 1811 DO j = 0, value_counts(2) - 1 1812 DO k = 0, value_counts(3) - 1 1813 values_int16_3d_resorted(i,j,k) = values_int16_3d(masked_indices(3,k), & 1814 masked_indices(2,j), & 1815 masked_indices(1,i) ) 1816 ENDDO 1817 ENDDO 1818 ENDDO 1819 !$OMP END PARALLEL 1820 ELSE 1821 ALLOCATE( values_int16_3d_resorted(1,1,1) ) 1822 values_int16_3d_resorted = 0_1 1823 ENDIF 1824 values_int16_3d_pointer => values_int16_3d_resorted 1825 1826 !-- 32bit integer output 1827 ELSEIF ( PRESENT( values_int32_0d ) ) THEN 1828 values_int32_0d_pointer => values_int32_0d 1829 ELSEIF ( PRESENT( values_int32_1d ) ) THEN 1830 IF ( do_output ) THEN 1831 ALLOCATE( values_int32_1d_resorted(0:value_counts(1)-1) ) 1832 !$OMP PARALLEL PRIVATE (i) 1833 !$OMP DO 1834 DO i = 0, value_counts(1) - 1 1835 values_int32_1d_resorted(i) = values_int32_1d(masked_indices(1,i)) 1836 ENDDO 1837 !$OMP END PARALLEL 1838 ELSE 1839 ALLOCATE( values_int32_1d_resorted(1) ) 1840 values_int32_1d_resorted = 0_1 1841 ENDIF 1842 values_int32_1d_pointer => values_int32_1d_resorted 1843 ELSEIF ( PRESENT( values_int32_2d ) ) THEN 1844 IF ( do_output ) THEN 1845 ALLOCATE( values_int32_2d_resorted(0:value_counts(1)-1, & 1846 0:value_counts(2)-1) ) 1847 !$OMP PARALLEL PRIVATE (i,j) 1848 !$OMP DO 1849 DO i = 0, value_counts(1) - 1 1850 DO j = 0, value_counts(2) - 1 1851 values_int32_2d_resorted(i,j) = values_int32_2d(masked_indices(2,j), & 1852 masked_indices(1,i) ) 1853 ENDDO 1854 ENDDO 1855 !$OMP END PARALLEL 1856 ELSE 1857 ALLOCATE( values_int32_2d_resorted(1,1) ) 1858 values_int32_2d_resorted = 0_1 1859 ENDIF 1860 values_int32_2d_pointer => values_int32_2d_resorted 1861 ELSEIF ( PRESENT( values_int32_3d ) ) THEN 1862 IF ( do_output ) THEN 1863 ALLOCATE( values_int32_3d_resorted(0:value_counts(1)-1, & 1864 0:value_counts(2)-1, & 1865 0:value_counts(3)-1) ) 1866 !$OMP PARALLEL PRIVATE (i,j,k) 1867 !$OMP DO 1868 DO i = 0, value_counts(1) - 1 1869 DO j = 0, value_counts(2) - 1 1870 DO k = 0, value_counts(3) - 1 1871 values_int32_3d_resorted(i,j,k) = values_int32_3d(masked_indices(3,k), & 1872 masked_indices(2,j), & 1873 masked_indices(1,i) ) 1874 ENDDO 1875 ENDDO 1876 ENDDO 1877 !$OMP END PARALLEL 1878 ELSE 1879 ALLOCATE( values_int32_3d_resorted(1,1,1) ) 1880 values_int32_3d_resorted = 0_1 1881 ENDIF 1882 values_int32_3d_pointer => values_int32_3d_resorted 1883 1884 !-- working-precision integer output 1885 ELSEIF ( PRESENT( values_intwp_0d ) ) THEN 1886 values_intwp_0d_pointer => values_intwp_0d 1887 ELSEIF ( PRESENT( values_intwp_1d ) ) THEN 1888 IF ( do_output ) THEN 1889 ALLOCATE( values_intwp_1d_resorted(0:value_counts(1)-1) ) 1890 !$OMP PARALLEL PRIVATE (i) 1891 !$OMP DO 1892 DO i = 0, value_counts(1) - 1 1893 values_intwp_1d_resorted(i) = values_intwp_1d(masked_indices(1,i)) 1894 ENDDO 1895 !$OMP END PARALLEL 1896 ELSE 1897 ALLOCATE( values_intwp_1d_resorted(1) ) 1898 values_intwp_1d_resorted = 0_1 1899 ENDIF 1900 values_intwp_1d_pointer => values_intwp_1d_resorted 1901 ELSEIF ( PRESENT( values_intwp_2d ) ) THEN 1902 IF ( do_output ) THEN 1903 ALLOCATE( values_intwp_2d_resorted(0:value_counts(1)-1, & 1904 0:value_counts(2)-1) ) 1905 !$OMP PARALLEL PRIVATE (i,j) 1906 !$OMP DO 1907 DO i = 0, value_counts(1) - 1 1908 DO j = 0, value_counts(2) - 1 1909 values_intwp_2d_resorted(i,j) = values_intwp_2d(masked_indices(2,j), & 1910 masked_indices(1,i) ) 1911 ENDDO 1912 ENDDO 1913 !$OMP END PARALLEL 1914 ELSE 1915 ALLOCATE( values_intwp_2d_resorted(1,1) ) 1916 values_intwp_2d_resorted = 0_1 1917 ENDIF 1918 values_intwp_2d_pointer => values_intwp_2d_resorted 1919 ELSEIF ( PRESENT( values_intwp_3d ) ) THEN 1920 IF ( do_output ) THEN 1921 ALLOCATE( values_intwp_3d_resorted(0:value_counts(1)-1, & 1922 0:value_counts(2)-1, & 1923 0:value_counts(3)-1) ) 1924 !$OMP PARALLEL PRIVATE (i,j,k) 1925 !$OMP DO 1926 DO i = 0, value_counts(1) - 1 1927 DO j = 0, value_counts(2) - 1 1928 DO k = 0, value_counts(3) - 1 1929 values_intwp_3d_resorted(i,j,k) = values_intwp_3d(masked_indices(3,k), & 1930 masked_indices(2,j), & 1931 masked_indices(1,i) ) 1932 ENDDO 1933 ENDDO 1934 ENDDO 1935 !$OMP END PARALLEL 1936 ELSE 1937 ALLOCATE( values_intwp_3d_resorted(1,1,1) ) 1938 values_intwp_3d_resorted = 0_1 1939 ENDIF 1940 values_intwp_3d_pointer => values_intwp_3d_resorted 1941 1942 !-- 32bit real output 1943 ELSEIF ( PRESENT( values_real32_0d ) ) THEN 1944 values_real32_0d_pointer => values_real32_0d 1945 ELSEIF ( PRESENT( values_real32_1d ) ) THEN 1946 IF ( do_output ) THEN 1947 ALLOCATE( values_real32_1d_resorted(0:value_counts(1)-1) ) 1948 !$OMP PARALLEL PRIVATE (i) 1949 !$OMP DO 1950 DO i = 0, value_counts(1) - 1 1951 values_real32_1d_resorted(i) = values_real32_1d(masked_indices(1,i)) 1952 ENDDO 1953 !$OMP END PARALLEL 1954 ELSE 1955 ALLOCATE( values_real32_1d_resorted(1) ) 1956 values_real32_1d_resorted = 0_1 1957 ENDIF 1958 values_real32_1d_pointer => values_real32_1d_resorted 1959 ELSEIF ( PRESENT( values_real32_2d ) ) THEN 1960 IF ( do_output ) THEN 1961 ALLOCATE( values_real32_2d_resorted(0:value_counts(1)-1, & 1756 !$OMP PARALLEL PRIVATE (i,j,k) 1757 !$OMP DO 1758 DO i = 0, value_counts(1) - 1 1759 DO j = 0, value_counts(2) - 1 1760 DO k = 0, value_counts(3) - 1 1761 values_int8_3d_resorted(i,j,k) = values_int8_3d(masked_indices(3,k), & 1762 masked_indices(2,j), & 1763 masked_indices(1,i) ) 1764 ENDDO 1765 ENDDO 1766 ENDDO 1767 !$OMP END PARALLEL 1768 ELSE 1769 ALLOCATE( values_int8_3d_resorted(1,1,1) ) 1770 values_int8_3d_resorted = 0_1 1771 ENDIF 1772 values_int8_3d_pointer => values_int8_3d_resorted 1773 ! 1774 !-- 16bit integer output 1775 ELSEIF ( PRESENT( values_int16_0d ) ) THEN 1776 values_int16_0d_pointer => values_int16_0d 1777 ELSEIF ( PRESENT( values_int16_1d ) ) THEN 1778 IF ( do_output ) THEN 1779 ALLOCATE( values_int16_1d_resorted(0:value_counts(1)-1) ) 1780 !$OMP PARALLEL PRIVATE (i) 1781 !$OMP DO 1782 DO i = 0, value_counts(1) - 1 1783 values_int16_1d_resorted(i) = values_int16_1d(masked_indices(1,i)) 1784 ENDDO 1785 !$OMP END PARALLEL 1786 ELSE 1787 ALLOCATE( values_int16_1d_resorted(1) ) 1788 values_int16_1d_resorted = 0_1 1789 ENDIF 1790 values_int16_1d_pointer => values_int16_1d_resorted 1791 ELSEIF ( PRESENT( values_int16_2d ) ) THEN 1792 IF ( do_output ) THEN 1793 ALLOCATE( values_int16_2d_resorted(0:value_counts(1)-1, & 1962 1794 0:value_counts(2)-1) ) 1963 !$OMP PARALLEL PRIVATE (i,j)1964 !$OMP DO1965 DO i = 0, value_counts(1) - 11966 DO j = 0, value_counts(2) - 11967 values_real32_2d_resorted(i,j) = values_real32_2d(masked_indices(2,j), &1968 masked_indices(1,i))1969 ENDDO1970 ENDDO1971 !$OMP END PARALLEL1972 ELSE1973 ALLOCATE( values_real32_2d_resorted(1,1) )1974 values_real32_2d_resorted = 0_11975 ENDIF1976 values_real32_2d_pointer => values_real32_2d_resorted1977 ELSEIF ( PRESENT( values_real32_3d ) ) THEN1978 IF ( do_output ) THEN1979 ALLOCATE( values_real32_3d_resorted(0:value_counts(1)-1, &1795 !$OMP PARALLEL PRIVATE (i,j) 1796 !$OMP DO 1797 DO i = 0, value_counts(1) - 1 1798 DO j = 0, value_counts(2) - 1 1799 values_int16_2d_resorted(i,j) = values_int16_2d(masked_indices(2,j), & 1800 masked_indices(1,i)) 1801 ENDDO 1802 ENDDO 1803 !$OMP END PARALLEL 1804 ELSE 1805 ALLOCATE( values_int16_2d_resorted(1,1) ) 1806 values_int16_2d_resorted = 0_1 1807 ENDIF 1808 values_int16_2d_pointer => values_int16_2d_resorted 1809 ELSEIF ( PRESENT( values_int16_3d ) ) THEN 1810 IF ( do_output ) THEN 1811 ALLOCATE( values_int16_3d_resorted(0:value_counts(1)-1, & 1980 1812 0:value_counts(2)-1, & 1981 1813 0:value_counts(3)-1) ) 1982 !$OMP PARALLEL PRIVATE (i,j,k)1983 !$OMP DO1984 DO i = 0, value_counts(1) - 11985 DO j = 0, value_counts(2) - 11986 DO k = 0, value_counts(3) - 11987 values_real32_3d_resorted(i,j,k) = values_real32_3d(masked_indices(3,k), &1988 1989 1990 ENDDO1991 ENDDO1992 ENDDO1993 !$OMP END PARALLEL1994 ELSE1995 ALLOCATE( values_real32_3d_resorted(1,1,1) )1996 values_real32_3d_resorted = 0_11997 ENDIF1998 values_real32_3d_pointer => values_real32_3d_resorted1999 2000 !-- 64bit realoutput2001 ELSEIF ( PRESENT( values_real64_0d ) ) THEN2002 values_real64_0d_pointer => values_real64_0d2003 ELSEIF ( PRESENT( values_real64_1d ) ) THEN2004 IF ( do_output ) THEN2005 ALLOCATE( values_real64_1d_resorted(0:value_counts(1)-1) )2006 !$OMP PARALLEL PRIVATE (i)2007 !$OMP DO2008 DO i = 0, value_counts(1) - 12009 values_real64_1d_resorted(i) = values_real64_1d(masked_indices(1,i))2010 ENDDO2011 !$OMP END PARALLEL2012 ELSE2013 ALLOCATE( values_real64_1d_resorted(1) )2014 values_real64_1d_resorted = 0_12015 ENDIF2016 values_real64_1d_pointer => values_real64_1d_resorted2017 ELSEIF ( PRESENT( values_real64_2d ) ) THEN2018 IF ( do_output ) THEN2019 ALLOCATE( values_real64_2d_resorted(0:value_counts(1)-1, &1814 !$OMP PARALLEL PRIVATE (i,j,k) 1815 !$OMP DO 1816 DO i = 0, value_counts(1) - 1 1817 DO j = 0, value_counts(2) - 1 1818 DO k = 0, value_counts(3) - 1 1819 values_int16_3d_resorted(i,j,k) = values_int16_3d(masked_indices(3,k), & 1820 masked_indices(2,j), & 1821 masked_indices(1,i) ) 1822 ENDDO 1823 ENDDO 1824 ENDDO 1825 !$OMP END PARALLEL 1826 ELSE 1827 ALLOCATE( values_int16_3d_resorted(1,1,1) ) 1828 values_int16_3d_resorted = 0_1 1829 ENDIF 1830 values_int16_3d_pointer => values_int16_3d_resorted 1831 ! 1832 !-- 32bit integer output 1833 ELSEIF ( PRESENT( values_int32_0d ) ) THEN 1834 values_int32_0d_pointer => values_int32_0d 1835 ELSEIF ( PRESENT( values_int32_1d ) ) THEN 1836 IF ( do_output ) THEN 1837 ALLOCATE( values_int32_1d_resorted(0:value_counts(1)-1) ) 1838 !$OMP PARALLEL PRIVATE (i) 1839 !$OMP DO 1840 DO i = 0, value_counts(1) - 1 1841 values_int32_1d_resorted(i) = values_int32_1d(masked_indices(1,i)) 1842 ENDDO 1843 !$OMP END PARALLEL 1844 ELSE 1845 ALLOCATE( values_int32_1d_resorted(1) ) 1846 values_int32_1d_resorted = 0_1 1847 ENDIF 1848 values_int32_1d_pointer => values_int32_1d_resorted 1849 ELSEIF ( PRESENT( values_int32_2d ) ) THEN 1850 IF ( do_output ) THEN 1851 ALLOCATE( values_int32_2d_resorted(0:value_counts(1)-1, & 2020 1852 0:value_counts(2)-1) ) 2021 !$OMP PARALLEL PRIVATE (i,j)2022 !$OMP DO2023 DO i = 0, value_counts(1) - 12024 DO j = 0, value_counts(2) - 12025 values_real64_2d_resorted(i,j) = values_real64_2d(masked_indices(2,j), &2026 2027 ENDDO2028 ENDDO2029 !$OMP END PARALLEL2030 ELSE2031 ALLOCATE( values_real64_2d_resorted(1,1) )2032 values_real64_2d_resorted = 0_12033 ENDIF2034 values_real64_2d_pointer => values_real64_2d_resorted2035 ELSEIF ( PRESENT( values_real64_3d ) ) THEN2036 IF ( do_output ) THEN2037 ALLOCATE( values_real64_3d_resorted(0:value_counts(1)-1, &1853 !$OMP PARALLEL PRIVATE (i,j) 1854 !$OMP DO 1855 DO i = 0, value_counts(1) - 1 1856 DO j = 0, value_counts(2) - 1 1857 values_int32_2d_resorted(i,j) = values_int32_2d(masked_indices(2,j), & 1858 masked_indices(1,i) ) 1859 ENDDO 1860 ENDDO 1861 !$OMP END PARALLEL 1862 ELSE 1863 ALLOCATE( values_int32_2d_resorted(1,1) ) 1864 values_int32_2d_resorted = 0_1 1865 ENDIF 1866 values_int32_2d_pointer => values_int32_2d_resorted 1867 ELSEIF ( PRESENT( values_int32_3d ) ) THEN 1868 IF ( do_output ) THEN 1869 ALLOCATE( values_int32_3d_resorted(0:value_counts(1)-1, & 2038 1870 0:value_counts(2)-1, & 2039 1871 0:value_counts(3)-1) ) 2040 !$OMP PARALLEL PRIVATE (i,j,k)2041 !$OMP DO2042 DO i = 0, value_counts(1) - 12043 DO j = 0, value_counts(2) - 12044 DO k = 0, value_counts(3) - 12045 values_real64_3d_resorted(i,j,k) = values_real64_3d(masked_indices(3,k), &2046 2047 2048 ENDDO2049 ENDDO2050 ENDDO2051 !$OMP END PARALLEL2052 ELSE2053 ALLOCATE( values_real64_3d_resorted(1,1,1) )2054 values_real64_3d_resorted = 0_12055 ENDIF2056 values_real64_3d_pointer => values_real64_3d_resorted2057 2058 !-- working-precision realoutput2059 ELSEIF ( PRESENT( values_realwp_0d ) ) THEN2060 values_realwp_0d_pointer => values_realwp_0d2061 ELSEIF ( PRESENT( values_realwp_1d ) ) THEN2062 IF ( do_output ) THEN2063 ALLOCATE( values_realwp_1d_resorted(0:value_counts(1)-1) )2064 !$OMP PARALLEL PRIVATE (i)2065 !$OMP DO2066 DO i = 0, value_counts(1) - 12067 values_realwp_1d_resorted(i) = values_realwp_1d(masked_indices(1,i))2068 ENDDO2069 !$OMP END PARALLEL2070 ELSE2071 ALLOCATE( values_realwp_1d_resorted(1) )2072 values_realwp_1d_resorted = 0_12073 ENDIF2074 values_realwp_1d_pointer => values_realwp_1d_resorted2075 ELSEIF ( PRESENT( values_realwp_2d ) ) THEN2076 IF ( do_output ) THEN2077 ALLOCATE( values_realwp_2d_resorted(0:value_counts(1)-1, &1872 !$OMP PARALLEL PRIVATE (i,j,k) 1873 !$OMP DO 1874 DO i = 0, value_counts(1) - 1 1875 DO j = 0, value_counts(2) - 1 1876 DO k = 0, value_counts(3) - 1 1877 values_int32_3d_resorted(i,j,k) = values_int32_3d(masked_indices(3,k), & 1878 masked_indices(2,j), & 1879 masked_indices(1,i) ) 1880 ENDDO 1881 ENDDO 1882 ENDDO 1883 !$OMP END PARALLEL 1884 ELSE 1885 ALLOCATE( values_int32_3d_resorted(1,1,1) ) 1886 values_int32_3d_resorted = 0_1 1887 ENDIF 1888 values_int32_3d_pointer => values_int32_3d_resorted 1889 ! 1890 !-- working-precision integer output 1891 ELSEIF ( PRESENT( values_intwp_0d ) ) THEN 1892 values_intwp_0d_pointer => values_intwp_0d 1893 ELSEIF ( PRESENT( values_intwp_1d ) ) THEN 1894 IF ( do_output ) THEN 1895 ALLOCATE( values_intwp_1d_resorted(0:value_counts(1)-1) ) 1896 !$OMP PARALLEL PRIVATE (i) 1897 !$OMP DO 1898 DO i = 0, value_counts(1) - 1 1899 values_intwp_1d_resorted(i) = values_intwp_1d(masked_indices(1,i)) 1900 ENDDO 1901 !$OMP END PARALLEL 1902 ELSE 1903 ALLOCATE( values_intwp_1d_resorted(1) ) 1904 values_intwp_1d_resorted = 0_1 1905 ENDIF 1906 values_intwp_1d_pointer => values_intwp_1d_resorted 1907 ELSEIF ( PRESENT( values_intwp_2d ) ) THEN 1908 IF ( do_output ) THEN 1909 ALLOCATE( values_intwp_2d_resorted(0:value_counts(1)-1, & 2078 1910 0:value_counts(2)-1) ) 2079 !$OMP PARALLEL PRIVATE (i,j)2080 !$OMP DO2081 DO i = 0, value_counts(1) - 12082 DO j = 0, value_counts(2) - 12083 values_realwp_2d_resorted(i,j) = values_realwp_2d(masked_indices(2,j), &2084 2085 ENDDO2086 ENDDO2087 !$OMP END PARALLEL2088 ELSE2089 ALLOCATE( values_realwp_2d_resorted(1,1) )2090 values_realwp_2d_resorted = 0_12091 ENDIF2092 values_realwp_2d_pointer => values_realwp_2d_resorted2093 ELSEIF ( PRESENT( values_realwp_3d ) ) THEN2094 IF ( do_output ) THEN2095 ALLOCATE( values_realwp_3d_resorted(0:value_counts(1)-1, &1911 !$OMP PARALLEL PRIVATE (i,j) 1912 !$OMP DO 1913 DO i = 0, value_counts(1) - 1 1914 DO j = 0, value_counts(2) - 1 1915 values_intwp_2d_resorted(i,j) = values_intwp_2d(masked_indices(2,j), & 1916 masked_indices(1,i) ) 1917 ENDDO 1918 ENDDO 1919 !$OMP END PARALLEL 1920 ELSE 1921 ALLOCATE( values_intwp_2d_resorted(1,1) ) 1922 values_intwp_2d_resorted = 0_1 1923 ENDIF 1924 values_intwp_2d_pointer => values_intwp_2d_resorted 1925 ELSEIF ( PRESENT( values_intwp_3d ) ) THEN 1926 IF ( do_output ) THEN 1927 ALLOCATE( values_intwp_3d_resorted(0:value_counts(1)-1, & 2096 1928 0:value_counts(2)-1, & 2097 1929 0:value_counts(3)-1) ) 2098 !$OMP PARALLEL PRIVATE (i,j,k) 2099 !$OMP DO 2100 DO i = 0, value_counts(1) - 1 2101 DO j = 0, value_counts(2) - 1 2102 DO k = 0, value_counts(3) - 1 2103 values_realwp_3d_resorted(i,j,k) = values_realwp_3d(masked_indices(3,k), & 2104 masked_indices(2,j), & 2105 masked_indices(1,i) ) 2106 ENDDO 2107 ENDDO 2108 ENDDO 2109 !$OMP END PARALLEL 2110 ELSE 2111 ALLOCATE( values_realwp_3d_resorted(1,1,1) ) 2112 values_realwp_3d_resorted = 0_1 2113 ENDIF 2114 values_realwp_3d_pointer => values_realwp_3d_resorted 2115 2116 ELSE 2117 return_value = 1 2118 CALL internal_message( 'error', routine_name // & 2119 ': no output values given ' // & 2120 '(variable "' // TRIM( variable_name ) // & 2121 '", file "' // TRIM( file_name ) // '")!' ) 2122 ENDIF 2123 2124 DEALLOCATE( masked_indices ) 2125 2126 ENDIF ! Check for error 2127 2128 IF ( return_value == 0 ) THEN 2129 2130 !-- Write variable into file 2131 SELECT CASE ( TRIM( file_format ) ) 2132 2133 CASE ( 'binary' ) 2134 !-- 8bit integer output 2135 IF ( PRESENT( values_int8_0d ) ) THEN 2136 CALL binary_write_variable( file_id, variable_id, & 2137 bounds_start_internal, value_counts, bounds_origin, is_global, & 2138 values_int8_0d=values_int8_0d_pointer, return_value=output_return_value ) 2139 ELSEIF ( PRESENT( values_int8_1d ) ) THEN 2140 CALL binary_write_variable( file_id, variable_id, & 2141 bounds_start_internal, value_counts, bounds_origin, is_global, & 2142 values_int8_1d=values_int8_1d_pointer, return_value=output_return_value ) 2143 ELSEIF ( PRESENT( values_int8_2d ) ) THEN 2144 CALL binary_write_variable( file_id, variable_id, & 2145 bounds_start_internal, value_counts, bounds_origin, is_global, & 2146 values_int8_2d=values_int8_2d_pointer, return_value=output_return_value ) 2147 ELSEIF ( PRESENT( values_int8_3d ) ) THEN 2148 CALL binary_write_variable( file_id, variable_id, & 2149 bounds_start_internal, value_counts, bounds_origin, is_global, & 2150 values_int8_3d=values_int8_3d_pointer, return_value=output_return_value ) 2151 !-- 16bit integer output 2152 ELSEIF ( PRESENT( values_int16_0d ) ) THEN 2153 CALL binary_write_variable( file_id, variable_id, & 2154 bounds_start_internal, value_counts, bounds_origin, is_global, & 2155 values_int16_0d=values_int16_0d_pointer, return_value=output_return_value ) 2156 ELSEIF ( PRESENT( values_int16_1d ) ) THEN 2157 CALL binary_write_variable( file_id, variable_id, & 2158 bounds_start_internal, value_counts, bounds_origin, is_global, & 2159 values_int16_1d=values_int16_1d_pointer, return_value=output_return_value ) 2160 ELSEIF ( PRESENT( values_int16_2d ) ) THEN 2161 CALL binary_write_variable( file_id, variable_id, & 2162 bounds_start_internal, value_counts, bounds_origin, is_global, & 2163 values_int16_2d=values_int16_2d_pointer, return_value=output_return_value ) 2164 ELSEIF ( PRESENT( values_int16_3d ) ) THEN 2165 CALL binary_write_variable( file_id, variable_id, & 2166 bounds_start_internal, value_counts, bounds_origin, is_global, & 2167 values_int16_3d=values_int16_3d_pointer, return_value=output_return_value ) 2168 !-- 32bit integer output 2169 ELSEIF ( PRESENT( values_int32_0d ) ) THEN 2170 CALL binary_write_variable( file_id, variable_id, & 2171 bounds_start_internal, value_counts, bounds_origin, is_global, & 2172 values_int32_0d=values_int32_0d_pointer, return_value=output_return_value ) 2173 ELSEIF ( PRESENT( values_int32_1d ) ) THEN 2174 CALL binary_write_variable( file_id, variable_id, & 2175 bounds_start_internal, value_counts, bounds_origin, is_global, & 2176 values_int32_1d=values_int32_1d_pointer, return_value=output_return_value ) 2177 ELSEIF ( PRESENT( values_int32_2d ) ) THEN 2178 CALL binary_write_variable( file_id, variable_id, & 2179 bounds_start_internal, value_counts, bounds_origin, is_global, & 2180 values_int32_2d=values_int32_2d_pointer, return_value=output_return_value ) 2181 ELSEIF ( PRESENT( values_int32_3d ) ) THEN 2182 CALL binary_write_variable( file_id, variable_id, & 2183 bounds_start_internal, value_counts, bounds_origin, is_global, & 2184 values_int32_3d=values_int32_3d_pointer, return_value=output_return_value ) 2185 !-- working-precision integer output 2186 ELSEIF ( PRESENT( values_intwp_0d ) ) THEN 2187 CALL binary_write_variable( file_id, variable_id, & 2188 bounds_start_internal, value_counts, bounds_origin, is_global, & 2189 values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value ) 2190 ELSEIF ( PRESENT( values_intwp_1d ) ) THEN 2191 CALL binary_write_variable( file_id, variable_id, & 2192 bounds_start_internal, value_counts, bounds_origin, is_global, & 2193 values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value ) 2194 ELSEIF ( PRESENT( values_intwp_2d ) ) THEN 2195 CALL binary_write_variable( file_id, variable_id, & 2196 bounds_start_internal, value_counts, bounds_origin, is_global, & 2197 values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value ) 2198 ELSEIF ( PRESENT( values_intwp_3d ) ) THEN 2199 CALL binary_write_variable( file_id, variable_id, & 2200 bounds_start_internal, value_counts, bounds_origin, is_global, & 2201 values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value ) 2202 !-- 32bit real output 2203 ELSEIF ( PRESENT( values_real32_0d ) ) THEN 2204 CALL binary_write_variable( file_id, variable_id, & 2205 bounds_start_internal, value_counts, bounds_origin, is_global, & 2206 values_real32_0d=values_real32_0d_pointer, return_value=output_return_value ) 2207 ELSEIF ( PRESENT( values_real32_1d ) ) THEN 2208 CALL binary_write_variable( file_id, variable_id, & 2209 bounds_start_internal, value_counts, bounds_origin, is_global, & 2210 values_real32_1d=values_real32_1d_pointer, return_value=output_return_value ) 2211 ELSEIF ( PRESENT( values_real32_2d ) ) THEN 2212 CALL binary_write_variable( file_id, variable_id, & 2213 bounds_start_internal, value_counts, bounds_origin, is_global, & 2214 values_real32_2d=values_real32_2d_pointer, return_value=output_return_value ) 2215 ELSEIF ( PRESENT( values_real32_3d ) ) THEN 2216 CALL binary_write_variable( file_id, variable_id, & 2217 bounds_start_internal, value_counts, bounds_origin, is_global, & 2218 values_real32_3d=values_real32_3d_pointer, return_value=output_return_value ) 2219 !-- 64bit real output 2220 ELSEIF ( PRESENT( values_real64_0d ) ) THEN 2221 CALL binary_write_variable( file_id, variable_id, & 2222 bounds_start_internal, value_counts, bounds_origin, is_global, & 2223 values_real64_0d=values_real64_0d_pointer, return_value=output_return_value ) 2224 ELSEIF ( PRESENT( values_real64_1d ) ) THEN 2225 CALL binary_write_variable( file_id, variable_id, & 2226 bounds_start_internal, value_counts, bounds_origin, is_global, & 2227 values_real64_1d=values_real64_1d_pointer, return_value=output_return_value ) 2228 ELSEIF ( PRESENT( values_real64_2d ) ) THEN 2229 CALL binary_write_variable( file_id, variable_id, & 2230 bounds_start_internal, value_counts, bounds_origin, is_global, & 2231 values_real64_2d=values_real64_2d_pointer, return_value=output_return_value ) 2232 ELSEIF ( PRESENT( values_real64_3d ) ) THEN 2233 CALL binary_write_variable( file_id, variable_id, & 2234 bounds_start_internal, value_counts, bounds_origin, is_global, & 2235 values_real64_3d=values_real64_3d_pointer, return_value=output_return_value ) 2236 !-- working-precision real output 2237 ELSEIF ( PRESENT( values_realwp_0d ) ) THEN 2238 CALL binary_write_variable( file_id, variable_id, & 2239 bounds_start_internal, value_counts, bounds_origin, is_global, & 2240 values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value ) 2241 ELSEIF ( PRESENT( values_realwp_1d ) ) THEN 2242 CALL binary_write_variable( file_id, variable_id, & 2243 bounds_start_internal, value_counts, bounds_origin, is_global, & 2244 values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value ) 2245 ELSEIF ( PRESENT( values_realwp_2d ) ) THEN 2246 CALL binary_write_variable( file_id, variable_id, & 2247 bounds_start_internal, value_counts, bounds_origin, is_global, & 2248 values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value ) 2249 ELSEIF ( PRESENT( values_realwp_3d ) ) THEN 2250 CALL binary_write_variable( file_id, variable_id, & 2251 bounds_start_internal, value_counts, bounds_origin, is_global, & 2252 values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value ) 2253 ELSE 2254 return_value = 1 2255 CALL internal_message( 'error', routine_name // & 2256 ': output_type not supported by file format "' // & 2257 TRIM( file_format ) // '" ' // & 2258 '(variable "' // TRIM( variable_name ) // & 2259 '", file "' // TRIM( file_name ) // '")!' ) 2260 ENDIF 2261 2262 CASE ( 'netcdf4-parallel', 'netcdf4-serial' ) 2263 !-- 8bit integer output 2264 IF ( PRESENT( values_int8_0d ) ) THEN 2265 CALL netcdf4_write_variable( file_id, variable_id, & 2266 bounds_start_internal, value_counts, bounds_origin, is_global, & 2267 values_int8_0d=values_int8_0d_pointer, return_value=output_return_value ) 2268 ELSEIF ( PRESENT( values_int8_1d ) ) THEN 2269 CALL netcdf4_write_variable( file_id, variable_id, & 2270 bounds_start_internal, value_counts, bounds_origin, is_global, & 2271 values_int8_1d=values_int8_1d_pointer, return_value=output_return_value ) 2272 ELSEIF ( PRESENT( values_int8_2d ) ) THEN 2273 CALL netcdf4_write_variable( file_id, variable_id, & 2274 bounds_start_internal, value_counts, bounds_origin, is_global, & 2275 values_int8_2d=values_int8_2d_pointer, return_value=output_return_value ) 2276 ELSEIF ( PRESENT( values_int8_3d ) ) THEN 2277 CALL netcdf4_write_variable( file_id, variable_id, & 2278 bounds_start_internal, value_counts, bounds_origin, is_global, & 2279 values_int8_3d=values_int8_3d_pointer, return_value=output_return_value ) 2280 !-- 16bit integer output 2281 ELSEIF ( PRESENT( values_int16_0d ) ) THEN 2282 CALL netcdf4_write_variable( file_id, variable_id, & 2283 bounds_start_internal, value_counts, bounds_origin, is_global, & 2284 values_int16_0d=values_int16_0d_pointer, return_value=output_return_value ) 2285 ELSEIF ( PRESENT( values_int16_1d ) ) THEN 2286 CALL netcdf4_write_variable( file_id, variable_id, & 2287 bounds_start_internal, value_counts, bounds_origin, is_global, & 2288 values_int16_1d=values_int16_1d_pointer, return_value=output_return_value ) 2289 ELSEIF ( PRESENT( values_int16_2d ) ) THEN 2290 CALL netcdf4_write_variable( file_id, variable_id, & 2291 bounds_start_internal, value_counts, bounds_origin, is_global, & 2292 values_int16_2d=values_int16_2d_pointer, return_value=output_return_value ) 2293 ELSEIF ( PRESENT( values_int16_3d ) ) THEN 2294 CALL netcdf4_write_variable( file_id, variable_id, & 2295 bounds_start_internal, value_counts, bounds_origin, is_global, & 2296 values_int16_3d=values_int16_3d_pointer, return_value=output_return_value ) 2297 !-- 32bit integer output 2298 ELSEIF ( PRESENT( values_int32_0d ) ) THEN 2299 CALL netcdf4_write_variable( file_id, variable_id, & 2300 bounds_start_internal, value_counts, bounds_origin, is_global, & 2301 values_int32_0d=values_int32_0d_pointer, return_value=output_return_value ) 2302 ELSEIF ( PRESENT( values_int32_1d ) ) THEN 2303 CALL netcdf4_write_variable( file_id, variable_id, & 2304 bounds_start_internal, value_counts, bounds_origin, is_global, & 2305 values_int32_1d=values_int32_1d_pointer, return_value=output_return_value ) 2306 ELSEIF ( PRESENT( values_int32_2d ) ) THEN 2307 CALL netcdf4_write_variable( file_id, variable_id, & 2308 bounds_start_internal, value_counts, bounds_origin, is_global, & 2309 values_int32_2d=values_int32_2d_pointer, return_value=output_return_value ) 2310 ELSEIF ( PRESENT( values_int32_3d ) ) THEN 2311 CALL netcdf4_write_variable( file_id, variable_id, & 2312 bounds_start_internal, value_counts, bounds_origin, is_global, & 2313 values_int32_3d=values_int32_3d_pointer, return_value=output_return_value ) 2314 !-- working-precision integer output 2315 ELSEIF ( PRESENT( values_intwp_0d ) ) THEN 2316 CALL netcdf4_write_variable( file_id, variable_id, & 2317 bounds_start_internal, value_counts, bounds_origin, is_global, & 2318 values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value ) 2319 ELSEIF ( PRESENT( values_intwp_1d ) ) THEN 2320 CALL netcdf4_write_variable( file_id, variable_id, & 2321 bounds_start_internal, value_counts, bounds_origin, is_global, & 2322 values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value ) 2323 ELSEIF ( PRESENT( values_intwp_2d ) ) THEN 2324 CALL netcdf4_write_variable( file_id, variable_id, & 2325 bounds_start_internal, value_counts, bounds_origin, is_global, & 2326 values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value ) 2327 ELSEIF ( PRESENT( values_intwp_3d ) ) THEN 2328 CALL netcdf4_write_variable( file_id, variable_id, & 2329 bounds_start_internal, value_counts, bounds_origin, is_global, & 2330 values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value ) 2331 !-- 32bit real output 2332 ELSEIF ( PRESENT( values_real32_0d ) ) THEN 2333 CALL netcdf4_write_variable( file_id, variable_id, & 2334 bounds_start_internal, value_counts, bounds_origin, is_global, & 2335 values_real32_0d=values_real32_0d_pointer, return_value=output_return_value ) 2336 ELSEIF ( PRESENT( values_real32_1d ) ) THEN 2337 CALL netcdf4_write_variable( file_id, variable_id, & 2338 bounds_start_internal, value_counts, bounds_origin, is_global, & 2339 values_real32_1d=values_real32_1d_pointer, return_value=output_return_value ) 2340 ELSEIF ( PRESENT( values_real32_2d ) ) THEN 2341 CALL netcdf4_write_variable( file_id, variable_id, & 2342 bounds_start_internal, value_counts, bounds_origin, is_global, & 2343 values_real32_2d=values_real32_2d_pointer, return_value=output_return_value ) 2344 ELSEIF ( PRESENT( values_real32_3d ) ) THEN 2345 CALL netcdf4_write_variable( file_id, variable_id, & 2346 bounds_start_internal, value_counts, bounds_origin, is_global, & 2347 values_real32_3d=values_real32_3d_pointer, return_value=output_return_value ) 2348 !-- 64bit real output 2349 ELSEIF ( PRESENT( values_real64_0d ) ) THEN 2350 CALL netcdf4_write_variable( file_id, variable_id, & 2351 bounds_start_internal, value_counts, bounds_origin, is_global, & 2352 values_real64_0d=values_real64_0d_pointer, return_value=output_return_value ) 2353 ELSEIF ( PRESENT( values_real64_1d ) ) THEN 2354 CALL netcdf4_write_variable( file_id, variable_id, & 2355 bounds_start_internal, value_counts, bounds_origin, is_global, & 2356 values_real64_1d=values_real64_1d_pointer, return_value=output_return_value ) 2357 ELSEIF ( PRESENT( values_real64_2d ) ) THEN 2358 CALL netcdf4_write_variable( file_id, variable_id, & 2359 bounds_start_internal, value_counts, bounds_origin, is_global, & 2360 values_real64_2d=values_real64_2d_pointer, return_value=output_return_value ) 2361 ELSEIF ( PRESENT( values_real64_3d ) ) THEN 2362 CALL netcdf4_write_variable( file_id, variable_id, & 2363 bounds_start_internal, value_counts, bounds_origin, is_global, & 2364 values_real64_3d=values_real64_3d_pointer, return_value=output_return_value ) 2365 !-- working-precision real output 2366 ELSEIF ( PRESENT( values_realwp_0d ) ) THEN 2367 CALL netcdf4_write_variable( file_id, variable_id, & 2368 bounds_start_internal, value_counts, bounds_origin, is_global, & 2369 values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value ) 2370 ELSEIF ( PRESENT( values_realwp_1d ) ) THEN 2371 CALL netcdf4_write_variable( file_id, variable_id, & 2372 bounds_start_internal, value_counts, bounds_origin, is_global, & 2373 values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value ) 2374 ELSEIF ( PRESENT( values_realwp_2d ) ) THEN 2375 CALL netcdf4_write_variable( file_id, variable_id, & 2376 bounds_start_internal, value_counts, bounds_origin, is_global, & 2377 values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value ) 2378 ELSEIF ( PRESENT( values_realwp_3d ) ) THEN 2379 CALL netcdf4_write_variable( file_id, variable_id, & 2380 bounds_start_internal, value_counts, bounds_origin, is_global, & 2381 values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value ) 2382 ELSE 2383 return_value = 1 2384 CALL internal_message( 'error', routine_name // & 2385 ': output_type not supported by file format "' // & 2386 TRIM( file_format ) // '" ' // & 2387 '(variable "' // TRIM( variable_name ) // & 2388 '", file "' // TRIM( file_name ) // '")!' ) 2389 ENDIF 2390 2391 CASE DEFAULT 2392 return_value = 1 2393 CALL internal_message( 'error', routine_name // & 2394 ': file format "' // TRIM( file_format ) // & 2395 '" not supported ' // & 2396 '(variable "' // TRIM( variable_name ) // & 2397 '", file "' // TRIM( file_name ) // '")!' ) 2398 2399 END SELECT 2400 2401 IF ( return_value == 0 .AND. output_return_value /= 0 ) THEN 2402 return_value = 1 2403 CALL internal_message( 'error', routine_name // & 2404 ': error while writing variable ' // & 2405 '(variable "' // TRIM( variable_name ) // & 2406 '", file "' // TRIM( file_name ) // '")!' ) 2407 ENDIF 2408 2409 ENDIF 2410 2411 END FUNCTION dom_write_var 1930 !$OMP PARALLEL PRIVATE (i,j,k) 1931 !$OMP DO 1932 DO i = 0, value_counts(1) - 1 1933 DO j = 0, value_counts(2) - 1 1934 DO k = 0, value_counts(3) - 1 1935 values_intwp_3d_resorted(i,j,k) = values_intwp_3d(masked_indices(3,k), & 1936 masked_indices(2,j), & 1937 masked_indices(1,i) ) 1938 ENDDO 1939 ENDDO 1940 ENDDO 1941 !$OMP END PARALLEL 1942 ELSE 1943 ALLOCATE( values_intwp_3d_resorted(1,1,1) ) 1944 values_intwp_3d_resorted = 0_1 1945 ENDIF 1946 values_intwp_3d_pointer => values_intwp_3d_resorted 1947 ! 1948 !-- 32bit real output 1949 ELSEIF ( PRESENT( values_real32_0d ) ) THEN 1950 values_real32_0d_pointer => values_real32_0d 1951 ELSEIF ( PRESENT( values_real32_1d ) ) THEN 1952 IF ( do_output ) THEN 1953 ALLOCATE( values_real32_1d_resorted(0:value_counts(1)-1) ) 1954 !$OMP PARALLEL PRIVATE (i) 1955 !$OMP DO 1956 DO i = 0, value_counts(1) - 1 1957 values_real32_1d_resorted(i) = values_real32_1d(masked_indices(1,i)) 1958 ENDDO 1959 !$OMP END PARALLEL 1960 ELSE 1961 ALLOCATE( values_real32_1d_resorted(1) ) 1962 values_real32_1d_resorted = 0_1 1963 ENDIF 1964 values_real32_1d_pointer => values_real32_1d_resorted 1965 ELSEIF ( PRESENT( values_real32_2d ) ) THEN 1966 IF ( do_output ) THEN 1967 ALLOCATE( values_real32_2d_resorted(0:value_counts(1)-1, & 1968 0:value_counts(2)-1) ) 1969 !$OMP PARALLEL PRIVATE (i,j) 1970 !$OMP DO 1971 DO i = 0, value_counts(1) - 1 1972 DO j = 0, value_counts(2) - 1 1973 values_real32_2d_resorted(i,j) = values_real32_2d(masked_indices(2,j), & 1974 masked_indices(1,i) ) 1975 ENDDO 1976 ENDDO 1977 !$OMP END PARALLEL 1978 ELSE 1979 ALLOCATE( values_real32_2d_resorted(1,1) ) 1980 values_real32_2d_resorted = 0_1 1981 ENDIF 1982 values_real32_2d_pointer => values_real32_2d_resorted 1983 ELSEIF ( PRESENT( values_real32_3d ) ) THEN 1984 IF ( do_output ) THEN 1985 ALLOCATE( values_real32_3d_resorted(0:value_counts(1)-1, & 1986 0:value_counts(2)-1, & 1987 0:value_counts(3)-1) ) 1988 !$OMP PARALLEL PRIVATE (i,j,k) 1989 !$OMP DO 1990 DO i = 0, value_counts(1) - 1 1991 DO j = 0, value_counts(2) - 1 1992 DO k = 0, value_counts(3) - 1 1993 values_real32_3d_resorted(i,j,k) = values_real32_3d(masked_indices(3,k), & 1994 masked_indices(2,j), & 1995 masked_indices(1,i) ) 1996 ENDDO 1997 ENDDO 1998 ENDDO 1999 !$OMP END PARALLEL 2000 ELSE 2001 ALLOCATE( values_real32_3d_resorted(1,1,1) ) 2002 values_real32_3d_resorted = 0_1 2003 ENDIF 2004 values_real32_3d_pointer => values_real32_3d_resorted 2005 ! 2006 !-- 64bit real output 2007 ELSEIF ( PRESENT( values_real64_0d ) ) THEN 2008 values_real64_0d_pointer => values_real64_0d 2009 ELSEIF ( PRESENT( values_real64_1d ) ) THEN 2010 IF ( do_output ) THEN 2011 ALLOCATE( values_real64_1d_resorted(0:value_counts(1)-1) ) 2012 !$OMP PARALLEL PRIVATE (i) 2013 !$OMP DO 2014 DO i = 0, value_counts(1) - 1 2015 values_real64_1d_resorted(i) = values_real64_1d(masked_indices(1,i)) 2016 ENDDO 2017 !$OMP END PARALLEL 2018 ELSE 2019 ALLOCATE( values_real64_1d_resorted(1) ) 2020 values_real64_1d_resorted = 0_1 2021 ENDIF 2022 values_real64_1d_pointer => values_real64_1d_resorted 2023 ELSEIF ( PRESENT( values_real64_2d ) ) THEN 2024 IF ( do_output ) THEN 2025 ALLOCATE( values_real64_2d_resorted(0:value_counts(1)-1, & 2026 0:value_counts(2)-1) ) 2027 !$OMP PARALLEL PRIVATE (i,j) 2028 !$OMP DO 2029 DO i = 0, value_counts(1) - 1 2030 DO j = 0, value_counts(2) - 1 2031 values_real64_2d_resorted(i,j) = values_real64_2d(masked_indices(2,j), & 2032 masked_indices(1,i) ) 2033 ENDDO 2034 ENDDO 2035 !$OMP END PARALLEL 2036 ELSE 2037 ALLOCATE( values_real64_2d_resorted(1,1) ) 2038 values_real64_2d_resorted = 0_1 2039 ENDIF 2040 values_real64_2d_pointer => values_real64_2d_resorted 2041 ELSEIF ( PRESENT( values_real64_3d ) ) THEN 2042 IF ( do_output ) THEN 2043 ALLOCATE( values_real64_3d_resorted(0:value_counts(1)-1, & 2044 0:value_counts(2)-1, & 2045 0:value_counts(3)-1) ) 2046 !$OMP PARALLEL PRIVATE (i,j,k) 2047 !$OMP DO 2048 DO i = 0, value_counts(1) - 1 2049 DO j = 0, value_counts(2) - 1 2050 DO k = 0, value_counts(3) - 1 2051 values_real64_3d_resorted(i,j,k) = values_real64_3d(masked_indices(3,k), & 2052 masked_indices(2,j), & 2053 masked_indices(1,i) ) 2054 ENDDO 2055 ENDDO 2056 ENDDO 2057 !$OMP END PARALLEL 2058 ELSE 2059 ALLOCATE( values_real64_3d_resorted(1,1,1) ) 2060 values_real64_3d_resorted = 0_1 2061 ENDIF 2062 values_real64_3d_pointer => values_real64_3d_resorted 2063 ! 2064 !-- working-precision real output 2065 ELSEIF ( PRESENT( values_realwp_0d ) ) THEN 2066 values_realwp_0d_pointer => values_realwp_0d 2067 ELSEIF ( PRESENT( values_realwp_1d ) ) THEN 2068 IF ( do_output ) THEN 2069 ALLOCATE( values_realwp_1d_resorted(0:value_counts(1)-1) ) 2070 !$OMP PARALLEL PRIVATE (i) 2071 !$OMP DO 2072 DO i = 0, value_counts(1) - 1 2073 values_realwp_1d_resorted(i) = values_realwp_1d(masked_indices(1,i)) 2074 ENDDO 2075 !$OMP END PARALLEL 2076 ELSE 2077 ALLOCATE( values_realwp_1d_resorted(1) ) 2078 values_realwp_1d_resorted = 0_1 2079 ENDIF 2080 values_realwp_1d_pointer => values_realwp_1d_resorted 2081 ELSEIF ( PRESENT( values_realwp_2d ) ) THEN 2082 IF ( do_output ) THEN 2083 ALLOCATE( values_realwp_2d_resorted(0:value_counts(1)-1, & 2084 0:value_counts(2)-1) ) 2085 !$OMP PARALLEL PRIVATE (i,j) 2086 !$OMP DO 2087 DO i = 0, value_counts(1) - 1 2088 DO j = 0, value_counts(2) - 1 2089 values_realwp_2d_resorted(i,j) = values_realwp_2d(masked_indices(2,j), & 2090 masked_indices(1,i) ) 2091 ENDDO 2092 ENDDO 2093 !$OMP END PARALLEL 2094 ELSE 2095 ALLOCATE( values_realwp_2d_resorted(1,1) ) 2096 values_realwp_2d_resorted = 0_1 2097 ENDIF 2098 values_realwp_2d_pointer => values_realwp_2d_resorted 2099 ELSEIF ( PRESENT( values_realwp_3d ) ) THEN 2100 IF ( do_output ) THEN 2101 ALLOCATE( values_realwp_3d_resorted(0:value_counts(1)-1, & 2102 0:value_counts(2)-1, & 2103 0:value_counts(3)-1) ) 2104 !$OMP PARALLEL PRIVATE (i,j,k) 2105 !$OMP DO 2106 DO i = 0, value_counts(1) - 1 2107 DO j = 0, value_counts(2) - 1 2108 DO k = 0, value_counts(3) - 1 2109 values_realwp_3d_resorted(i,j,k) = values_realwp_3d(masked_indices(3,k), & 2110 masked_indices(2,j), & 2111 masked_indices(1,i) ) 2112 ENDDO 2113 ENDDO 2114 ENDDO 2115 !$OMP END PARALLEL 2116 ELSE 2117 ALLOCATE( values_realwp_3d_resorted(1,1,1) ) 2118 values_realwp_3d_resorted = 0_1 2119 ENDIF 2120 values_realwp_3d_pointer => values_realwp_3d_resorted 2121 2122 ELSE 2123 return_value = 1 2124 CALL internal_message( 'error', routine_name // & 2125 ': no output values given ' // & 2126 '(variable "' // TRIM( variable_name ) // & 2127 '", file "' // TRIM( file_name ) // '")!' ) 2128 ENDIF 2129 2130 DEALLOCATE( masked_indices ) 2131 2132 ENDIF ! Check for error 2133 2134 IF ( return_value == 0 ) THEN 2135 ! 2136 !-- Write variable into file 2137 SELECT CASE ( TRIM( file_format ) ) 2138 2139 CASE ( 'binary' ) 2140 ! 2141 !-- 8bit integer output 2142 IF ( PRESENT( values_int8_0d ) ) THEN 2143 CALL binary_write_variable( file_id, variable_id, & 2144 bounds_start_internal, value_counts, bounds_origin, is_global, & 2145 values_int8_0d=values_int8_0d_pointer, return_value=output_return_value ) 2146 ELSEIF ( PRESENT( values_int8_1d ) ) THEN 2147 CALL binary_write_variable( file_id, variable_id, & 2148 bounds_start_internal, value_counts, bounds_origin, is_global, & 2149 values_int8_1d=values_int8_1d_pointer, return_value=output_return_value ) 2150 ELSEIF ( PRESENT( values_int8_2d ) ) THEN 2151 CALL binary_write_variable( file_id, variable_id, & 2152 bounds_start_internal, value_counts, bounds_origin, is_global, & 2153 values_int8_2d=values_int8_2d_pointer, return_value=output_return_value ) 2154 ELSEIF ( PRESENT( values_int8_3d ) ) THEN 2155 CALL binary_write_variable( file_id, variable_id, & 2156 bounds_start_internal, value_counts, bounds_origin, is_global, & 2157 values_int8_3d=values_int8_3d_pointer, return_value=output_return_value ) 2158 ! 2159 !-- 16bit integer output 2160 ELSEIF ( PRESENT( values_int16_0d ) ) THEN 2161 CALL binary_write_variable( file_id, variable_id, & 2162 bounds_start_internal, value_counts, bounds_origin, is_global, & 2163 values_int16_0d=values_int16_0d_pointer, return_value=output_return_value ) 2164 ELSEIF ( PRESENT( values_int16_1d ) ) THEN 2165 CALL binary_write_variable( file_id, variable_id, & 2166 bounds_start_internal, value_counts, bounds_origin, is_global, & 2167 values_int16_1d=values_int16_1d_pointer, return_value=output_return_value ) 2168 ELSEIF ( PRESENT( values_int16_2d ) ) THEN 2169 CALL binary_write_variable( file_id, variable_id, & 2170 bounds_start_internal, value_counts, bounds_origin, is_global, & 2171 values_int16_2d=values_int16_2d_pointer, return_value=output_return_value ) 2172 ELSEIF ( PRESENT( values_int16_3d ) ) THEN 2173 CALL binary_write_variable( file_id, variable_id, & 2174 bounds_start_internal, value_counts, bounds_origin, is_global, & 2175 values_int16_3d=values_int16_3d_pointer, return_value=output_return_value ) 2176 ! 2177 !-- 32bit integer output 2178 ELSEIF ( PRESENT( values_int32_0d ) ) THEN 2179 CALL binary_write_variable( file_id, variable_id, & 2180 bounds_start_internal, value_counts, bounds_origin, is_global, & 2181 values_int32_0d=values_int32_0d_pointer, return_value=output_return_value ) 2182 ELSEIF ( PRESENT( values_int32_1d ) ) THEN 2183 CALL binary_write_variable( file_id, variable_id, & 2184 bounds_start_internal, value_counts, bounds_origin, is_global, & 2185 values_int32_1d=values_int32_1d_pointer, return_value=output_return_value ) 2186 ELSEIF ( PRESENT( values_int32_2d ) ) THEN 2187 CALL binary_write_variable( file_id, variable_id, & 2188 bounds_start_internal, value_counts, bounds_origin, is_global, & 2189 values_int32_2d=values_int32_2d_pointer, return_value=output_return_value ) 2190 ELSEIF ( PRESENT( values_int32_3d ) ) THEN 2191 CALL binary_write_variable( file_id, variable_id, & 2192 bounds_start_internal, value_counts, bounds_origin, is_global, & 2193 values_int32_3d=values_int32_3d_pointer, return_value=output_return_value ) 2194 ! 2195 !-- working-precision integer output 2196 ELSEIF ( PRESENT( values_intwp_0d ) ) THEN 2197 CALL binary_write_variable( file_id, variable_id, & 2198 bounds_start_internal, value_counts, bounds_origin, is_global, & 2199 values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value ) 2200 ELSEIF ( PRESENT( values_intwp_1d ) ) THEN 2201 CALL binary_write_variable( file_id, variable_id, & 2202 bounds_start_internal, value_counts, bounds_origin, is_global, & 2203 values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value ) 2204 ELSEIF ( PRESENT( values_intwp_2d ) ) THEN 2205 CALL binary_write_variable( file_id, variable_id, & 2206 bounds_start_internal, value_counts, bounds_origin, is_global, & 2207 values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value ) 2208 ELSEIF ( PRESENT( values_intwp_3d ) ) THEN 2209 CALL binary_write_variable( file_id, variable_id, & 2210 bounds_start_internal, value_counts, bounds_origin, is_global, & 2211 values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value ) 2212 ! 2213 !-- 32bit real output 2214 ELSEIF ( PRESENT( values_real32_0d ) ) THEN 2215 CALL binary_write_variable( file_id, variable_id, & 2216 bounds_start_internal, value_counts, bounds_origin, is_global, & 2217 values_real32_0d=values_real32_0d_pointer, return_value=output_return_value ) 2218 ELSEIF ( PRESENT( values_real32_1d ) ) THEN 2219 CALL binary_write_variable( file_id, variable_id, & 2220 bounds_start_internal, value_counts, bounds_origin, is_global, & 2221 values_real32_1d=values_real32_1d_pointer, return_value=output_return_value ) 2222 ELSEIF ( PRESENT( values_real32_2d ) ) THEN 2223 CALL binary_write_variable( file_id, variable_id, & 2224 bounds_start_internal, value_counts, bounds_origin, is_global, & 2225 values_real32_2d=values_real32_2d_pointer, return_value=output_return_value ) 2226 ELSEIF ( PRESENT( values_real32_3d ) ) THEN 2227 CALL binary_write_variable( file_id, variable_id, & 2228 bounds_start_internal, value_counts, bounds_origin, is_global, & 2229 values_real32_3d=values_real32_3d_pointer, return_value=output_return_value ) 2230 ! 2231 !-- 64bit real output 2232 ELSEIF ( PRESENT( values_real64_0d ) ) THEN 2233 CALL binary_write_variable( file_id, variable_id, & 2234 bounds_start_internal, value_counts, bounds_origin, is_global, & 2235 values_real64_0d=values_real64_0d_pointer, return_value=output_return_value ) 2236 ELSEIF ( PRESENT( values_real64_1d ) ) THEN 2237 CALL binary_write_variable( file_id, variable_id, & 2238 bounds_start_internal, value_counts, bounds_origin, is_global, & 2239 values_real64_1d=values_real64_1d_pointer, return_value=output_return_value ) 2240 ELSEIF ( PRESENT( values_real64_2d ) ) THEN 2241 CALL binary_write_variable( file_id, variable_id, & 2242 bounds_start_internal, value_counts, bounds_origin, is_global, & 2243 values_real64_2d=values_real64_2d_pointer, return_value=output_return_value ) 2244 ELSEIF ( PRESENT( values_real64_3d ) ) THEN 2245 CALL binary_write_variable( file_id, variable_id, & 2246 bounds_start_internal, value_counts, bounds_origin, is_global, & 2247 values_real64_3d=values_real64_3d_pointer, return_value=output_return_value ) 2248 ! 2249 !-- working-precision real output 2250 ELSEIF ( PRESENT( values_realwp_0d ) ) THEN 2251 CALL binary_write_variable( file_id, variable_id, & 2252 bounds_start_internal, value_counts, bounds_origin, is_global, & 2253 values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value ) 2254 ELSEIF ( PRESENT( values_realwp_1d ) ) THEN 2255 CALL binary_write_variable( file_id, variable_id, & 2256 bounds_start_internal, value_counts, bounds_origin, is_global, & 2257 values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value ) 2258 ELSEIF ( PRESENT( values_realwp_2d ) ) THEN 2259 CALL binary_write_variable( file_id, variable_id, & 2260 bounds_start_internal, value_counts, bounds_origin, is_global, & 2261 values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value ) 2262 ELSEIF ( PRESENT( values_realwp_3d ) ) THEN 2263 CALL binary_write_variable( file_id, variable_id, & 2264 bounds_start_internal, value_counts, bounds_origin, is_global, & 2265 values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value ) 2266 ELSE 2267 return_value = 1 2268 CALL internal_message( 'error', routine_name // & 2269 ': output_type not supported by file format "' // & 2270 TRIM( file_format ) // '" ' // & 2271 '(variable "' // TRIM( variable_name ) // & 2272 '", file "' // TRIM( file_name ) // '")!' ) 2273 ENDIF 2274 2275 CASE ( 'netcdf4-parallel', 'netcdf4-serial' ) 2276 ! 2277 !-- 8bit integer output 2278 IF ( PRESENT( values_int8_0d ) ) THEN 2279 CALL netcdf4_write_variable( file_id, variable_id, & 2280 bounds_start_internal, value_counts, bounds_origin, is_global, & 2281 values_int8_0d=values_int8_0d_pointer, return_value=output_return_value ) 2282 ELSEIF ( PRESENT( values_int8_1d ) ) THEN 2283 CALL netcdf4_write_variable( file_id, variable_id, & 2284 bounds_start_internal, value_counts, bounds_origin, is_global, & 2285 values_int8_1d=values_int8_1d_pointer, return_value=output_return_value ) 2286 ELSEIF ( PRESENT( values_int8_2d ) ) THEN 2287 CALL netcdf4_write_variable( file_id, variable_id, & 2288 bounds_start_internal, value_counts, bounds_origin, is_global, & 2289 values_int8_2d=values_int8_2d_pointer, return_value=output_return_value ) 2290 ELSEIF ( PRESENT( values_int8_3d ) ) THEN 2291 CALL netcdf4_write_variable( file_id, variable_id, & 2292 bounds_start_internal, value_counts, bounds_origin, is_global, & 2293 values_int8_3d=values_int8_3d_pointer, return_value=output_return_value ) 2294 ! 2295 !-- 16bit integer output 2296 ELSEIF ( PRESENT( values_int16_0d ) ) THEN 2297 CALL netcdf4_write_variable( file_id, variable_id, & 2298 bounds_start_internal, value_counts, bounds_origin, is_global, & 2299 values_int16_0d=values_int16_0d_pointer, return_value=output_return_value ) 2300 ELSEIF ( PRESENT( values_int16_1d ) ) THEN 2301 CALL netcdf4_write_variable( file_id, variable_id, & 2302 bounds_start_internal, value_counts, bounds_origin, is_global, & 2303 values_int16_1d=values_int16_1d_pointer, return_value=output_return_value ) 2304 ELSEIF ( PRESENT( values_int16_2d ) ) THEN 2305 CALL netcdf4_write_variable( file_id, variable_id, & 2306 bounds_start_internal, value_counts, bounds_origin, is_global, & 2307 values_int16_2d=values_int16_2d_pointer, return_value=output_return_value ) 2308 ELSEIF ( PRESENT( values_int16_3d ) ) THEN 2309 CALL netcdf4_write_variable( file_id, variable_id, & 2310 bounds_start_internal, value_counts, bounds_origin, is_global, & 2311 values_int16_3d=values_int16_3d_pointer, return_value=output_return_value ) 2312 ! 2313 !-- 32bit integer output 2314 ELSEIF ( PRESENT( values_int32_0d ) ) THEN 2315 CALL netcdf4_write_variable( file_id, variable_id, & 2316 bounds_start_internal, value_counts, bounds_origin, is_global, & 2317 values_int32_0d=values_int32_0d_pointer, return_value=output_return_value ) 2318 ELSEIF ( PRESENT( values_int32_1d ) ) THEN 2319 CALL netcdf4_write_variable( file_id, variable_id, & 2320 bounds_start_internal, value_counts, bounds_origin, is_global, & 2321 values_int32_1d=values_int32_1d_pointer, return_value=output_return_value ) 2322 ELSEIF ( PRESENT( values_int32_2d ) ) THEN 2323 CALL netcdf4_write_variable( file_id, variable_id, & 2324 bounds_start_internal, value_counts, bounds_origin, is_global, & 2325 values_int32_2d=values_int32_2d_pointer, return_value=output_return_value ) 2326 ELSEIF ( PRESENT( values_int32_3d ) ) THEN 2327 CALL netcdf4_write_variable( file_id, variable_id, & 2328 bounds_start_internal, value_counts, bounds_origin, is_global, & 2329 values_int32_3d=values_int32_3d_pointer, return_value=output_return_value ) 2330 ! 2331 !-- working-precision integer output 2332 ELSEIF ( PRESENT( values_intwp_0d ) ) THEN 2333 CALL netcdf4_write_variable( file_id, variable_id, & 2334 bounds_start_internal, value_counts, bounds_origin, is_global, & 2335 values_intwp_0d=values_intwp_0d_pointer, return_value=output_return_value ) 2336 ELSEIF ( PRESENT( values_intwp_1d ) ) THEN 2337 CALL netcdf4_write_variable( file_id, variable_id, & 2338 bounds_start_internal, value_counts, bounds_origin, is_global, & 2339 values_intwp_1d=values_intwp_1d_pointer, return_value=output_return_value ) 2340 ELSEIF ( PRESENT( values_intwp_2d ) ) THEN 2341 CALL netcdf4_write_variable( file_id, variable_id, & 2342 bounds_start_internal, value_counts, bounds_origin, is_global, & 2343 values_intwp_2d=values_intwp_2d_pointer, return_value=output_return_value ) 2344 ELSEIF ( PRESENT( values_intwp_3d ) ) THEN 2345 CALL netcdf4_write_variable( file_id, variable_id, & 2346 bounds_start_internal, value_counts, bounds_origin, is_global, & 2347 values_intwp_3d=values_intwp_3d_pointer, return_value=output_return_value ) 2348 ! 2349 !-- 32bit real output 2350 ELSEIF ( PRESENT( values_real32_0d ) ) THEN 2351 CALL netcdf4_write_variable( file_id, variable_id, & 2352 bounds_start_internal, value_counts, bounds_origin, is_global, & 2353 values_real32_0d=values_real32_0d_pointer, return_value=output_return_value ) 2354 ELSEIF ( PRESENT( values_real32_1d ) ) THEN 2355 CALL netcdf4_write_variable( file_id, variable_id, & 2356 bounds_start_internal, value_counts, bounds_origin, is_global, & 2357 values_real32_1d=values_real32_1d_pointer, return_value=output_return_value ) 2358 ELSEIF ( PRESENT( values_real32_2d ) ) THEN 2359 CALL netcdf4_write_variable( file_id, variable_id, & 2360 bounds_start_internal, value_counts, bounds_origin, is_global, & 2361 values_real32_2d=values_real32_2d_pointer, return_value=output_return_value ) 2362 ELSEIF ( PRESENT( values_real32_3d ) ) THEN 2363 CALL netcdf4_write_variable( file_id, variable_id, & 2364 bounds_start_internal, value_counts, bounds_origin, is_global, & 2365 values_real32_3d=values_real32_3d_pointer, return_value=output_return_value ) 2366 ! 2367 !-- 64bit real output 2368 ELSEIF ( PRESENT( values_real64_0d ) ) THEN 2369 CALL netcdf4_write_variable( file_id, variable_id, & 2370 bounds_start_internal, value_counts, bounds_origin, is_global, & 2371 values_real64_0d=values_real64_0d_pointer, return_value=output_return_value ) 2372 ELSEIF ( PRESENT( values_real64_1d ) ) THEN 2373 CALL netcdf4_write_variable( file_id, variable_id, & 2374 bounds_start_internal, value_counts, bounds_origin, is_global, & 2375 values_real64_1d=values_real64_1d_pointer, return_value=output_return_value ) 2376 ELSEIF ( PRESENT( values_real64_2d ) ) THEN 2377 CALL netcdf4_write_variable( file_id, variable_id, & 2378 bounds_start_internal, value_counts, bounds_origin, is_global, & 2379 values_real64_2d=values_real64_2d_pointer, return_value=output_return_value ) 2380 ELSEIF ( PRESENT( values_real64_3d ) ) THEN 2381 CALL netcdf4_write_variable( file_id, variable_id, & 2382 bounds_start_internal, value_counts, bounds_origin, is_global, & 2383 values_real64_3d=values_real64_3d_pointer, return_value=output_return_value ) 2384 ! 2385 !-- working-precision real output 2386 ELSEIF ( PRESENT( values_realwp_0d ) ) THEN 2387 CALL netcdf4_write_variable( file_id, variable_id, & 2388 bounds_start_internal, value_counts, bounds_origin, is_global, & 2389 values_realwp_0d=values_realwp_0d_pointer, return_value=output_return_value ) 2390 ELSEIF ( PRESENT( values_realwp_1d ) ) THEN 2391 CALL netcdf4_write_variable( file_id, variable_id, & 2392 bounds_start_internal, value_counts, bounds_origin, is_global, & 2393 values_realwp_1d=values_realwp_1d_pointer, return_value=output_return_value ) 2394 ELSEIF ( PRESENT( values_realwp_2d ) ) THEN 2395 CALL netcdf4_write_variable( file_id, variable_id, & 2396 bounds_start_internal, value_counts, bounds_origin, is_global, & 2397 values_realwp_2d=values_realwp_2d_pointer, return_value=output_return_value ) 2398 ELSEIF ( PRESENT( values_realwp_3d ) ) THEN 2399 CALL netcdf4_write_variable( file_id, variable_id, & 2400 bounds_start_internal, value_counts, bounds_origin, is_global, & 2401 values_realwp_3d=values_realwp_3d_pointer, return_value=output_return_value ) 2402 ELSE 2403 return_value = 1 2404 CALL internal_message( 'error', routine_name // & 2405 ': output_type not supported by file format "' // & 2406 TRIM( file_format ) // '" ' // & 2407 '(variable "' // TRIM( variable_name ) // & 2408 '", file "' // TRIM( file_name ) // '")!' ) 2409 ENDIF 2410 2411 CASE DEFAULT 2412 return_value = 1 2413 CALL internal_message( 'error', routine_name // & 2414 ': file format "' // TRIM( file_format ) // & 2415 '" not supported ' // & 2416 '(variable "' // TRIM( variable_name ) // & 2417 '", file "' // TRIM( file_name ) // '")!' ) 2418 2419 END SELECT 2420 2421 IF ( return_value == 0 .AND. output_return_value /= 0 ) THEN 2422 return_value = 1 2423 CALL internal_message( 'error', routine_name // & 2424 ': error while writing variable ' // & 2425 '(variable "' // TRIM( variable_name ) // & 2426 '", file "' // TRIM( file_name ) // '")!' ) 2427 ENDIF 2428 2429 ENDIF 2430 2431 END FUNCTION dom_write_var 2412 2432 2413 2433 !--------------------------------------------------------------------------------------------------! … … 2420 2440 !> @bug if multiple files failed to be closed, only the last failure is given in the error message. 2421 2441 !--------------------------------------------------------------------------------------------------! 2422 FUNCTION dom_finalize_output() RESULT( return_value )2423 2424 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_finalize_output' !< name of routine2425 2426 INTEGER :: f !< loop index2427 INTEGER :: output_return_value !< return value from called routines2428 INTEGER :: return_value !< return value2429 INTEGER :: return_value_internal !< error code after closing a single file2430 2431 2432 return_value = 02433 2434 DO f = 1, nfiles2435 2436 IF ( files(f)%is_init ) THEN2437 2438 output_return_value = 02439 return_value_internal = 02440 2441 SELECT CASE ( TRIM( files(f)%format ) )2442 2443 CASE ( 'binary' )2444 CALL binary_finalize( files(f)%id, output_return_value )2445 2446 CASE ( 'netcdf4-parallel', 'netcdf4-serial' )2447 CALL netcdf4_finalize( files(f)%id, output_return_value )2448 2449 CASE DEFAULT2450 return_value_internal = 12451 2452 END SELECT2453 2454 IF ( output_return_value /= 0 ) THEN2455 return_value = output_return_value2456 CALL internal_message( 'error', routine_name // &2457 ': error while finalizing file "' // &2458 TRIM( files(f)%name ) // '"' )2459 ELSEIF ( return_value_internal /= 0 ) THEN2460 return_value = return_value_internal2461 CALL internal_message( 'error', routine_name // &2462 ': unsupported file format "' // &2463 TRIM( files(f)%format ) // '" for file "' // &2464 TRIM( files(f)%name ) // '"' )2465 ENDIF2466 2467 ENDIF2468 2469 ENDDO2470 2471 END FUNCTION dom_finalize_output2442 FUNCTION dom_finalize_output() RESULT( return_value ) 2443 2444 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_finalize_output' !< name of routine 2445 2446 INTEGER :: f !< loop index 2447 INTEGER :: output_return_value !< return value from called routines 2448 INTEGER :: return_value !< return value 2449 INTEGER :: return_value_internal !< error code after closing a single file 2450 2451 2452 return_value = 0 2453 2454 DO f = 1, nfiles 2455 2456 IF ( files(f)%is_init ) THEN 2457 2458 output_return_value = 0 2459 return_value_internal = 0 2460 2461 SELECT CASE ( TRIM( files(f)%format ) ) 2462 2463 CASE ( 'binary' ) 2464 CALL binary_finalize( files(f)%id, output_return_value ) 2465 2466 CASE ( 'netcdf4-parallel', 'netcdf4-serial' ) 2467 CALL netcdf4_finalize( files(f)%id, output_return_value ) 2468 2469 CASE DEFAULT 2470 return_value_internal = 1 2471 2472 END SELECT 2473 2474 IF ( output_return_value /= 0 ) THEN 2475 return_value = output_return_value 2476 CALL internal_message( 'error', routine_name // & 2477 ': error while finalizing file "' // & 2478 TRIM( files(f)%name ) // '"' ) 2479 ELSEIF ( return_value_internal /= 0 ) THEN 2480 return_value = return_value_internal 2481 CALL internal_message( 'error', routine_name // & 2482 ': unsupported file format "' // & 2483 TRIM( files(f)%format ) // '" for file "' // & 2484 TRIM( files(f)%name ) // '"' ) 2485 ENDIF 2486 2487 ENDIF 2488 2489 ENDDO 2490 2491 END FUNCTION dom_finalize_output 2472 2492 2473 2493 !--------------------------------------------------------------------------------------------------! … … 2476 2496 !> Return the last created error message. 2477 2497 !--------------------------------------------------------------------------------------------------! 2478 FUNCTION dom_get_error_message() RESULT( error_message )2479 2480 CHARACTER(LEN=800) :: error_message !< return error message to main program2481 2482 2483 error_message = TRIM( internal_error_message )2484 2485 error_message = TRIM( error_message ) // TRIM( binary_get_error_message() )2486 2487 error_message = TRIM( error_message ) // TRIM( netcdf4_get_error_message() )2488 2489 internal_error_message = ''2490 2491 END FUNCTION dom_get_error_message2498 FUNCTION dom_get_error_message() RESULT( error_message ) 2499 2500 CHARACTER(LEN=800) :: error_message !< return error message to main program 2501 2502 2503 error_message = TRIM( internal_error_message ) 2504 2505 error_message = TRIM( error_message ) // TRIM( binary_get_error_message() ) 2506 2507 error_message = TRIM( error_message ) // TRIM( netcdf4_get_error_message() ) 2508 2509 internal_error_message = '' 2510 2511 END FUNCTION dom_get_error_message 2492 2512 2493 2513 !--------------------------------------------------------------------------------------------------! … … 2498 2518 !> @todo Try to combine similar code parts and shorten routine. 2499 2519 !--------------------------------------------------------------------------------------------------! 2500 FUNCTION save_attribute_in_database( file_name, variable_name, attribute, append ) & 2501 RESULT( return_value ) 2502 2503 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 2504 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 2505 2506 CHARACTER(LEN=*), PARAMETER :: routine_name = 'save_attribute_in_database' !< name of routine 2507 2508 INTEGER :: a !< loop index 2509 INTEGER :: d !< loop index 2510 INTEGER :: f !< loop index 2511 INTEGER :: natts !< number of attributes 2512 INTEGER :: return_value !< return value 2513 2514 LOGICAL :: found !< true if variable or dimension of name 'variable_name' found 2515 LOGICAL, INTENT(IN) :: append !< if true, append value to existing value 2516 2517 TYPE(attribute_type), INTENT(IN) :: attribute !< new attribute 2518 2519 TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: atts_tmp !< temporary attribute list 2520 2521 2522 return_value = 0 2523 found = .FALSE. 2524 2525 CALL internal_message( 'debug', routine_name // & 2526 ': define attribute "' // TRIM( attribute%name ) // & 2527 '" of variable "' // TRIM( variable_name ) // & 2528 '" in file "' // TRIM( file_name ) // '"' ) 2529 2530 DO f = 1, nfiles 2531 2532 IF ( TRIM( file_name ) == files(f)%name ) THEN 2533 2534 IF ( files(f)%is_init ) THEN 2535 return_value = 1 2536 CALL internal_message( 'error', routine_name // ': file "' // TRIM( file_name ) // & 2537 '" is already initialized. No further attribute definition allowed!' ) 2538 EXIT 2539 ENDIF 2540 2541 !-- Add attribute to file 2542 IF ( TRIM( variable_name ) == '' ) THEN 2543 2544 !-- Initialize first file attribute 2545 IF ( .NOT. ALLOCATED( files(f)%attributes ) ) THEN 2546 natts = 1 2547 ALLOCATE( files(f)%attributes(natts) ) 2548 ELSE 2549 natts = SIZE( files(f)%attributes ) 2550 2551 !-- Check if attribute already exists 2552 DO a = 1, natts 2553 IF ( files(f)%attributes(a)%name == attribute%name ) THEN 2554 IF ( append ) THEN 2555 !-- Append existing string attribute 2556 files(f)%attributes(a)%value_char = & 2557 TRIM( files(f)%attributes(a)%value_char ) // & 2558 TRIM( attribute%value_char ) 2559 ELSE 2560 files(f)%attributes(a) = attribute 2561 ENDIF 2562 found = .TRUE. 2563 EXIT 2564 ENDIF 2565 ENDDO 2566 2567 !-- Extend attribute list by 1 2568 IF ( .NOT. found ) THEN 2569 ALLOCATE( atts_tmp(natts) ) 2570 atts_tmp = files(f)%attributes 2571 DEALLOCATE( files(f)%attributes ) 2572 natts = natts + 1 2573 ALLOCATE( files(f)%attributes(natts) ) 2574 files(f)%attributes(:natts-1) = atts_tmp 2575 DEALLOCATE( atts_tmp ) 2576 ENDIF 2577 ENDIF 2578 2579 !-- Save new attribute to the end of the attribute list 2580 IF ( .NOT. found ) THEN 2581 files(f)%attributes(natts) = attribute 2582 found = .TRUE. 2583 ENDIF 2584 2585 EXIT 2586 2587 ELSE 2588 2589 !-- Add attribute to dimension 2590 IF ( ALLOCATED( files(f)%dimensions ) ) THEN 2591 2592 DO d = 1, SIZE( files(f)%dimensions ) 2593 2594 IF ( files(f)%dimensions(d)%name == TRIM( variable_name ) ) THEN 2595 2596 IF ( .NOT. ALLOCATED( files(f)%dimensions(d)%attributes ) ) THEN 2597 !-- Initialize first attribute 2598 natts = 1 2599 ALLOCATE( files(f)%dimensions(d)%attributes(natts) ) 2600 ELSE 2601 natts = SIZE( files(f)%dimensions(d)%attributes ) 2602 2603 !-- Check if attribute already exists 2604 DO a = 1, natts 2605 IF ( files(f)%dimensions(d)%attributes(a)%name == attribute%name ) & 2606 THEN 2607 IF ( append ) THEN 2608 !-- Append existing character attribute 2609 files(f)%dimensions(d)%attributes(a)%value_char = & 2610 TRIM( files(f)%dimensions(d)%attributes(a)%value_char ) // & 2611 TRIM( attribute%value_char ) 2612 ELSE 2613 !-- Update existing attribute 2614 files(f)%dimensions(d)%attributes(a) = attribute 2615 ENDIF 2616 found = .TRUE. 2617 EXIT 2618 ENDIF 2619 ENDDO 2620 2621 !-- Extend attribute list 2622 IF ( .NOT. found ) THEN 2623 ALLOCATE( atts_tmp(natts) ) 2624 atts_tmp = files(f)%dimensions(d)%attributes 2625 DEALLOCATE( files(f)%dimensions(d)%attributes ) 2626 natts = natts + 1 2627 ALLOCATE( files(f)%dimensions(d)%attributes(natts) ) 2628 files(f)%dimensions(d)%attributes(:natts-1) = atts_tmp 2629 DEALLOCATE( atts_tmp ) 2630 ENDIF 2631 ENDIF 2632 2633 !-- Add new attribute to database 2634 IF ( .NOT. found ) THEN 2635 files(f)%dimensions(d)%attributes(natts) = attribute 2636 found = .TRUE. 2637 ENDIF 2638 2639 EXIT 2640 2641 ENDIF ! dimension found 2642 2643 ENDDO ! loop over dimensions 2644 2645 ENDIF ! dimensions exist in file 2646 2647 !-- Add attribute to variable 2648 IF ( .NOT. found .AND. ALLOCATED( files(f)%variables) ) THEN 2649 2650 DO d = 1, SIZE( files(f)%variables ) 2651 2652 IF ( files(f)%variables(d)%name == TRIM( variable_name ) ) THEN 2653 2654 IF ( .NOT. ALLOCATED( files(f)%variables(d)%attributes ) ) THEN 2655 !-- Initialize first attribute 2656 natts = 1 2657 ALLOCATE( files(f)%variables(d)%attributes(natts) ) 2658 ELSE 2659 natts = SIZE( files(f)%variables(d)%attributes ) 2660 2661 !-- Check if attribute already exists 2662 DO a = 1, natts 2663 IF ( files(f)%variables(d)%attributes(a)%name == attribute%name ) & 2664 THEN 2665 IF ( append ) THEN 2666 !-- Append existing character attribute 2667 files(f)%variables(d)%attributes(a)%value_char = & 2668 TRIM( files(f)%variables(d)%attributes(a)%value_char ) // & 2669 TRIM( attribute%value_char ) 2670 ELSE 2671 !-- Update existing attribute 2672 files(f)%variables(d)%attributes(a) = attribute 2673 ENDIF 2674 found = .TRUE. 2675 EXIT 2676 ENDIF 2677 ENDDO 2678 2679 !-- Extend attribute list 2680 IF ( .NOT. found ) THEN 2681 ALLOCATE( atts_tmp(natts) ) 2682 atts_tmp = files(f)%variables(d)%attributes 2683 DEALLOCATE( files(f)%variables(d)%attributes ) 2684 natts = natts + 1 2685 ALLOCATE( files(f)%variables(d)%attributes(natts) ) 2686 files(f)%variables(d)%attributes(:natts-1) = atts_tmp 2687 DEALLOCATE( atts_tmp ) 2688 ENDIF 2689 2690 ENDIF 2691 2692 !-- Add new attribute to database 2693 IF ( .NOT. found ) THEN 2694 files(f)%variables(d)%attributes(natts) = attribute 2695 found = .TRUE. 2696 ENDIF 2697 2698 EXIT 2699 2700 ENDIF ! variable found 2701 2702 ENDDO ! loop over variables 2703 2704 ENDIF ! variables exist in file 2705 2706 IF ( .NOT. found ) THEN 2707 return_value = 1 2708 CALL internal_message( 'error', & 2709 routine_name // & 2710 ': requested dimension/variable "' // TRIM( variable_name ) // & 2711 '" for attribute "' // TRIM( attribute%name ) // & 2712 '" does not exist in file "' // TRIM( file_name ) // '"' ) 2713 ENDIF 2714 2715 EXIT 2716 2717 ENDIF ! variable_name not empty 2718 2719 ENDIF ! check file_name 2720 2721 ENDDO ! loop over files 2722 2723 IF ( .NOT. found .AND. return_value == 0 ) THEN 2724 return_value = 1 2725 CALL internal_message( 'error', & 2726 routine_name // & 2727 ': requested file "' // TRIM( file_name ) // & 2728 '" for attribute "' // TRIM( attribute%name ) // & 2729 '" does not exist' ) 2730 ENDIF 2731 2732 END FUNCTION save_attribute_in_database 2520 FUNCTION save_attribute_in_database( file_name, variable_name, attribute, append ) & 2521 RESULT( return_value ) 2522 2523 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 2524 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 2525 2526 CHARACTER(LEN=*), PARAMETER :: routine_name = 'save_attribute_in_database' !< name of routine 2527 2528 INTEGER :: a !< loop index 2529 INTEGER :: d !< loop index 2530 INTEGER :: f !< loop index 2531 INTEGER :: natts !< number of attributes 2532 INTEGER :: return_value !< return value 2533 2534 LOGICAL :: found !< true if variable or dimension of name 'variable_name' found 2535 LOGICAL, INTENT(IN) :: append !< if true, append value to existing value 2536 2537 TYPE(attribute_type), INTENT(IN) :: attribute !< new attribute 2538 2539 TYPE(attribute_type), DIMENSION(:), ALLOCATABLE :: atts_tmp !< temporary attribute list 2540 2541 2542 return_value = 0 2543 found = .FALSE. 2544 2545 CALL internal_message( 'debug', routine_name // & 2546 ': define attribute "' // TRIM( attribute%name ) // & 2547 '" of variable "' // TRIM( variable_name ) // & 2548 '" in file "' // TRIM( file_name ) // '"' ) 2549 2550 DO f = 1, nfiles 2551 2552 IF ( TRIM( file_name ) == files(f)%name ) THEN 2553 2554 IF ( files(f)%is_init ) THEN 2555 return_value = 1 2556 CALL internal_message( 'error', routine_name // ': file "' // TRIM( file_name ) // & 2557 '" is already initialized. No further attribute definition allowed!' ) 2558 EXIT 2559 ENDIF 2560 ! 2561 !-- Add attribute to file 2562 IF ( TRIM( variable_name ) == '' ) THEN 2563 ! 2564 !-- Initialize first file attribute 2565 IF ( .NOT. ALLOCATED( files(f)%attributes ) ) THEN 2566 natts = 1 2567 ALLOCATE( files(f)%attributes(natts) ) 2568 ELSE 2569 natts = SIZE( files(f)%attributes ) 2570 ! 2571 !-- Check if attribute already exists 2572 DO a = 1, natts 2573 IF ( files(f)%attributes(a)%name == attribute%name ) THEN 2574 IF ( append ) THEN 2575 ! 2576 !-- Append existing string attribute 2577 files(f)%attributes(a)%value_char = & 2578 TRIM( files(f)%attributes(a)%value_char ) // & 2579 TRIM( attribute%value_char ) 2580 ELSE 2581 files(f)%attributes(a) = attribute 2582 ENDIF 2583 found = .TRUE. 2584 EXIT 2585 ENDIF 2586 ENDDO 2587 ! 2588 !-- Extend attribute list by 1 2589 IF ( .NOT. found ) THEN 2590 ALLOCATE( atts_tmp(natts) ) 2591 atts_tmp = files(f)%attributes 2592 DEALLOCATE( files(f)%attributes ) 2593 natts = natts + 1 2594 ALLOCATE( files(f)%attributes(natts) ) 2595 files(f)%attributes(:natts-1) = atts_tmp 2596 DEALLOCATE( atts_tmp ) 2597 ENDIF 2598 ENDIF 2599 ! 2600 !-- Save new attribute to the end of the attribute list 2601 IF ( .NOT. found ) THEN 2602 files(f)%attributes(natts) = attribute 2603 found = .TRUE. 2604 ENDIF 2605 2606 EXIT 2607 2608 ELSE 2609 ! 2610 !-- Add attribute to dimension 2611 IF ( ALLOCATED( files(f)%dimensions ) ) THEN 2612 2613 DO d = 1, SIZE( files(f)%dimensions ) 2614 2615 IF ( files(f)%dimensions(d)%name == TRIM( variable_name ) ) THEN 2616 2617 IF ( .NOT. ALLOCATED( files(f)%dimensions(d)%attributes ) ) THEN 2618 ! 2619 !-- Initialize first attribute 2620 natts = 1 2621 ALLOCATE( files(f)%dimensions(d)%attributes(natts) ) 2622 ELSE 2623 natts = SIZE( files(f)%dimensions(d)%attributes ) 2624 ! 2625 !-- Check if attribute already exists 2626 DO a = 1, natts 2627 IF ( files(f)%dimensions(d)%attributes(a)%name == attribute%name ) & 2628 THEN 2629 IF ( append ) THEN 2630 ! 2631 !-- Append existing character attribute 2632 files(f)%dimensions(d)%attributes(a)%value_char = & 2633 TRIM( files(f)%dimensions(d)%attributes(a)%value_char ) // & 2634 TRIM( attribute%value_char ) 2635 ELSE 2636 ! 2637 !-- Update existing attribute 2638 files(f)%dimensions(d)%attributes(a) = attribute 2639 ENDIF 2640 found = .TRUE. 2641 EXIT 2642 ENDIF 2643 ENDDO 2644 ! 2645 !-- Extend attribute list 2646 IF ( .NOT. found ) THEN 2647 ALLOCATE( atts_tmp(natts) ) 2648 atts_tmp = files(f)%dimensions(d)%attributes 2649 DEALLOCATE( files(f)%dimensions(d)%attributes ) 2650 natts = natts + 1 2651 ALLOCATE( files(f)%dimensions(d)%attributes(natts) ) 2652 files(f)%dimensions(d)%attributes(:natts-1) = atts_tmp 2653 DEALLOCATE( atts_tmp ) 2654 ENDIF 2655 ENDIF 2656 ! 2657 !-- Add new attribute to database 2658 IF ( .NOT. found ) THEN 2659 files(f)%dimensions(d)%attributes(natts) = attribute 2660 found = .TRUE. 2661 ENDIF 2662 2663 EXIT 2664 2665 ENDIF ! dimension found 2666 2667 ENDDO ! loop over dimensions 2668 2669 ENDIF ! dimensions exist in file 2670 ! 2671 !-- Add attribute to variable 2672 IF ( .NOT. found .AND. ALLOCATED( files(f)%variables) ) THEN 2673 2674 DO d = 1, SIZE( files(f)%variables ) 2675 2676 IF ( files(f)%variables(d)%name == TRIM( variable_name ) ) THEN 2677 2678 IF ( .NOT. ALLOCATED( files(f)%variables(d)%attributes ) ) THEN 2679 ! 2680 !-- Initialize first attribute 2681 natts = 1 2682 ALLOCATE( files(f)%variables(d)%attributes(natts) ) 2683 ELSE 2684 natts = SIZE( files(f)%variables(d)%attributes ) 2685 ! 2686 !-- Check if attribute already exists 2687 DO a = 1, natts 2688 IF ( files(f)%variables(d)%attributes(a)%name == attribute%name ) & 2689 THEN 2690 IF ( append ) THEN 2691 ! 2692 !-- Append existing character attribute 2693 files(f)%variables(d)%attributes(a)%value_char = & 2694 TRIM( files(f)%variables(d)%attributes(a)%value_char ) // & 2695 TRIM( attribute%value_char ) 2696 ELSE 2697 ! 2698 !-- Update existing attribute 2699 files(f)%variables(d)%attributes(a) = attribute 2700 ENDIF 2701 found = .TRUE. 2702 EXIT 2703 ENDIF 2704 ENDDO 2705 ! 2706 !-- Extend attribute list 2707 IF ( .NOT. found ) THEN 2708 ALLOCATE( atts_tmp(natts) ) 2709 atts_tmp = files(f)%variables(d)%attributes 2710 DEALLOCATE( files(f)%variables(d)%attributes ) 2711 natts = natts + 1 2712 ALLOCATE( files(f)%variables(d)%attributes(natts) ) 2713 files(f)%variables(d)%attributes(:natts-1) = atts_tmp 2714 DEALLOCATE( atts_tmp ) 2715 ENDIF 2716 2717 ENDIF 2718 ! 2719 !-- Add new attribute to database 2720 IF ( .NOT. found ) THEN 2721 files(f)%variables(d)%attributes(natts) = attribute 2722 found = .TRUE. 2723 ENDIF 2724 2725 EXIT 2726 2727 ENDIF ! variable found 2728 2729 ENDDO ! loop over variables 2730 2731 ENDIF ! variables exist in file 2732 2733 IF ( .NOT. found ) THEN 2734 return_value = 1 2735 CALL internal_message( 'error', & 2736 routine_name // & 2737 ': requested dimension/variable "' // TRIM( variable_name ) // & 2738 '" for attribute "' // TRIM( attribute%name ) // & 2739 '" does not exist in file "' // TRIM( file_name ) // '"' ) 2740 ENDIF 2741 2742 EXIT 2743 2744 ENDIF ! variable_name not empty 2745 2746 ENDIF ! check file_name 2747 2748 ENDDO ! loop over files 2749 2750 IF ( .NOT. found .AND. return_value == 0 ) THEN 2751 return_value = 1 2752 CALL internal_message( 'error', & 2753 routine_name // & 2754 ': requested file "' // TRIM( file_name ) // & 2755 '" for attribute "' // TRIM( attribute%name ) // & 2756 '" does not exist' ) 2757 ENDIF 2758 2759 END FUNCTION save_attribute_in_database 2733 2760 2734 2761 !--------------------------------------------------------------------------------------------------! … … 2738 2765 !> without variables). 2739 2766 !--------------------------------------------------------------------------------------------------! 2740 FUNCTION cleanup_database() RESULT( return_value )2741 2742 ! CHARACTER(LEN=*), PARAMETER :: routine_name = 'cleanup_database' !< name of routine2743 2744 INTEGER :: d !< loop index2745 INTEGER :: f !< loop index2746 INTEGER :: i !< loop index2747 INTEGER :: ndims !< number of dimensions in a file2748 INTEGER :: ndims_used !< number of used dimensions in a file2749 INTEGER :: nfiles_used !< number of used files2750 INTEGER :: nvars !< number of variables in a file2751 INTEGER :: return_value !< return value2752 2753 LOGICAL, DIMENSION(1:nfiles) :: file_is_used !< true if file contains variables2754 LOGICAL, DIMENSION(:), ALLOCATABLE :: dimension_is_used !< true if dimension is used by any variable2755 2756 TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: used_dimensions !< list of used dimensions2757 2758 TYPE(file_type), DIMENSION(:), ALLOCATABLE :: used_files !< list of used files2759 2760 2761 return_value = 02762 2763 2764 file_is_used(:) = .FALSE.2765 DO f = 1, nfiles2766 IF ( ALLOCATED( files(f)%variables ) ) THEN2767 file_is_used(f) = .TRUE.2768 ENDIF2769 ENDDO2770 2771 2772 nfiles_used = COUNT( file_is_used )2773 ALLOCATE( used_files(nfiles_used) )2774 i = 02775 DO f = 1, nfiles2776 IF ( file_is_used(f) ) THEN2777 i = i + 12778 used_files(i) = files(f)2779 ENDIF2780 ENDDO2781 2782 2783 DEALLOCATE( files )2784 nfiles = nfiles_used2785 ALLOCATE( files(nfiles) )2786 files = used_files2787 DEALLOCATE( used_files )2788 2789 2790 DO f = 1, nfiles2791 2792 !--If a file is already initialized, it was already checked previously2793 IF ( files(f)%is_init ) CYCLE2794 2795 !--Get number of defined dimensions2796 ndims = SIZE( files(f)%dimensions )2797 ALLOCATE( dimension_is_used(ndims) )2798 2799 !--Go through all variables and flag all used dimensions2800 nvars = SIZE( files(f)%variables )2801 DO d = 1, ndims2802 DO i = 1, nvars2803 dimension_is_used(d) = &2804 ANY( files(f)%dimensions(d)%name == files(f)%variables(i)%dimension_names )2805 IF ( dimension_is_used(d) ) EXIT2806 ENDDO2807 ENDDO2808 2809 !--Copy used dimensions to temporary list2810 ndims_used = COUNT( dimension_is_used )2811 ALLOCATE( used_dimensions(ndims_used) )2812 i = 02813 DO d = 1, ndims2814 IF ( dimension_is_used(d) ) THEN2815 i = i + 12816 used_dimensions(i) = files(f)%dimensions(d)2817 ENDIF2818 ENDDO2819 2820 !--Replace dimension list with list of used dimensions2821 DEALLOCATE( files(f)%dimensions )2822 ndims = ndims_used2823 ALLOCATE( files(f)%dimensions(ndims) )2824 files(f)%dimensions = used_dimensions2825 DEALLOCATE( used_dimensions )2826 DEALLOCATE( dimension_is_used )2827 2828 ENDDO2829 2830 END FUNCTION cleanup_database2767 FUNCTION cleanup_database() RESULT( return_value ) 2768 2769 ! CHARACTER(LEN=*), PARAMETER :: routine_name = 'cleanup_database' !< name of routine 2770 2771 INTEGER :: d !< loop index 2772 INTEGER :: f !< loop index 2773 INTEGER :: i !< loop index 2774 INTEGER :: ndims !< number of dimensions in a file 2775 INTEGER :: ndims_used !< number of used dimensions in a file 2776 INTEGER :: nfiles_used !< number of used files 2777 INTEGER :: nvars !< number of variables in a file 2778 INTEGER :: return_value !< return value 2779 2780 LOGICAL, DIMENSION(1:nfiles) :: file_is_used !< true if file contains variables 2781 LOGICAL, DIMENSION(:), ALLOCATABLE :: dimension_is_used !< true if dimension is used by any variable 2782 2783 TYPE(dimension_type), DIMENSION(:), ALLOCATABLE :: used_dimensions !< list of used dimensions 2784 2785 TYPE(file_type), DIMENSION(:), ALLOCATABLE :: used_files !< list of used files 2786 2787 2788 return_value = 0 2789 ! 2790 !-- Flag files which contain output variables as used 2791 file_is_used(:) = .FALSE. 2792 DO f = 1, nfiles 2793 IF ( ALLOCATED( files(f)%variables ) ) THEN 2794 file_is_used(f) = .TRUE. 2795 ENDIF 2796 ENDDO 2797 ! 2798 !-- Copy flagged files into temporary list 2799 nfiles_used = COUNT( file_is_used ) 2800 ALLOCATE( used_files(nfiles_used) ) 2801 i = 0 2802 DO f = 1, nfiles 2803 IF ( file_is_used(f) ) THEN 2804 i = i + 1 2805 used_files(i) = files(f) 2806 ENDIF 2807 ENDDO 2808 ! 2809 !-- Replace file list with list of used files 2810 DEALLOCATE( files ) 2811 nfiles = nfiles_used 2812 ALLOCATE( files(nfiles) ) 2813 files = used_files 2814 DEALLOCATE( used_files ) 2815 ! 2816 !-- Check every file for unused dimensions 2817 DO f = 1, nfiles 2818 ! 2819 !-- If a file is already initialized, it was already checked previously 2820 IF ( files(f)%is_init ) CYCLE 2821 ! 2822 !-- Get number of defined dimensions 2823 ndims = SIZE( files(f)%dimensions ) 2824 ALLOCATE( dimension_is_used(ndims) ) 2825 ! 2826 !-- Go through all variables and flag all used dimensions 2827 nvars = SIZE( files(f)%variables ) 2828 DO d = 1, ndims 2829 DO i = 1, nvars 2830 dimension_is_used(d) = & 2831 ANY( files(f)%dimensions(d)%name == files(f)%variables(i)%dimension_names ) 2832 IF ( dimension_is_used(d) ) EXIT 2833 ENDDO 2834 ENDDO 2835 ! 2836 !-- Copy used dimensions to temporary list 2837 ndims_used = COUNT( dimension_is_used ) 2838 ALLOCATE( used_dimensions(ndims_used) ) 2839 i = 0 2840 DO d = 1, ndims 2841 IF ( dimension_is_used(d) ) THEN 2842 i = i + 1 2843 used_dimensions(i) = files(f)%dimensions(d) 2844 ENDIF 2845 ENDDO 2846 ! 2847 !-- Replace dimension list with list of used dimensions 2848 DEALLOCATE( files(f)%dimensions ) 2849 ndims = ndims_used 2850 ALLOCATE( files(f)%dimensions(ndims) ) 2851 files(f)%dimensions = used_dimensions 2852 DEALLOCATE( used_dimensions ) 2853 DEALLOCATE( dimension_is_used ) 2854 2855 ENDDO 2856 2857 END FUNCTION cleanup_database 2831 2858 2832 2859 !--------------------------------------------------------------------------------------------------! … … 2835 2862 !> Open requested output file. 2836 2863 !--------------------------------------------------------------------------------------------------! 2837 SUBROUTINE open_output_file( file_format, file_name, file_id, return_value )2838 2839 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file2840 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file to be checked2841 2842 CHARACTER(LEN=*), PARAMETER :: routine_name = 'open_output_file' !< name of routine2843 2844 INTEGER, INTENT(OUT) :: file_id !< file ID2845 INTEGER :: output_return_value !< return value of a called output routine2846 INTEGER, INTENT(OUT) :: return_value !< return value2847 2848 2849 return_value = 02850 output_return_value = 02851 2852 SELECT CASE ( TRIM( file_format ) )2853 2854 CASE ( 'binary' )2855 CALL binary_open_file( 'binary', file_name, file_id, output_return_value )2856 2857 CASE ( 'netcdf4-serial' )2858 CALL netcdf4_open_file( 'serial', file_name, file_id, output_return_value )2859 2860 CASE ( 'netcdf4-parallel' )2861 CALL netcdf4_open_file( 'parallel', file_name, file_id, output_return_value )2862 2863 CASE DEFAULT2864 return_value = 12865 2866 END SELECT2867 2868 IF ( output_return_value /= 0 ) THEN2869 return_value = output_return_value2870 CALL internal_message( 'error', routine_name // &2871 ': error while opening file "' // TRIM( file_name ) // '"' )2872 ELSEIF ( return_value /= 0 ) THEN2873 CALL internal_message( 'error', routine_name // &2874 ': file "' // TRIM( file_name ) // &2875 '": file format "' // TRIM( file_format ) // &2876 '" not supported' )2877 ENDIF2878 2879 END SUBROUTINE open_output_file2864 SUBROUTINE open_output_file( file_format, file_name, file_id, return_value ) 2865 2866 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file 2867 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file to be checked 2868 2869 CHARACTER(LEN=*), PARAMETER :: routine_name = 'open_output_file' !< name of routine 2870 2871 INTEGER, INTENT(OUT) :: file_id !< file ID 2872 INTEGER :: output_return_value !< return value of a called output routine 2873 INTEGER, INTENT(OUT) :: return_value !< return value 2874 2875 2876 return_value = 0 2877 output_return_value = 0 2878 2879 SELECT CASE ( TRIM( file_format ) ) 2880 2881 CASE ( 'binary' ) 2882 CALL binary_open_file( 'binary', file_name, file_id, output_return_value ) 2883 2884 CASE ( 'netcdf4-serial' ) 2885 CALL netcdf4_open_file( 'serial', file_name, file_id, output_return_value ) 2886 2887 CASE ( 'netcdf4-parallel' ) 2888 CALL netcdf4_open_file( 'parallel', file_name, file_id, output_return_value ) 2889 2890 CASE DEFAULT 2891 return_value = 1 2892 2893 END SELECT 2894 2895 IF ( output_return_value /= 0 ) THEN 2896 return_value = output_return_value 2897 CALL internal_message( 'error', routine_name // & 2898 ': error while opening file "' // TRIM( file_name ) // '"' ) 2899 ELSEIF ( return_value /= 0 ) THEN 2900 CALL internal_message( 'error', routine_name // & 2901 ': file "' // TRIM( file_name ) // & 2902 '": file format "' // TRIM( file_format ) // & 2903 '" not supported' ) 2904 ENDIF 2905 2906 END SUBROUTINE open_output_file 2880 2907 2881 2908 !--------------------------------------------------------------------------------------------------! … … 2884 2911 !> Initialize attributes, dimensions and variables in a file. 2885 2912 !--------------------------------------------------------------------------------------------------! 2886 SUBROUTINE init_file_header( file, return_value ) 2887 2888 ! CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_header' !< name of routine 2889 2890 INTEGER :: a !< loop index 2891 INTEGER :: d !< loop index 2892 INTEGER, INTENT(OUT) :: return_value !< return value 2893 2894 TYPE(file_type), INTENT(INOUT) :: file !< initialize header of this file 2895 2896 2897 return_value = 0 2898 2899 !-- Write file attributes 2900 IF ( ALLOCATED( file%attributes ) ) THEN 2901 DO a = 1, SIZE( file%attributes ) 2902 return_value = write_attribute( file%format, file%id, file%name, & 2903 variable_id=no_id, variable_name='', & 2904 attribute=file%attributes(a) ) 2905 IF ( return_value /= 0 ) EXIT 2906 ENDDO 2907 ENDIF 2908 2909 IF ( return_value == 0 ) THEN 2910 2911 !-- Initialize file dimensions 2912 DO d = 1, SIZE( file%dimensions ) 2913 2914 IF ( .NOT. file%dimensions(d)%is_masked ) THEN 2915 2916 !-- Initialize non-masked dimension 2917 CALL init_file_dimension( file%format, file%id, file%name, & 2918 file%dimensions(d)%id, file%dimensions(d)%name, & 2919 file%dimensions(d)%data_type, file%dimensions(d)%length, & 2920 file%dimensions(d)%variable_id, return_value ) 2921 2922 ELSE 2923 2924 !-- Initialize masked dimension 2925 CALL init_file_dimension( file%format, file%id, file%name, & 2926 file%dimensions(d)%id, file%dimensions(d)%name, & 2927 file%dimensions(d)%data_type, file%dimensions(d)%length_mask, & 2928 file%dimensions(d)%variable_id, return_value ) 2929 2930 ENDIF 2931 2932 IF ( return_value == 0 .AND. ALLOCATED( file%dimensions(d)%attributes ) ) THEN 2933 !-- Write dimension attributes 2934 DO a = 1, SIZE( file%dimensions(d)%attributes ) 2935 return_value = write_attribute( file%format, file%id, file%name, & 2936 variable_id=file%dimensions(d)%variable_id, & 2937 variable_name=file%dimensions(d)%name, & 2938 attribute=file%dimensions(d)%attributes(a) ) 2939 IF ( return_value /= 0 ) EXIT 2940 ENDDO 2941 ENDIF 2942 2943 IF ( return_value /= 0 ) EXIT 2944 2945 ENDDO 2946 2947 !-- Save dimension IDs for variables wihtin database 2948 IF ( return_value == 0 ) & 2949 CALL collect_dimesion_ids_for_variables( file%name, file%variables, file%dimensions, & 2950 return_value ) 2951 2952 !-- Initialize file variables 2953 IF ( return_value == 0 ) THEN 2954 DO d = 1, SIZE( file%variables ) 2955 2956 CALL init_file_variable( file%format, file%id, file%name, & 2957 file%variables(d)%id, file%variables(d)%name, file%variables(d)%data_type, & 2958 file%variables(d)%dimension_ids, & 2959 file%variables(d)%is_global, return_value ) 2960 2961 IF ( return_value == 0 .AND. ALLOCATED( file%variables(d)%attributes ) ) THEN 2962 !-- Write variable attributes 2963 DO a = 1, SIZE( file%variables(d)%attributes ) 2964 return_value = write_attribute( file%format, file%id, file%name, & 2965 variable_id=file%variables(d)%id, & 2966 variable_name=file%variables(d)%name, & 2967 attribute=file%variables(d)%attributes(a) ) 2968 IF ( return_value /= 0 ) EXIT 2969 ENDDO 2970 ENDIF 2971 2972 IF ( return_value /= 0 ) EXIT 2973 2974 ENDDO 2975 ENDIF 2976 2977 ENDIF 2978 2979 END SUBROUTINE init_file_header 2913 SUBROUTINE init_file_header( file, return_value ) 2914 2915 ! CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_header' !< name of routine 2916 2917 INTEGER :: a !< loop index 2918 INTEGER :: d !< loop index 2919 INTEGER, INTENT(OUT) :: return_value !< return value 2920 2921 TYPE(file_type), INTENT(INOUT) :: file !< initialize header of this file 2922 2923 2924 return_value = 0 2925 ! 2926 !-- Write file attributes 2927 IF ( ALLOCATED( file%attributes ) ) THEN 2928 DO a = 1, SIZE( file%attributes ) 2929 return_value = write_attribute( file%format, file%id, file%name, & 2930 variable_id=no_id, variable_name='', & 2931 attribute=file%attributes(a) ) 2932 IF ( return_value /= 0 ) EXIT 2933 ENDDO 2934 ENDIF 2935 2936 IF ( return_value == 0 ) THEN 2937 ! 2938 !-- Initialize file dimensions 2939 DO d = 1, SIZE( file%dimensions ) 2940 2941 IF ( .NOT. file%dimensions(d)%is_masked ) THEN 2942 ! 2943 !-- Initialize non-masked dimension 2944 CALL init_file_dimension( file%format, file%id, file%name, & 2945 file%dimensions(d)%id, file%dimensions(d)%name, & 2946 file%dimensions(d)%data_type, file%dimensions(d)%length, & 2947 file%dimensions(d)%variable_id, return_value ) 2948 2949 ELSE 2950 ! 2951 !-- Initialize masked dimension 2952 CALL init_file_dimension( file%format, file%id, file%name, & 2953 file%dimensions(d)%id, file%dimensions(d)%name, & 2954 file%dimensions(d)%data_type, file%dimensions(d)%length_mask, & 2955 file%dimensions(d)%variable_id, return_value ) 2956 2957 ENDIF 2958 2959 IF ( return_value == 0 .AND. ALLOCATED( file%dimensions(d)%attributes ) ) THEN 2960 ! 2961 !-- Write dimension attributes 2962 DO a = 1, SIZE( file%dimensions(d)%attributes ) 2963 return_value = write_attribute( file%format, file%id, file%name, & 2964 variable_id=file%dimensions(d)%variable_id, & 2965 variable_name=file%dimensions(d)%name, & 2966 attribute=file%dimensions(d)%attributes(a) ) 2967 IF ( return_value /= 0 ) EXIT 2968 ENDDO 2969 ENDIF 2970 2971 IF ( return_value /= 0 ) EXIT 2972 2973 ENDDO 2974 ! 2975 !-- Save dimension IDs for variables wihtin database 2976 IF ( return_value == 0 ) & 2977 CALL collect_dimesion_ids_for_variables( file%name, file%variables, file%dimensions, & 2978 return_value ) 2979 ! 2980 !-- Initialize file variables 2981 IF ( return_value == 0 ) THEN 2982 DO d = 1, SIZE( file%variables ) 2983 2984 CALL init_file_variable( file%format, file%id, file%name, & 2985 file%variables(d)%id, file%variables(d)%name, file%variables(d)%data_type, & 2986 file%variables(d)%dimension_ids, & 2987 file%variables(d)%is_global, return_value ) 2988 2989 IF ( return_value == 0 .AND. ALLOCATED( file%variables(d)%attributes ) ) THEN 2990 ! 2991 !-- Write variable attributes 2992 DO a = 1, SIZE( file%variables(d)%attributes ) 2993 return_value = write_attribute( file%format, file%id, file%name, & 2994 variable_id=file%variables(d)%id, & 2995 variable_name=file%variables(d)%name, & 2996 attribute=file%variables(d)%attributes(a) ) 2997 IF ( return_value /= 0 ) EXIT 2998 ENDDO 2999 ENDIF 3000 3001 IF ( return_value /= 0 ) EXIT 3002 3003 ENDDO 3004 ENDIF 3005 3006 ENDIF 3007 3008 END SUBROUTINE init_file_header 2980 3009 2981 3010 !--------------------------------------------------------------------------------------------------! … … 2984 3013 !> Initialize dimension in file. 2985 3014 !--------------------------------------------------------------------------------------------------! 2986 SUBROUTINE init_file_dimension( file_format, file_id, file_name, &2987 dimension_id, dimension_name, dimension_type, dimension_length, &2988 variable_id, return_value )2989 2990 CHARACTER(LEN=*), INTENT(IN) :: dimension_name !< name of dimension2991 CHARACTER(LEN=*), INTENT(IN) :: dimension_type !< data type of dimension2992 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file2993 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file2994 2995 CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_dimension' !< file format chosen for file2996 2997 INTEGER, INTENT(OUT) :: dimension_id !< dimension ID2998 INTEGER, INTENT(IN) :: dimension_length !< length of dimension2999 INTEGER, INTENT(IN) :: file_id !< file ID3000 INTEGER :: output_return_value !< return value of a called output routine3001 INTEGER, INTENT(OUT) :: return_value !< return value3002 INTEGER, INTENT(OUT) :: variable_id !< associated variable ID3003 3004 3005 return_value = 03006 output_return_value = 03007 3008 temp_string = '(file "' // TRIM( file_name ) // &3009 '", dimension "' // TRIM( dimension_name ) // '")'3010 3011 SELECT CASE ( TRIM( file_format ) )3012 3013 CASE ( 'binary' )3014 CALL binary_init_dimension( 'binary', file_id, dimension_id, variable_id, &3015 dimension_name, dimension_type, dimension_length, &3016 return_value=output_return_value )3017 3018 CASE ( 'netcdf4-serial' )3019 CALL netcdf4_init_dimension( 'serial', file_id, dimension_id, variable_id, &3020 dimension_name, dimension_type, dimension_length, &3021 return_value=output_return_value )3022 3023 CASE ( 'netcdf4-parallel' )3024 CALL netcdf4_init_dimension( 'parallel', file_id, dimension_id, variable_id, &3025 dimension_name, dimension_type, dimension_length, &3026 return_value=output_return_value )3027 3028 CASE DEFAULT3029 return_value = 13030 CALL internal_message( 'error', routine_name // &3031 ': file format "' // TRIM( file_format ) // &3032 '" not supported ' // TRIM( temp_string ) )3033 3034 END SELECT3035 3036 IF ( output_return_value /= 0 ) THEN3037 return_value = output_return_value3038 CALL internal_message( 'error', routine_name // &3039 ': error while defining dimension ' // TRIM( temp_string ) )3040 ENDIF3041 3042 END SUBROUTINE init_file_dimension3015 SUBROUTINE init_file_dimension( file_format, file_id, file_name, & 3016 dimension_id, dimension_name, dimension_type, dimension_length, & 3017 variable_id, return_value ) 3018 3019 CHARACTER(LEN=*), INTENT(IN) :: dimension_name !< name of dimension 3020 CHARACTER(LEN=*), INTENT(IN) :: dimension_type !< data type of dimension 3021 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file 3022 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 3023 3024 CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_dimension' !< file format chosen for file 3025 3026 INTEGER, INTENT(OUT) :: dimension_id !< dimension ID 3027 INTEGER, INTENT(IN) :: dimension_length !< length of dimension 3028 INTEGER, INTENT(IN) :: file_id !< file ID 3029 INTEGER :: output_return_value !< return value of a called output routine 3030 INTEGER, INTENT(OUT) :: return_value !< return value 3031 INTEGER, INTENT(OUT) :: variable_id !< associated variable ID 3032 3033 3034 return_value = 0 3035 output_return_value = 0 3036 3037 temp_string = '(file "' // TRIM( file_name ) // & 3038 '", dimension "' // TRIM( dimension_name ) // '")' 3039 3040 SELECT CASE ( TRIM( file_format ) ) 3041 3042 CASE ( 'binary' ) 3043 CALL binary_init_dimension( 'binary', file_id, dimension_id, variable_id, & 3044 dimension_name, dimension_type, dimension_length, & 3045 return_value=output_return_value ) 3046 3047 CASE ( 'netcdf4-serial' ) 3048 CALL netcdf4_init_dimension( 'serial', file_id, dimension_id, variable_id, & 3049 dimension_name, dimension_type, dimension_length, & 3050 return_value=output_return_value ) 3051 3052 CASE ( 'netcdf4-parallel' ) 3053 CALL netcdf4_init_dimension( 'parallel', file_id, dimension_id, variable_id, & 3054 dimension_name, dimension_type, dimension_length, & 3055 return_value=output_return_value ) 3056 3057 CASE DEFAULT 3058 return_value = 1 3059 CALL internal_message( 'error', routine_name // & 3060 ': file format "' // TRIM( file_format ) // & 3061 '" not supported ' // TRIM( temp_string ) ) 3062 3063 END SELECT 3064 3065 IF ( output_return_value /= 0 ) THEN 3066 return_value = output_return_value 3067 CALL internal_message( 'error', routine_name // & 3068 ': error while defining dimension ' // TRIM( temp_string ) ) 3069 ENDIF 3070 3071 END SUBROUTINE init_file_dimension 3043 3072 3044 3073 !--------------------------------------------------------------------------------------------------! … … 3047 3076 !> Initialize variable. 3048 3077 !--------------------------------------------------------------------------------------------------! 3049 SUBROUTINE init_file_variable( file_format, file_id, file_name, &3050 variable_id, variable_name, variable_type, dimension_ids, &3051 is_global, return_value )3052 3053 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file3054 CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name3055 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable3056 CHARACTER(LEN=*), INTENT(IN) :: variable_type !< data type of variable3057 3058 CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_variable' !< file format chosen for file3059 3060 INTEGER, INTENT(IN) :: file_id !< file ID3061 INTEGER :: output_return_value !< return value of a called output routine3062 INTEGER, INTENT(OUT) :: return_value !< return value3063 INTEGER, INTENT(OUT) :: variable_id !< variable ID3064 3065 INTEGER, DIMENSION(:), INTENT(IN) :: dimension_ids !< list of dimension IDs used by variable3066 3067 LOGICAL, INTENT(IN) :: is_global !< true if variable is global3068 3069 3070 return_value = 03071 output_return_value = 03072 3073 temp_string = '(file "' // TRIM( file_name ) // &3074 '", variable "' // TRIM( variable_name ) // '")'3075 3076 SELECT CASE ( TRIM( file_format ) )3077 3078 CASE ( 'binary' )3079 CALL binary_init_variable( 'binary', file_id, variable_id, variable_name, &3080 variable_type, dimension_ids, is_global, return_value=output_return_value )3081 3082 CASE ( 'netcdf4-serial' )3083 CALL netcdf4_init_variable( 'serial', file_id, variable_id, variable_name, &3084 variable_type, dimension_ids, is_global, return_value=output_return_value )3085 3086 CASE ( 'netcdf4-parallel' )3087 CALL netcdf4_init_variable( 'parallel', file_id, variable_id, variable_name, &3088 variable_type, dimension_ids, is_global, return_value=output_return_value )3089 3090 CASE DEFAULT3091 return_value = 13092 CALL internal_message( 'error', routine_name // &3093 ': file format "' // TRIM( file_format ) // &3094 '" not supported ' // TRIM( temp_string ) )3095 3096 END SELECT3097 3098 IF ( output_return_value /= 0 ) THEN3099 return_value = output_return_value3100 CALL internal_message( 'error', routine_name // &3101 ': error while defining variable ' // TRIM( temp_string ) )3102 ENDIF3103 3104 END SUBROUTINE init_file_variable3078 SUBROUTINE init_file_variable( file_format, file_id, file_name, & 3079 variable_id, variable_name, variable_type, dimension_ids, & 3080 is_global, return_value ) 3081 3082 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file 3083 CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name 3084 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 3085 CHARACTER(LEN=*), INTENT(IN) :: variable_type !< data type of variable 3086 3087 CHARACTER(LEN=*), PARAMETER :: routine_name = 'init_file_variable' !< file format chosen for file 3088 3089 INTEGER, INTENT(IN) :: file_id !< file ID 3090 INTEGER :: output_return_value !< return value of a called output routine 3091 INTEGER, INTENT(OUT) :: return_value !< return value 3092 INTEGER, INTENT(OUT) :: variable_id !< variable ID 3093 3094 INTEGER, DIMENSION(:), INTENT(IN) :: dimension_ids !< list of dimension IDs used by variable 3095 3096 LOGICAL, INTENT(IN) :: is_global !< true if variable is global 3097 3098 3099 return_value = 0 3100 output_return_value = 0 3101 3102 temp_string = '(file "' // TRIM( file_name ) // & 3103 '", variable "' // TRIM( variable_name ) // '")' 3104 3105 SELECT CASE ( TRIM( file_format ) ) 3106 3107 CASE ( 'binary' ) 3108 CALL binary_init_variable( 'binary', file_id, variable_id, variable_name, & 3109 variable_type, dimension_ids, is_global, return_value=output_return_value ) 3110 3111 CASE ( 'netcdf4-serial' ) 3112 CALL netcdf4_init_variable( 'serial', file_id, variable_id, variable_name, & 3113 variable_type, dimension_ids, is_global, return_value=output_return_value ) 3114 3115 CASE ( 'netcdf4-parallel' ) 3116 CALL netcdf4_init_variable( 'parallel', file_id, variable_id, variable_name, & 3117 variable_type, dimension_ids, is_global, return_value=output_return_value ) 3118 3119 CASE DEFAULT 3120 return_value = 1 3121 CALL internal_message( 'error', routine_name // & 3122 ': file format "' // TRIM( file_format ) // & 3123 '" not supported ' // TRIM( temp_string ) ) 3124 3125 END SELECT 3126 3127 IF ( output_return_value /= 0 ) THEN 3128 return_value = output_return_value 3129 CALL internal_message( 'error', routine_name // & 3130 ': error while defining variable ' // TRIM( temp_string ) ) 3131 ENDIF 3132 3133 END SUBROUTINE init_file_variable 3105 3134 3106 3135 !--------------------------------------------------------------------------------------------------! … … 3109 3138 !> Write attribute to file. 3110 3139 !--------------------------------------------------------------------------------------------------! 3111 FUNCTION write_attribute( file_format, file_id, file_name, &3112 variable_id, variable_name, attribute ) RESULT( return_value )3113 3114 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file3115 CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name3116 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< variable name3117 3118 CHARACTER(LEN=*), PARAMETER :: routine_name = 'write_attribute' !< file format chosen for file3119 3120 INTEGER, INTENT(IN) :: file_id !< file ID3121 INTEGER :: return_value !< return value3122 INTEGER :: output_return_value !< return value of a called output routine3123 INTEGER, INTENT(IN) :: variable_id !< variable ID3124 3125 TYPE(attribute_type), INTENT(IN) :: attribute !< attribute to be written3126 3127 3128 return_value = 03129 output_return_value = 03130 3131 3132 temp_string = '(file "' // TRIM( file_name ) // &3133 '", variable "' // TRIM( variable_name ) // &3134 '", attribute "' // TRIM( attribute%name ) // '")'3135 3136 3137 SELECT CASE ( TRIM( file_format ) )3138 3139 CASE ( 'binary' )3140 3141 SELECT CASE ( TRIM( attribute%data_type ) )3142 3143 CASE( 'char' )3144 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3145 attribute_name=attribute%name, value_char=attribute%value_char, &3146 return_value=output_return_value )3147 3148 CASE( 'int8' )3149 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3150 attribute_name=attribute%name, value_int8=attribute%value_int8, &3151 return_value=output_return_value )3152 3153 CASE( 'int16' )3154 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3155 attribute_name=attribute%name, value_int16=attribute%value_int16, &3156 return_value=output_return_value )3157 3158 CASE( 'int32' )3159 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3160 attribute_name=attribute%name, value_int32=attribute%value_int32, &3161 return_value=output_return_value )3162 3163 CASE( 'real32' )3164 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3165 attribute_name=attribute%name, value_real32=attribute%value_real32, &3166 return_value=output_return_value )3167 3168 CASE( 'real64' )3169 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, &3170 attribute_name=attribute%name, value_real64=attribute%value_real64, &3171 return_value=output_return_value )3172 3173 CASE DEFAULT3174 return_value = 13175 CALL internal_message( 'error', routine_name // &3176 ': file format "' // TRIM( file_format ) // &3177 '" does not support attribute data type "'// &3178 TRIM( attribute%data_type ) // &3179 '" ' // TRIM( temp_string ) )3180 3181 END SELECT3182 3183 CASE ( 'netcdf4-parallel', 'netcdf4-serial' )3184 3185 SELECT CASE ( TRIM( attribute%data_type ) )3186 3187 CASE( 'char' )3188 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3189 attribute_name=attribute%name, value_char=attribute%value_char, &3190 return_value=output_return_value )3191 3192 CASE( 'int8' )3193 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3194 attribute_name=attribute%name, value_int8=attribute%value_int8, &3195 return_value=output_return_value )3196 3197 CASE( 'int16' )3198 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3199 attribute_name=attribute%name, value_int16=attribute%value_int16, &3200 return_value=output_return_value )3201 3202 CASE( 'int32' )3203 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3204 attribute_name=attribute%name, value_int32=attribute%value_int32, &3205 return_value=output_return_value )3206 3207 CASE( 'real32' )3208 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3209 attribute_name=attribute%name, value_real32=attribute%value_real32, &3210 return_value=output_return_value )3211 3212 CASE( 'real64' )3213 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, &3214 attribute_name=attribute%name, value_real64=attribute%value_real64, &3215 return_value=output_return_value )3216 3217 CASE DEFAULT3218 return_value = 13219 CALL internal_message( 'error', routine_name // &3220 ': file format "' // TRIM( file_format ) // &3221 '" does not support attribute data type "'// &3222 TRIM( attribute%data_type ) // &3223 '" ' // TRIM( temp_string ) )3224 3225 END SELECT3226 3227 CASE DEFAULT3228 return_value = 13229 CALL internal_message( 'error', routine_name // &3230 ': unsupported file format "' // TRIM( file_format ) // &3231 '" ' // TRIM( temp_string ) )3232 3233 END SELECT3234 3235 IF ( output_return_value /= 0 ) THEN3236 return_value = output_return_value3237 CALL internal_message( 'error', routine_name // &3238 ': error while writing attribute ' // TRIM( temp_string ) )3239 ENDIF3240 3241 END FUNCTION write_attribute3140 FUNCTION write_attribute( file_format, file_id, file_name, & 3141 variable_id, variable_name, attribute ) RESULT( return_value ) 3142 3143 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format chosen for file 3144 CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name 3145 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< variable name 3146 3147 CHARACTER(LEN=*), PARAMETER :: routine_name = 'write_attribute' !< file format chosen for file 3148 3149 INTEGER, INTENT(IN) :: file_id !< file ID 3150 INTEGER :: return_value !< return value 3151 INTEGER :: output_return_value !< return value of a called output routine 3152 INTEGER, INTENT(IN) :: variable_id !< variable ID 3153 3154 TYPE(attribute_type), INTENT(IN) :: attribute !< attribute to be written 3155 3156 3157 return_value = 0 3158 output_return_value = 0 3159 ! 3160 !-- Prepare for possible error message 3161 temp_string = '(file "' // TRIM( file_name ) // & 3162 '", variable "' // TRIM( variable_name ) // & 3163 '", attribute "' // TRIM( attribute%name ) // '")' 3164 ! 3165 !-- Write attribute to file 3166 SELECT CASE ( TRIM( file_format ) ) 3167 3168 CASE ( 'binary' ) 3169 3170 SELECT CASE ( TRIM( attribute%data_type ) ) 3171 3172 CASE( 'char' ) 3173 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3174 attribute_name=attribute%name, value_char=attribute%value_char, & 3175 return_value=output_return_value ) 3176 3177 CASE( 'int8' ) 3178 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3179 attribute_name=attribute%name, value_int8=attribute%value_int8, & 3180 return_value=output_return_value ) 3181 3182 CASE( 'int16' ) 3183 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3184 attribute_name=attribute%name, value_int16=attribute%value_int16, & 3185 return_value=output_return_value ) 3186 3187 CASE( 'int32' ) 3188 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3189 attribute_name=attribute%name, value_int32=attribute%value_int32, & 3190 return_value=output_return_value ) 3191 3192 CASE( 'real32' ) 3193 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3194 attribute_name=attribute%name, value_real32=attribute%value_real32, & 3195 return_value=output_return_value ) 3196 3197 CASE( 'real64' ) 3198 CALL binary_write_attribute( file_id=file_id, variable_id=variable_id, & 3199 attribute_name=attribute%name, value_real64=attribute%value_real64, & 3200 return_value=output_return_value ) 3201 3202 CASE DEFAULT 3203 return_value = 1 3204 CALL internal_message( 'error', routine_name // & 3205 ': file format "' // TRIM( file_format ) // & 3206 '" does not support attribute data type "'// & 3207 TRIM( attribute%data_type ) // & 3208 '" ' // TRIM( temp_string ) ) 3209 3210 END SELECT 3211 3212 CASE ( 'netcdf4-parallel', 'netcdf4-serial' ) 3213 3214 SELECT CASE ( TRIM( attribute%data_type ) ) 3215 3216 CASE( 'char' ) 3217 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3218 attribute_name=attribute%name, value_char=attribute%value_char, & 3219 return_value=output_return_value ) 3220 3221 CASE( 'int8' ) 3222 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3223 attribute_name=attribute%name, value_int8=attribute%value_int8, & 3224 return_value=output_return_value ) 3225 3226 CASE( 'int16' ) 3227 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3228 attribute_name=attribute%name, value_int16=attribute%value_int16, & 3229 return_value=output_return_value ) 3230 3231 CASE( 'int32' ) 3232 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3233 attribute_name=attribute%name, value_int32=attribute%value_int32, & 3234 return_value=output_return_value ) 3235 3236 CASE( 'real32' ) 3237 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3238 attribute_name=attribute%name, value_real32=attribute%value_real32, & 3239 return_value=output_return_value ) 3240 3241 CASE( 'real64' ) 3242 CALL netcdf4_write_attribute( file_id=file_id, variable_id=variable_id, & 3243 attribute_name=attribute%name, value_real64=attribute%value_real64, & 3244 return_value=output_return_value ) 3245 3246 CASE DEFAULT 3247 return_value = 1 3248 CALL internal_message( 'error', routine_name // & 3249 ': file format "' // TRIM( file_format ) // & 3250 '" does not support attribute data type "'// & 3251 TRIM( attribute%data_type ) // & 3252 '" ' // TRIM( temp_string ) ) 3253 3254 END SELECT 3255 3256 CASE DEFAULT 3257 return_value = 1 3258 CALL internal_message( 'error', routine_name // & 3259 ': unsupported file format "' // TRIM( file_format ) // & 3260 '" ' // TRIM( temp_string ) ) 3261 3262 END SELECT 3263 3264 IF ( output_return_value /= 0 ) THEN 3265 return_value = output_return_value 3266 CALL internal_message( 'error', routine_name // & 3267 ': error while writing attribute ' // TRIM( temp_string ) ) 3268 ENDIF 3269 3270 END FUNCTION write_attribute 3242 3271 3243 3272 !--------------------------------------------------------------------------------------------------! … … 3246 3275 !> Get dimension IDs and save them to variables. 3247 3276 !--------------------------------------------------------------------------------------------------! 3248 SUBROUTINE collect_dimesion_ids_for_variables( file_name, variables, dimensions, return_value )3249 3250 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file3251 3252 CHARACTER(LEN=*), PARAMETER :: routine_name = 'collect_dimesion_ids_for_variables' !< file format chosen for file3253 3254 INTEGER :: d !< loop index3255 INTEGER :: i !< loop index3256 INTEGER :: j !< loop index3257 INTEGER :: ndims !< number of dimensions3258 INTEGER :: nvars !< number of variables3259 INTEGER, INTENT(OUT) :: return_value !< return value3260 3261 LOGICAL :: found !< true if dimension required by variable was found in dimension list3262 3263 TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< list of dimensions in file3264 3265 TYPE(variable_type), DIMENSION(:), INTENT(INOUT) :: variables !< list of variables in file3266 3267 3268 return_value = 03269 ndims = SIZE( dimensions )3270 nvars = SIZE( variables )3271 3272 DO i = 1, nvars3273 DO j = 1, SIZE( variables(i)%dimension_names )3274 found = .FALSE.3275 DO d = 1, ndims3276 IF ( variables(i)%dimension_names(j) == dimensions(d)%name ) THEN3277 variables(i)%dimension_ids(j) = dimensions(d)%id3278 found = .TRUE.3279 EXIT3280 ENDIF3281 ENDDO3282 IF ( .NOT. found ) THEN3283 return_value = 13284 CALL internal_message( 'error', routine_name // &3285 ': required dimension "' // TRIM( variables(i)%dimension_names(j) ) // &3286 '" is undefined (variable "' // TRIM( variables(i)%name ) // &3287 '", file "' // TRIM( file_name ) // '")!' )3288 EXIT3289 ENDIF3290 ENDDO3291 IF ( .NOT. found ) EXIT3292 ENDDO3293 3294 END SUBROUTINE collect_dimesion_ids_for_variables3277 SUBROUTINE collect_dimesion_ids_for_variables( file_name, variables, dimensions, return_value ) 3278 3279 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 3280 3281 CHARACTER(LEN=*), PARAMETER :: routine_name = 'collect_dimesion_ids_for_variables' !< file format chosen for file 3282 3283 INTEGER :: d !< loop index 3284 INTEGER :: i !< loop index 3285 INTEGER :: j !< loop index 3286 INTEGER :: ndims !< number of dimensions 3287 INTEGER :: nvars !< number of variables 3288 INTEGER, INTENT(OUT) :: return_value !< return value 3289 3290 LOGICAL :: found !< true if dimension required by variable was found in dimension list 3291 3292 TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< list of dimensions in file 3293 3294 TYPE(variable_type), DIMENSION(:), INTENT(INOUT) :: variables !< list of variables in file 3295 3296 3297 return_value = 0 3298 ndims = SIZE( dimensions ) 3299 nvars = SIZE( variables ) 3300 3301 DO i = 1, nvars 3302 DO j = 1, SIZE( variables(i)%dimension_names ) 3303 found = .FALSE. 3304 DO d = 1, ndims 3305 IF ( variables(i)%dimension_names(j) == dimensions(d)%name ) THEN 3306 variables(i)%dimension_ids(j) = dimensions(d)%id 3307 found = .TRUE. 3308 EXIT 3309 ENDIF 3310 ENDDO 3311 IF ( .NOT. found ) THEN 3312 return_value = 1 3313 CALL internal_message( 'error', routine_name // & 3314 ': required dimension "' // TRIM( variables(i)%dimension_names(j) ) // & 3315 '" is undefined (variable "' // TRIM( variables(i)%name ) // & 3316 '", file "' // TRIM( file_name ) // '")!' ) 3317 EXIT 3318 ENDIF 3319 ENDDO 3320 IF ( .NOT. found ) EXIT 3321 ENDDO 3322 3323 END SUBROUTINE collect_dimesion_ids_for_variables 3295 3324 3296 3325 !--------------------------------------------------------------------------------------------------! … … 3301 3330 !> @todo Do we need an MPI barrier at the end? 3302 3331 !--------------------------------------------------------------------------------------------------! 3303 SUBROUTINE stop_file_header_definition( file_format, file_id, file_name, return_value )3304 3305 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format3306 CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name3307 3308 CHARACTER(LEN=*), PARAMETER :: routine_name = 'stop_file_header_definition' !< name of routine3309 3310 INTEGER, INTENT(IN) :: file_id !< file id3311 INTEGER :: output_return_value !< return value of a called output routine3312 INTEGER, INTENT(OUT) :: return_value !< return value3313 3314 3315 return_value = 03316 output_return_value = 03317 3318 temp_string = '(file "' // TRIM( file_name ) // '")'3319 3320 SELECT CASE ( TRIM( file_format ) )3321 3322 CASE ( 'binary' )3323 CALL binary_stop_file_header_definition( file_id, output_return_value )3324 3325 CASE ( 'netcdf4-parallel', 'netcdf4-serial' )3326 CALL netcdf4_stop_file_header_definition( file_id, output_return_value )3327 3328 CASE DEFAULT3329 return_value = 13330 CALL internal_message( 'error', routine_name // &3331 ': file format "' // TRIM( file_format ) // &3332 '" not supported ' // TRIM( temp_string ) )3333 3334 END SELECT3335 3336 IF ( output_return_value /= 0 ) THEN3337 return_value = output_return_value3338 CALL internal_message( 'error', routine_name // &3339 ': error while leaving file-definition state ' // &3340 TRIM( temp_string ) )3341 ENDIF3342 3343 ! CALL MPI_Barrier( MPI_COMM_WORLD, return_value )3344 3345 END SUBROUTINE stop_file_header_definition3332 SUBROUTINE stop_file_header_definition( file_format, file_id, file_name, return_value ) 3333 3334 CHARACTER(LEN=*), INTENT(IN) :: file_format !< file format 3335 CHARACTER(LEN=*), INTENT(IN) :: file_name !< file name 3336 3337 CHARACTER(LEN=*), PARAMETER :: routine_name = 'stop_file_header_definition' !< name of routine 3338 3339 INTEGER, INTENT(IN) :: file_id !< file id 3340 INTEGER :: output_return_value !< return value of a called output routine 3341 INTEGER, INTENT(OUT) :: return_value !< return value 3342 3343 3344 return_value = 0 3345 output_return_value = 0 3346 3347 temp_string = '(file "' // TRIM( file_name ) // '")' 3348 3349 SELECT CASE ( TRIM( file_format ) ) 3350 3351 CASE ( 'binary' ) 3352 CALL binary_stop_file_header_definition( file_id, output_return_value ) 3353 3354 CASE ( 'netcdf4-parallel', 'netcdf4-serial' ) 3355 CALL netcdf4_stop_file_header_definition( file_id, output_return_value ) 3356 3357 CASE DEFAULT 3358 return_value = 1 3359 CALL internal_message( 'error', routine_name // & 3360 ': file format "' // TRIM( file_format ) // & 3361 '" not supported ' // TRIM( temp_string ) ) 3362 3363 END SELECT 3364 3365 IF ( output_return_value /= 0 ) THEN 3366 return_value = output_return_value 3367 CALL internal_message( 'error', routine_name // & 3368 ': error while leaving file-definition state ' // & 3369 TRIM( temp_string ) ) 3370 ENDIF 3371 3372 ! CALL MPI_Barrier( MPI_COMM_WORLD, return_value ) 3373 3374 END SUBROUTINE stop_file_header_definition 3346 3375 3347 3376 !--------------------------------------------------------------------------------------------------! … … 3350 3379 !> Find a requested variable 'variable_name' and its used dimensions in requested file 'file_name'. 3351 3380 !--------------------------------------------------------------------------------------------------! 3352 SUBROUTINE find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, &3353 is_global, dimensions, return_value )3354 3355 CHARACTER(LEN=charlen), INTENT(OUT) :: file_format !< file format chosen for file3356 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file3357 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable3358 3359 CHARACTER(LEN=*), PARAMETER :: routine_name = 'find_var_in_file' !< name of routine3360 3361 INTEGER :: d !< loop index3362 INTEGER :: dd !< loop index3363 INTEGER :: f !< loop index3364 INTEGER, INTENT(OUT) :: file_id !< file ID3365 INTEGER, INTENT(OUT) :: return_value !< return value3366 INTEGER, INTENT(OUT) :: variable_id !< variable ID3367 3368 INTEGER, DIMENSION(:), ALLOCATABLE :: dimension_ids !< list of dimension IDs used by variable3369 3370 LOGICAL :: found !< true if requested variable found in requested file3371 LOGICAL, INTENT(OUT) :: is_global !< true if variable is global3372 3373 TYPE(dimension_type), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dimensions !< list of dimensions used by variable3374 3375 3376 return_value = 03377 found = .FALSE.3378 3379 DO f = 1, nfiles3380 IF ( TRIM( file_name ) == TRIM( files(f)%name ) ) THEN3381 3382 IF ( .NOT. files(f)%is_init ) THEN3383 return_value = 13384 CALL internal_message( 'error', routine_name // &3385 ': file not initialized. ' // &3386 'Writing variable to file is impossible ' // &3387 '(variable "' // TRIM( variable_name ) // &3388 '", file "' // TRIM( file_name ) // '")!' )3389 EXIT3390 ENDIF3391 3392 file_id = files(f)%id3393 file_format = files(f)%format3394 3395 !--Search for variable in file3396 DO d = 1, SIZE( files(f)%variables )3397 IF ( TRIM( variable_name ) == TRIM( files(f)%variables(d)%name ) ) THEN3398 3399 variable_id = files(f)%variables(d)%id3400 is_global = files(f)%variables(d)%is_global3401 3402 ALLOCATE( dimension_ids(SIZE( files(f)%variables(d)%dimension_ids )) )3403 ALLOCATE( dimensions(SIZE( files(f)%variables(d)%dimension_ids )) )3404 3405 dimension_ids = files(f)%variables(d)%dimension_ids3406 3407 found = .TRUE.3408 EXIT3409 3410 ENDIF3411 ENDDO3412 3413 IF ( found ) THEN3414 3415 !--Get list of dimensions used by variable3416 DO d = 1, SIZE( files(f)%dimensions )3417 DO dd = 1, SIZE( dimension_ids )3418 IF ( dimension_ids(dd) == files(f)%dimensions(d)%id ) THEN3419 dimensions(dd) = files(f)%dimensions(d)3420 EXIT3421 ENDIF3422 ENDDO3423 ENDDO3424 3425 ELSE3426 3427 !--If variable was not found, search for a dimension instead3428 DO d = 1, SIZE( files(f)%dimensions )3429 IF ( TRIM( variable_name ) == TRIM( files(f)%dimensions(d)%name ) ) THEN3430 3431 variable_id = files(f)%dimensions(d)%variable_id3432 is_global = .TRUE.3433 3434 ALLOCATE( dimensions(1) )3435 3436 dimensions(1) = files(f)%dimensions(d)3437 3438 found = .TRUE.3439 EXIT3440 3441 ENDIF3442 ENDDO3443 3444 ENDIF3445 3446 !--If variable was not found in requested file, return an error3447 IF ( .NOT. found ) THEN3448 return_value = 13449 CALL internal_message( 'error', routine_name // &3450 ': variable not found in file ' // &3451 '(variable "' // TRIM( variable_name ) // &3452 '", file "' // TRIM( file_name ) // '")!' )3453 ENDIF3454 3455 EXIT3456 3457 ENDIF ! file found3458 ENDDO ! loop over files3459 3460 IF ( .NOT. found .AND. return_value == 0 ) THEN3461 return_value = 13462 CALL internal_message( 'error', routine_name // &3463 ': file not found ' // &3464 '(variable "' // TRIM( variable_name ) // &3465 '", file "' // TRIM( file_name ) // '")!' )3466 ENDIF3467 3468 END SUBROUTINE find_var_in_file3381 SUBROUTINE find_var_in_file( file_name, variable_name, file_format, file_id, variable_id, & 3382 is_global, dimensions, return_value ) 3383 3384 CHARACTER(LEN=charlen), INTENT(OUT) :: file_format !< file format chosen for file 3385 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file 3386 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable 3387 3388 CHARACTER(LEN=*), PARAMETER :: routine_name = 'find_var_in_file' !< name of routine 3389 3390 INTEGER :: d !< loop index 3391 INTEGER :: dd !< loop index 3392 INTEGER :: f !< loop index 3393 INTEGER, INTENT(OUT) :: file_id !< file ID 3394 INTEGER, INTENT(OUT) :: return_value !< return value 3395 INTEGER, INTENT(OUT) :: variable_id !< variable ID 3396 3397 INTEGER, DIMENSION(:), ALLOCATABLE :: dimension_ids !< list of dimension IDs used by variable 3398 3399 LOGICAL :: found !< true if requested variable found in requested file 3400 LOGICAL, INTENT(OUT) :: is_global !< true if variable is global 3401 3402 TYPE(dimension_type), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dimensions !< list of dimensions used by variable 3403 3404 3405 return_value = 0 3406 found = .FALSE. 3407 3408 DO f = 1, nfiles 3409 IF ( TRIM( file_name ) == TRIM( files(f)%name ) ) THEN 3410 3411 IF ( .NOT. files(f)%is_init ) THEN 3412 return_value = 1 3413 CALL internal_message( 'error', routine_name // & 3414 ': file not initialized. ' // & 3415 'Writing variable to file is impossible ' // & 3416 '(variable "' // TRIM( variable_name ) // & 3417 '", file "' // TRIM( file_name ) // '")!' ) 3418 EXIT 3419 ENDIF 3420 3421 file_id = files(f)%id 3422 file_format = files(f)%format 3423 ! 3424 !-- Search for variable in file 3425 DO d = 1, SIZE( files(f)%variables ) 3426 IF ( TRIM( variable_name ) == TRIM( files(f)%variables(d)%name ) ) THEN 3427 3428 variable_id = files(f)%variables(d)%id 3429 is_global = files(f)%variables(d)%is_global 3430 3431 ALLOCATE( dimension_ids(SIZE( files(f)%variables(d)%dimension_ids )) ) 3432 ALLOCATE( dimensions(SIZE( files(f)%variables(d)%dimension_ids )) ) 3433 3434 dimension_ids = files(f)%variables(d)%dimension_ids 3435 3436 found = .TRUE. 3437 EXIT 3438 3439 ENDIF 3440 ENDDO 3441 3442 IF ( found ) THEN 3443 ! 3444 !-- Get list of dimensions used by variable 3445 DO d = 1, SIZE( files(f)%dimensions ) 3446 DO dd = 1, SIZE( dimension_ids ) 3447 IF ( dimension_ids(dd) == files(f)%dimensions(d)%id ) THEN 3448 dimensions(dd) = files(f)%dimensions(d) 3449 EXIT 3450 ENDIF 3451 ENDDO 3452 ENDDO 3453 3454 ELSE 3455 ! 3456 !-- If variable was not found, search for a dimension instead 3457 DO d = 1, SIZE( files(f)%dimensions ) 3458 IF ( TRIM( variable_name ) == TRIM( files(f)%dimensions(d)%name ) ) THEN 3459 3460 variable_id = files(f)%dimensions(d)%variable_id 3461 is_global = .TRUE. 3462 3463 ALLOCATE( dimensions(1) ) 3464 3465 dimensions(1) = files(f)%dimensions(d) 3466 3467 found = .TRUE. 3468 EXIT 3469 3470 ENDIF 3471 ENDDO 3472 3473 ENDIF 3474 ! 3475 !-- If variable was not found in requested file, return an error 3476 IF ( .NOT. found ) THEN 3477 return_value = 1 3478 CALL internal_message( 'error', routine_name // & 3479 ': variable not found in file ' // & 3480 '(variable "' // TRIM( variable_name ) // & 3481 '", file "' // TRIM( file_name ) // '")!' ) 3482 ENDIF 3483 3484 EXIT 3485 3486 ENDIF ! file found 3487 ENDDO ! loop over files 3488 3489 IF ( .NOT. found .AND. return_value == 0 ) THEN 3490 return_value = 1 3491 CALL internal_message( 'error', routine_name // & 3492 ': file not found ' // & 3493 '(variable "' // TRIM( variable_name ) // & 3494 '", file "' // TRIM( file_name ) // '")!' ) 3495 ENDIF 3496 3497 END SUBROUTINE find_var_in_file 3469 3498 3470 3499 !--------------------------------------------------------------------------------------------------! … … 3478 3507 !> starts and origins are set to zero for all dimensions. 3479 3508 !--------------------------------------------------------------------------------------------------! 3480 SUBROUTINE get_masked_indices_and_masked_dimension_bounds( &3481 dimensions, bounds_start, bounds_end, bounds_masked_start, value_counts, &3482 bounds_origin, masked_indices )3483 3484 ! CHARACTER(LEN=*), PARAMETER :: routine_name = 'get_masked_indices_and_masked_dimension_bounds' !< name of routine3485 3486 INTEGER :: d !< loop index3487 INTEGER :: i !< loop index3488 3489 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_end !< upper bonuds to be searched in3490 INTEGER, DIMENSION(:), INTENT(OUT) :: bounds_masked_start !< lower bounds of masked dimensions within given bounds3491 INTEGER, DIMENSION(:), INTENT(OUT) :: bounds_origin !< first index of each dimension, 0 if dimension is masked3492 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_start !< lower bounds to be searched in3493 INTEGER, DIMENSION(:), INTENT(OUT) :: value_counts !< count of indices per dimension to be output3494 3495 INTEGER, DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: masked_indices !< masked indices within given bounds3496 3497 TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< dimensions to be searched for masked indices3498 3499 3500 ALLOCATE( masked_indices(SIZE( dimensions ),0:MAXVAL( bounds_end - bounds_start + 1 )) )3501 masked_indices = -HUGE( 0 )3502 3503 3504 DO d = 1, SIZE( dimensions )3505 3506 IF ( dimensions(d)%is_masked ) THEN3507 3508 bounds_origin(d) = 03509 3510 bounds_masked_start(d) = -HUGE( 0 )3511 3512 !--Find number of masked values within given variable bounds3513 value_counts(d) = 03514 DO i = LBOUND( dimensions(d)%masked_indices, DIM=1 ), &3515 UBOUND( dimensions(d)%masked_indices, DIM=1 )3516 3517 !--Is masked index within given bounds?3518 IF ( dimensions(d)%masked_indices(i) >= bounds_start(d) .AND. &3519 dimensions(d)%masked_indices(i) <= bounds_end(d) ) THEN3520 3521 !--Save masked index3522 masked_indices(d,value_counts(d)) = dimensions(d)%masked_indices(i)3523 value_counts(d) = value_counts(d) + 13524 3525 !--Save bounds of mask within given bounds3526 IF ( bounds_masked_start(d) == -HUGE( 0 ) ) bounds_masked_start(d) = i3527 3528 ENDIF3529 3530 ENDDO3531 3532 !--Set masked bounds to zero if no masked index lies within bounds3533 IF ( value_counts(d) == 0 ) THEN3534 bounds_origin(:) = 03535 bounds_masked_start(:) = 03536 value_counts(:) = 03537 EXIT3538 ENDIF3539 3540 ELSE3541 3542 !--If dimension is not masked, save all indices within bounds for output3543 bounds_origin(d) = dimensions(d)%bounds(1)3544 bounds_masked_start(d) = bounds_start(d)3545 value_counts(d) = bounds_end(d) - bounds_start(d) + 13546 3547 DO i = 0, value_counts(d) - 13548 masked_indices(d,i) = bounds_start(d) + i3549 ENDDO3550 3551 ENDIF3552 3553 ENDDO3554 3555 END SUBROUTINE get_masked_indices_and_masked_dimension_bounds3509 SUBROUTINE get_masked_indices_and_masked_dimension_bounds( & 3510 dimensions, bounds_start, bounds_end, bounds_masked_start, value_counts, & 3511 bounds_origin, masked_indices ) 3512 3513 ! CHARACTER(LEN=*), PARAMETER :: routine_name = 'get_masked_indices_and_masked_dimension_bounds' !< name of routine 3514 3515 INTEGER :: d !< loop index 3516 INTEGER :: i !< loop index 3517 3518 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_end !< upper bonuds to be searched in 3519 INTEGER, DIMENSION(:), INTENT(OUT) :: bounds_masked_start !< lower bounds of masked dimensions within given bounds 3520 INTEGER, DIMENSION(:), INTENT(OUT) :: bounds_origin !< first index of each dimension, 0 if dimension is masked 3521 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_start !< lower bounds to be searched in 3522 INTEGER, DIMENSION(:), INTENT(OUT) :: value_counts !< count of indices per dimension to be output 3523 3524 INTEGER, DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: masked_indices !< masked indices within given bounds 3525 3526 TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< dimensions to be searched for masked indices 3527 3528 3529 ALLOCATE( masked_indices(SIZE( dimensions ),0:MAXVAL( bounds_end - bounds_start + 1 )) ) 3530 masked_indices = -HUGE( 0 ) 3531 ! 3532 !-- Check for masking and update lower and upper bounds if masked 3533 DO d = 1, SIZE( dimensions ) 3534 3535 IF ( dimensions(d)%is_masked ) THEN 3536 3537 bounds_origin(d) = 0 3538 3539 bounds_masked_start(d) = -HUGE( 0 ) 3540 ! 3541 !-- Find number of masked values within given variable bounds 3542 value_counts(d) = 0 3543 DO i = LBOUND( dimensions(d)%masked_indices, DIM=1 ), & 3544 UBOUND( dimensions(d)%masked_indices, DIM=1 ) 3545 ! 3546 !-- Is masked index within given bounds? 3547 IF ( dimensions(d)%masked_indices(i) >= bounds_start(d) .AND. & 3548 dimensions(d)%masked_indices(i) <= bounds_end(d) ) THEN 3549 ! 3550 !-- Save masked index 3551 masked_indices(d,value_counts(d)) = dimensions(d)%masked_indices(i) 3552 value_counts(d) = value_counts(d) + 1 3553 ! 3554 !-- Save bounds of mask within given bounds 3555 IF ( bounds_masked_start(d) == -HUGE( 0 ) ) bounds_masked_start(d) = i 3556 3557 ENDIF 3558 3559 ENDDO 3560 ! 3561 !-- Set masked bounds to zero if no masked index lies within bounds 3562 IF ( value_counts(d) == 0 ) THEN 3563 bounds_origin(:) = 0 3564 bounds_masked_start(:) = 0 3565 value_counts(:) = 0 3566 EXIT 3567 ENDIF 3568 3569 ELSE 3570 ! 3571 !-- If dimension is not masked, save all indices within bounds for output 3572 bounds_origin(d) = dimensions(d)%bounds(1) 3573 bounds_masked_start(d) = bounds_start(d) 3574 value_counts(d) = bounds_end(d) - bounds_start(d) + 1 3575 3576 DO i = 0, value_counts(d) - 1 3577 masked_indices(d,i) = bounds_start(d) + i 3578 ENDDO 3579 3580 ENDIF 3581 3582 ENDDO 3583 3584 END SUBROUTINE get_masked_indices_and_masked_dimension_bounds 3556 3585 3557 3586 !--------------------------------------------------------------------------------------------------! … … 3561 3590 !> or creating the error message string. 3562 3591 !--------------------------------------------------------------------------------------------------! 3563 SUBROUTINE internal_message( level, string )3564 3565 CHARACTER(LEN=*), INTENT(IN) :: level !< message importance level3566 CHARACTER(LEN=*), INTENT(IN) :: string !< message string3567 3568 3569 IF ( TRIM( level ) == 'error' ) THEN3570 3571 WRITE( internal_error_message, '(A,A)' ) 'DOM ERROR: ', string3572 3573 ELSEIF ( TRIM( level ) == 'debug' .AND. print_debug_output ) THEN3574 3575 WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string3576 FLUSH( debug_output_unit )3577 3578 ENDIF3579 3580 END SUBROUTINE internal_message3592 SUBROUTINE internal_message( level, string ) 3593 3594 CHARACTER(LEN=*), INTENT(IN) :: level !< message importance level 3595 CHARACTER(LEN=*), INTENT(IN) :: string !< message string 3596 3597 3598 IF ( TRIM( level ) == 'error' ) THEN 3599 3600 WRITE( internal_error_message, '(A,A)' ) 'DOM ERROR: ', string 3601 3602 ELSEIF ( TRIM( level ) == 'debug' .AND. print_debug_output ) THEN 3603 3604 WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string 3605 FLUSH( debug_output_unit ) 3606 3607 ENDIF 3608 3609 END SUBROUTINE internal_message 3581 3610 3582 3611 !--------------------------------------------------------------------------------------------------! … … 3586 3615 !> stage after the call to 'dom_init'. Multiple calls are possible. 3587 3616 !--------------------------------------------------------------------------------------------------! 3588 SUBROUTINE dom_database_debug_output3589 3590 CHARACTER(LEN=*), PARAMETER :: separation_string = '---' !< string separating blocks in output3591 CHARACTER(LEN=50) :: write_format1 !< format for write statements3592 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_database_debug_output' !< name of this routine3593 3594 INTEGER :: f !< loop index3595 INTEGER, PARAMETER :: indent_depth = 3 !< space per indentation3596 INTEGER :: indent_level !< indentation level3597 INTEGER, PARAMETER :: max_keyname_length = 6 !< length of longest key name3598 INTEGER :: natts !< number of attributes3599 INTEGER :: ndims !< number of dimensions3600 INTEGER :: nvars !< number of variables3601 3602 3603 CALL internal_message( 'debug', routine_name // ': write database to debug output' )3604 3605 WRITE( debug_output_unit, '(A)' ) 'DOM database:'3606 WRITE( debug_output_unit, '(A)' ) REPEAT( separation_string // ' ', 4 )3607 3608 IF ( .NOT. ALLOCATED( files ) .OR. nfiles == 0 ) THEN3609 3610 WRITE( debug_output_unit, '(A)' ) 'database is empty'3611 3612 ELSE3613 3614 indent_level = 13615 WRITE( write_format1, '(A,I3,A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A,T', &3616 indent_level * indent_depth + 1 + max_keyname_length, &3617 ',(": ")'3618 3619 DO f = 1, nfiles3620 3621 natts = 03622 ndims = 03623 nvars = 03624 IF ( ALLOCATED( files(f)%attributes ) ) natts = SIZE( files(f)%attributes )3625 IF ( ALLOCATED( files(f)%dimensions ) ) ndims = SIZE( files(f)%dimensions )3626 IF ( ALLOCATED( files(f)%variables ) ) nvars = SIZE( files(f)%variables )3627 3628 WRITE( debug_output_unit, '(A)' ) 'file:'3629 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) 'name', TRIM( files(f)%name )3630 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) 'format', TRIM(files(f)%format)3631 WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) 'id', files(f)%id3632 WRITE( debug_output_unit, TRIM( write_format1 ) // ',L1)' ) 'is init', files(f)%is_init3633 WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#atts', natts3634 WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#dims', ndims3635 WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#vars', nvars3636 3637 IF ( natts /= 0 ) CALL print_attributes( indent_level, files(f)%attributes )3638 IF ( ndims /= 0 ) CALL print_dimensions( indent_level, files(f)%dimensions )3639 IF ( nvars /= 0 ) CALL print_variables( indent_level, files(f)%variables )3640 3641 WRITE( debug_output_unit, '(/A/)' ) REPEAT( separation_string // ' ', 4 )3642 3643 ENDDO3644 3645 ENDIF3646 3647 CONTAINS3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 !--Print general information3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 !--Print information about mask3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 !--Print saved values3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 END SUBROUTINE dom_database_debug_output3986 3987 END MODULE data_output_module3617 SUBROUTINE dom_database_debug_output 3618 3619 CHARACTER(LEN=*), PARAMETER :: separation_string = '---' !< string separating blocks in output 3620 CHARACTER(LEN=50) :: write_format1 !< format for write statements 3621 CHARACTER(LEN=*), PARAMETER :: routine_name = 'dom_database_debug_output' !< name of this routine 3622 3623 INTEGER :: f !< loop index 3624 INTEGER, PARAMETER :: indent_depth = 3 !< space per indentation 3625 INTEGER :: indent_level !< indentation level 3626 INTEGER, PARAMETER :: max_keyname_length = 6 !< length of longest key name 3627 INTEGER :: natts !< number of attributes 3628 INTEGER :: ndims !< number of dimensions 3629 INTEGER :: nvars !< number of variables 3630 3631 3632 CALL internal_message( 'debug', routine_name // ': write database to debug output' ) 3633 3634 WRITE( debug_output_unit, '(A)' ) 'DOM database:' 3635 WRITE( debug_output_unit, '(A)' ) REPEAT( separation_string // ' ', 4 ) 3636 3637 IF ( .NOT. ALLOCATED( files ) .OR. nfiles == 0 ) THEN 3638 3639 WRITE( debug_output_unit, '(A)' ) 'database is empty' 3640 3641 ELSE 3642 3643 indent_level = 1 3644 WRITE( write_format1, '(A,I3,A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A,T', & 3645 indent_level * indent_depth + 1 + max_keyname_length, & 3646 ',(": ")' 3647 3648 DO f = 1, nfiles 3649 3650 natts = 0 3651 ndims = 0 3652 nvars = 0 3653 IF ( ALLOCATED( files(f)%attributes ) ) natts = SIZE( files(f)%attributes ) 3654 IF ( ALLOCATED( files(f)%dimensions ) ) ndims = SIZE( files(f)%dimensions ) 3655 IF ( ALLOCATED( files(f)%variables ) ) nvars = SIZE( files(f)%variables ) 3656 3657 WRITE( debug_output_unit, '(A)' ) 'file:' 3658 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) 'name', TRIM( files(f)%name ) 3659 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) 'format', TRIM(files(f)%format) 3660 WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) 'id', files(f)%id 3661 WRITE( debug_output_unit, TRIM( write_format1 ) // ',L1)' ) 'is init', files(f)%is_init 3662 WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#atts', natts 3663 WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#dims', ndims 3664 WRITE( debug_output_unit, TRIM( write_format1 ) // ',I7)' ) '#vars', nvars 3665 3666 IF ( natts /= 0 ) CALL print_attributes( indent_level, files(f)%attributes ) 3667 IF ( ndims /= 0 ) CALL print_dimensions( indent_level, files(f)%dimensions ) 3668 IF ( nvars /= 0 ) CALL print_variables( indent_level, files(f)%variables ) 3669 3670 WRITE( debug_output_unit, '(/A/)' ) REPEAT( separation_string // ' ', 4 ) 3671 3672 ENDDO 3673 3674 ENDIF 3675 3676 CONTAINS 3677 3678 !--------------------------------------------------------------------------------------------! 3679 ! Description: 3680 ! ------------ 3681 !> Print list of attributes. 3682 !--------------------------------------------------------------------------------------------! 3683 SUBROUTINE print_attributes( indent_level, attributes ) 3684 3685 CHARACTER(LEN=50) :: write_format1 !< format for write statements 3686 CHARACTER(LEN=50) :: write_format2 !< format for write statements 3687 3688 INTEGER :: i !< loop index 3689 INTEGER, INTENT(IN) :: indent_level !< indentation level 3690 INTEGER, PARAMETER :: max_keyname_length = 6 !< length of longest key name 3691 INTEGER :: nelement !< number of elements to print 3692 3693 TYPE(attribute_type), DIMENSION(:), INTENT(IN) :: attributes !< list of attributes 3694 3695 3696 WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A' 3697 WRITE( write_format2, '(A,I3,A,I3,A)' ) & 3698 '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', & 3699 ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")' 3700 3701 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) & 3702 REPEAT( separation_string // ' ', 4 ) 3703 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'attributes:' 3704 3705 nelement = SIZE( attributes ) 3706 DO i = 1, nelement 3707 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3708 'name', TRIM( attributes(i)%name ) 3709 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3710 'type', TRIM( attributes(i)%data_type ) 3711 3712 IF ( TRIM( attributes(i)%data_type ) == 'char' ) THEN 3713 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3714 'value', TRIM( attributes(i)%value_char ) 3715 ELSEIF ( TRIM( attributes(i)%data_type ) == 'int8' ) THEN 3716 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)' ) & 3717 'value', attributes(i)%value_int8 3718 ELSEIF ( TRIM( attributes(i)%data_type ) == 'int16' ) THEN 3719 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)' ) & 3720 'value', attributes(i)%value_int16 3721 ELSEIF ( TRIM( attributes(i)%data_type ) == 'int32' ) THEN 3722 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)' ) & 3723 'value', attributes(i)%value_int32 3724 ELSEIF ( TRIM( attributes(i)%data_type ) == 'real32' ) THEN 3725 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)' ) & 3726 'value', attributes(i)%value_real32 3727 ELSEIF ( TRIM(attributes(i)%data_type) == 'real64' ) THEN 3728 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)' ) & 3729 'value', attributes(i)%value_real64 3730 ENDIF 3731 IF ( i < nelement ) & 3732 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string 3733 ENDDO 3734 3735 END SUBROUTINE print_attributes 3736 3737 !--------------------------------------------------------------------------------------------! 3738 ! Description: 3739 ! ------------ 3740 !> Print list of dimensions. 3741 !--------------------------------------------------------------------------------------------! 3742 SUBROUTINE print_dimensions( indent_level, dimensions ) 3743 3744 CHARACTER(LEN=50) :: write_format1 !< format for write statements 3745 CHARACTER(LEN=50) :: write_format2 !< format for write statements 3746 3747 INTEGER :: i !< loop index 3748 INTEGER, INTENT(IN) :: indent_level !< indentation level 3749 INTEGER :: j !< loop index 3750 INTEGER, PARAMETER :: max_keyname_length = 15 !< length of longest key name 3751 INTEGER :: nelement !< number of elements to print 3752 3753 LOGICAL :: is_masked !< true if dimension is masked 3754 3755 TYPE(dimension_type), DIMENSION(:), INTENT(IN) :: dimensions !< list of dimensions 3756 3757 3758 WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A' 3759 WRITE( write_format2, '(A,I3,A,I3,A)' ) & 3760 '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', & 3761 ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")' 3762 3763 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) & 3764 REPEAT( separation_string // ' ', 4 ) 3765 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'dimensions:' 3766 3767 nelement = SIZE( dimensions ) 3768 DO i = 1, nelement 3769 is_masked = dimensions(i)%is_masked 3770 ! 3771 !-- Print general information 3772 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3773 'name', TRIM( dimensions(i)%name ) 3774 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3775 'type', TRIM( dimensions(i)%data_type ) 3776 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) & 3777 'id', dimensions(i)%id 3778 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) & 3779 'length', dimensions(i)%length 3780 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7,A,I7)' ) & 3781 'bounds', dimensions(i)%bounds(1), ',', dimensions(i)%bounds(2) 3782 WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)' ) & 3783 'is masked', dimensions(i)%is_masked 3784 ! 3785 !-- Print information about mask 3786 IF ( is_masked ) THEN 3787 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) & 3788 'masked length', dimensions(i)%length_mask 3789 3790 WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)', ADVANCE='no' ) & 3791 'mask', dimensions(i)%mask(dimensions(i)%bounds(1)) 3792 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3793 WRITE( debug_output_unit, '(A,L1)', ADVANCE='no' ) ',', dimensions(i)%mask(j) 3794 ENDDO 3795 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3796 3797 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) & 3798 'masked indices', dimensions(i)%masked_indices(0) 3799 DO j = 1, dimensions(i)%length_mask-1 3800 WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) & 3801 ',', dimensions(i)%masked_indices(j) 3802 ENDDO 3803 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3804 ENDIF 3805 ! 3806 !-- Print saved values 3807 IF ( ALLOCATED( dimensions(i)%values_int8 ) ) THEN 3808 3809 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)', ADVANCE='no' ) & 3810 'values', dimensions(i)%values_int8(dimensions(i)%bounds(1)) 3811 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3812 WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) & 3813 ',', dimensions(i)%values_int8(j) 3814 ENDDO 3815 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3816 IF ( is_masked ) THEN 3817 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I4)', ADVANCE='no' ) & 3818 'masked values', dimensions(i)%masked_values_int8(0) 3819 DO j = 1, dimensions(i)%length_mask-1 3820 WRITE( debug_output_unit, '(A,I4)', ADVANCE='no' ) & 3821 ',', dimensions(i)%masked_values_int8(j) 3822 ENDDO 3823 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3824 ENDIF 3825 3826 ELSEIF ( ALLOCATED( dimensions(i)%values_int16 ) ) THEN 3827 3828 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) & 3829 'values', dimensions(i)%values_int16(dimensions(i)%bounds(1)) 3830 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3831 WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) & 3832 ',', dimensions(i)%values_int16(j) 3833 ENDDO 3834 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3835 IF ( is_masked ) THEN 3836 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I6)', ADVANCE='no' ) & 3837 'masked values', dimensions(i)%masked_values_int16(0) 3838 DO j = 1, dimensions(i)%length_mask-1 3839 WRITE( debug_output_unit, '(A,I6)', ADVANCE='no' ) & 3840 ',', dimensions(i)%masked_values_int16(j) 3841 ENDDO 3842 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3843 ENDIF 3844 3845 ELSEIF ( ALLOCATED( dimensions(i)%values_int32 ) ) THEN 3846 3847 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) & 3848 'values', dimensions(i)%values_int32(dimensions(i)%bounds(1)) 3849 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3850 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) & 3851 ',', dimensions(i)%values_int32(j) 3852 ENDDO 3853 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3854 IF ( is_masked ) THEN 3855 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) & 3856 'masked values', dimensions(i)%masked_values_int32(0) 3857 DO j = 1, dimensions(i)%length_mask-1 3858 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) & 3859 ',', dimensions(i)%masked_values_int32(j) 3860 ENDDO 3861 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3862 ENDIF 3863 3864 ELSEIF ( ALLOCATED( dimensions(i)%values_intwp ) ) THEN 3865 3866 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) & 3867 'values', dimensions(i)%values_intwp(dimensions(i)%bounds(1)) 3868 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3869 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) & 3870 ',', dimensions(i)%values_intwp(j) 3871 ENDDO 3872 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3873 IF ( is_masked ) THEN 3874 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I11)', ADVANCE='no' ) & 3875 'masked values', dimensions(i)%masked_values_intwp(0) 3876 DO j = 1, dimensions(i)%length_mask-1 3877 WRITE( debug_output_unit, '(A,I11)', ADVANCE='no' ) & 3878 ',', dimensions(i)%masked_values_intwp(j) 3879 ENDDO 3880 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3881 ENDIF 3882 3883 ELSEIF ( ALLOCATED( dimensions(i)%values_real32 ) ) THEN 3884 3885 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)', ADVANCE='no' ) & 3886 'values', dimensions(i)%values_real32(dimensions(i)%bounds(1)) 3887 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3888 WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) & 3889 ',', dimensions(i)%values_real32(j) 3890 ENDDO 3891 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3892 IF ( is_masked ) THEN 3893 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E14.7)', ADVANCE='no' ) & 3894 'masked values', dimensions(i)%masked_values_real32(0) 3895 DO j = 1, dimensions(i)%length_mask-1 3896 WRITE( debug_output_unit, '(A,E14.7)', ADVANCE='no' ) & 3897 ',', dimensions(i)%masked_values_real32(j) 3898 ENDDO 3899 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3900 ENDIF 3901 3902 ELSEIF ( ALLOCATED( dimensions(i)%values_real64 ) ) THEN 3903 3904 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) & 3905 'values', dimensions(i)%values_real64(dimensions(i)%bounds(1)) 3906 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3907 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) & 3908 ',', dimensions(i)%values_real64(j) 3909 ENDDO 3910 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3911 IF ( is_masked ) THEN 3912 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) & 3913 'masked values', dimensions(i)%masked_values_real64(0) 3914 DO j = 1, dimensions(i)%length_mask-1 3915 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) & 3916 ',', dimensions(i)%masked_values_real64(j) 3917 ENDDO 3918 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3919 ENDIF 3920 3921 ELSEIF ( ALLOCATED( dimensions(i)%values_realwp ) ) THEN 3922 3923 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) & 3924 'values', dimensions(i)%values_realwp(dimensions(i)%bounds(1)) 3925 DO j = dimensions(i)%bounds(1)+1, dimensions(i)%bounds(2) 3926 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) & 3927 ',', dimensions(i)%values_realwp(j) 3928 ENDDO 3929 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3930 IF ( is_masked ) THEN 3931 WRITE( debug_output_unit, TRIM( write_format2 ) // ',E22.15)', ADVANCE='no' ) & 3932 'masked values', dimensions(i)%masked_values_realwp(0) 3933 DO j = 1, dimensions(i)%length_mask-1 3934 WRITE( debug_output_unit, '(A,E22.15)', ADVANCE='no' ) & 3935 ',', dimensions(i)%masked_values_realwp(j) 3936 ENDDO 3937 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3938 ENDIF 3939 3940 ENDIF 3941 3942 IF ( ALLOCATED( dimensions(i)%attributes ) ) & 3943 CALL print_attributes( indent_level+1, dimensions(i)%attributes ) 3944 3945 IF ( i < nelement ) & 3946 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string 3947 ENDDO 3948 3949 END SUBROUTINE print_dimensions 3950 3951 !--------------------------------------------------------------------------------------------! 3952 ! Description: 3953 ! ------------ 3954 !> Print list of variables. 3955 !--------------------------------------------------------------------------------------------! 3956 SUBROUTINE print_variables( indent_level, variables ) 3957 3958 CHARACTER(LEN=50) :: write_format1 !< format for write statements 3959 CHARACTER(LEN=50) :: write_format2 !< format for write statements 3960 3961 INTEGER :: i !< loop index 3962 INTEGER, INTENT(IN) :: indent_level !< indentation level 3963 INTEGER :: j !< loop index 3964 INTEGER, PARAMETER :: max_keyname_length = 16 !< length of longest key name 3965 INTEGER :: nelement !< number of elements to print 3966 3967 TYPE(variable_type), DIMENSION(:), INTENT(IN) :: variables !< list of variables 3968 3969 3970 WRITE( write_format1, '(A,I3,A)' ) '(T', indent_level * indent_depth + 1, ',A' 3971 WRITE( write_format2, '(A,I3,A,I3,A)' ) & 3972 '(T', ( indent_level + 1 ) * indent_depth + 1, ',A,T', & 3973 ( indent_level + 1 ) * indent_depth + 1 + max_keyname_length, ',(": ")' 3974 3975 WRITE( debug_output_unit, TRIM( write_format1 ) // ',A)' ) & 3976 REPEAT( separation_string // ' ', 4 ) 3977 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) 'variables:' 3978 3979 nelement = SIZE( variables ) 3980 DO i = 1, nelement 3981 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3982 'name', TRIM( variables(i)%name ) 3983 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)' ) & 3984 'type', TRIM( variables(i)%data_type ) 3985 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)' ) & 3986 'id', variables(i)%id 3987 WRITE( debug_output_unit, TRIM( write_format2 ) // ',L1)' ) & 3988 'is global', variables(i)%is_global 3989 3990 WRITE( debug_output_unit, TRIM( write_format2 ) // ',A)', ADVANCE='no' ) & 3991 'dimension names', TRIM( variables(i)%dimension_names(1) ) 3992 DO j = 2, SIZE( variables(i)%dimension_names ) 3993 WRITE( debug_output_unit, '(A,A)', ADVANCE='no' ) & 3994 ',', TRIM( variables(i)%dimension_names(j) ) 3995 ENDDO 3996 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 3997 3998 WRITE( debug_output_unit, TRIM( write_format2 ) // ',I7)', ADVANCE='no' ) & 3999 'dimension ids', variables(i)%dimension_ids(1) 4000 DO j = 2, SIZE( variables(i)%dimension_names ) 4001 WRITE( debug_output_unit, '(A,I7)', ADVANCE='no' ) & 4002 ',', variables(i)%dimension_ids(j) 4003 ENDDO 4004 WRITE( debug_output_unit, '(A)' ) '' ! write line-end 4005 4006 IF ( ALLOCATED( variables(i)%attributes ) ) & 4007 CALL print_attributes( indent_level+1, variables(i)%attributes ) 4008 IF ( i < nelement ) & 4009 WRITE( debug_output_unit, TRIM( write_format1 ) // ')' ) separation_string 4010 ENDDO 4011 4012 END SUBROUTINE print_variables 4013 4014 END SUBROUTINE dom_database_debug_output 4015 4016 END MODULE data_output_module
Note: See TracChangeset
for help on using the changeset viewer.