Changeset 4597 for palm/trunk/SOURCE/data_output_binary_module.f90
- Timestamp:
- Jul 9, 2020 7:21:53 PM (4 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/data_output_binary_module.f90 (modified) (26 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/data_output_binary_module.f90
r4579 r4597 24 24 ! ----------------- 25 25 ! $Id$ 26 ! change: update argument list of routine binary_init_dimension due to changes in interface 27 ! 28 ! 4579 2020-06-25 20:05:07Z gronemeier 26 29 ! corrected formatting to follow PALM coding standard 27 30 ! … … 68 71 INCLUDE "mpif.h" 69 72 #endif 70 71 73 72 74 CHARACTER(LEN=*), PARAMETER :: config_file_name = 'BINARY_TO_NETCDF_CONFIG' !< name of config file … … 88 90 INTEGER :: output_group_comm !< MPI communicator addressing all MPI ranks which participate in output 89 91 90 INTEGER, DIMENSION(:), ALLOCATABLE :: files_highest_variable_id !< highest assigned ID of 91 !< variable or dimension in a file 92 93 LOGICAL :: binary_open_file_first_call = .TRUE. !< true if binary_open_file routine was not 94 !< called yet 95 LOGICAL :: config_file_open = .FALSE. !< true if config file is opened and not 96 !< closed 92 INTEGER, DIMENSION(:), ALLOCATABLE :: files_highest_variable_id !< highest assigned ID of variable or dimension in a file 93 94 LOGICAL :: binary_open_file_first_call = .TRUE. !< true if binary_open_file routine was not called yet 95 LOGICAL :: config_file_open = .FALSE. !< true if config file is opened and not closed 97 96 LOGICAL :: print_debug_output = .FALSE. !< if true, debug output is printed 98 97 … … 165 164 166 165 INTEGER, INTENT(IN) :: dom_global_id !< global id within a file defined by DOM 167 INTEGER, INTENT(IN) :: master_output_rank !< MPI rank executing tasks which must be 168 !< executed by a single PE 169 INTEGER, INTENT(IN) :: mpi_comm_of_output_group !< MPI communicator specifying the rank group 170 !< participating in output 166 INTEGER, INTENT(IN) :: master_output_rank !< MPI rank executing tasks which must be executed by a single PE 167 INTEGER, INTENT(IN) :: mpi_comm_of_output_group !< MPI communicator specifying the rank group participating in output 171 168 INTEGER, INTENT(IN) :: program_debug_output_unit !< file unit number for debug output 172 169 … … 174 171 175 172 176 file_suffix = file_suffix_of_output_group177 output_group_comm = mpi_comm_of_output_group178 master_rank = master_output_rank173 file_suffix = file_suffix_of_output_group 174 output_group_comm = mpi_comm_of_output_group 175 master_rank = master_output_rank 179 176 180 177 debug_output_unit = program_debug_output_unit 181 178 print_debug_output = debug_output 182 179 183 global_id_in_file = dom_global_id180 global_id_in_file = dom_global_id 184 181 185 182 END SUBROUTINE binary_init_module … … 204 201 INTEGER, INTENT(OUT) :: return_value !< return value 205 202 206 INTEGER, DIMENSION(:), ALLOCATABLE :: files_highest_variable_id_tmp !< temporary list of given 207 !< variable IDs in file 203 INTEGER, DIMENSION(:), ALLOCATABLE :: files_highest_variable_id_tmp !< temporary list of given variable IDs in file 208 204 209 205 LOGICAL :: file_exists !< true if file to be opened already exists … … 238 234 ! 239 235 !-- Remove any pre-existing file 240 INQUIRE( FILE=TRIM( config_file_name ) // TRIM( file_suffix ), EXIST =file_exists )236 INQUIRE( FILE=TRIM( config_file_name ) // TRIM( file_suffix ), EXIST=file_exists ) 241 237 242 238 IF ( file_exists ) THEN 243 CALL internal_message( 'debug', routine_name // ': Remove existing file ' // & 239 CALL internal_message( 'debug', routine_name // & 240 ': Remove existing file ' // & 244 241 TRIM( config_file_name ) // TRIM( file_suffix ) ) 245 242 !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by 246 243 !> PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used 247 ! CALL EXECUTE_COMMAND_LINE( 244 ! CALL EXECUTE_COMMAND_LINE( & 248 245 ! COMMAND='rm ' // TRIM( config_file_name ) // TRIM( file_suffix ), & 249 246 ! WAIT=.TRUE., EXITSTAT=return_value ) … … 288 285 289 286 IF ( file_exists ) THEN 290 CALL internal_message( 'debug', routine_name // ': remove existing file ' //&291 TRIM( bin_filename ) )287 CALL internal_message( 'debug', routine_name // & 288 ': remove existing file ' // TRIM( bin_filename ) ) 292 289 !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by 293 290 !> PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used … … 320 317 !-- Extend file-variable/dimension-ID list by 1 and set it to 0 for new file. 321 318 IF ( ALLOCATED( files_highest_variable_id ) ) THEN 322 ALLOCATE( files_highest_variable_id_tmp( SIZE( files_highest_variable_id )) )319 ALLOCATE( files_highest_variable_id_tmp(SIZE( files_highest_variable_id )) ) 323 320 files_highest_variable_id_tmp = files_highest_variable_id 324 321 DEALLOCATE( files_highest_variable_id ) … … 333 330 ELSE 334 331 return_value = 1 335 CALL internal_message( 'error', routine_name // ': could not open file "' //&336 TRIM( file_name ) // '"')332 CALL internal_message( 'error', routine_name // & 333 ': could not open file "' // TRIM( file_name ) // '"') 337 334 ENDIF 338 335 … … 349 346 value_int16, value_int32, value_real32, value_real64, & 350 347 return_value ) 351 352 348 353 349 CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_write_attribute' !< name of this routine … … 372 368 return_value = 0 373 369 374 CALL internal_message( 'debug', TRIM( routine_name ) // ': write attribute ' //&375 TRIM( attribute_name ) )370 CALL internal_message( 'debug', TRIM( routine_name ) // & 371 ': write attribute ' // TRIM( attribute_name ) ) 376 372 ! 377 373 !-- Write attribute to file … … 418 414 ! ------------ 419 415 !> Initialize dimension. Write information in file header and save dimension values to be later 420 ! <written to file.416 !> written to file. 421 417 !--------------------------------------------------------------------------------------------------! 422 418 SUBROUTINE binary_init_dimension( mode, file_id, dimension_id, variable_id, dimension_name, & 423 dimension_type, dimension_length, return_value ) 419 dimension_type, dimension_length, write_only_by_master_rank, & 420 return_value ) 424 421 425 422 CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_dimension' !< name of this routine … … 436 433 INTEGER, INTENT(OUT) :: variable_id !< variable ID 437 434 435 LOGICAL, INTENT(IN) :: write_only_by_master_rank !< true if only master rank shall write variable 436 438 437 439 438 return_value = 0 … … 441 440 CALL internal_message( 'debug', routine_name // ': init dimension ' // TRIM( dimension_name ) ) 442 441 ! 443 !-- Check mode (not required, added for compatibility reasons only)442 !-- Required for compatibility reasons 444 443 IF ( TRIM( mode ) == mode_binary ) CONTINUE 445 444 ! … … 458 457 !-- Define variable associated with dimension 459 458 CALL binary_init_variable( mode, file_id, variable_id, dimension_name, dimension_type, & 460 (/ dimension_id /), is_global=.TRUE., return_value=return_value ) 459 (/ dimension_id /), & 460 write_only_by_master_rank=write_only_by_master_rank, & 461 return_value=return_value ) 462 461 463 IF ( return_value /= 0 ) THEN 462 464 CALL internal_message( 'error', routine_name // & … … 472 474 !--------------------------------------------------------------------------------------------------! 473 475 SUBROUTINE binary_init_variable( mode, file_id, variable_id, variable_name, variable_type, & 474 dimension_ids, is_global, return_value )476 dimension_ids, write_only_by_master_rank, return_value ) 475 477 476 478 CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_variable' !< name of this routine 477 479 480 CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode 478 481 CHARACTER(LEN=charlen) :: output_string !< output string 479 CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode480 482 CHARACTER(LEN=charlen), INTENT(IN) :: variable_name !< name of variable 481 483 CHARACTER(LEN=charlen), INTENT(IN) :: variable_type !< data type of variable … … 487 489 INTEGER, DIMENSION(:), INTENT(IN) :: dimension_ids !< list of dimension IDs used by variable 488 490 489 LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE)491 LOGICAL, INTENT(IN) :: write_only_by_master_rank !< true if only master rank shall write variable 490 492 491 493 … … 494 496 CALL internal_message( 'debug', routine_name // ': init variable ' // TRIM( variable_name ) ) 495 497 ! 496 !-- Check mode (not required, added for compatibility reasons only)498 !-- Required for compatibility reasons 497 499 IF ( TRIM( mode ) == mode_binary ) CONTINUE 498 ! 499 !-- Check if variable is global (not required, added for compatibility reasons only) 500 IF ( is_global ) CONTINUE 500 IF ( write_only_by_master_rank ) CONTINUE 501 501 ! 502 502 !-- Assign variable ID … … 533 533 534 534 WRITE( temp_string, * ) file_id 535 CALL internal_message( 'debug', routine_name // ': finalize file definition (file_id=' //&536 TRIM( temp_string ) // ')' )535 CALL internal_message( 'debug', routine_name // & 536 ': finalize file definition (file_id=' // TRIM( temp_string ) // ')' ) 537 537 538 538 output_string = '*** end file header ***' … … 547 547 !--------------------------------------------------------------------------------------------------! 548 548 SUBROUTINE binary_write_variable( & 549 file_id, variable_id, bounds_start, value_counts, bounds_origin, & 550 is_global, & 551 values_char_0d, values_char_1d, values_char_2d, values_char_3d, & 552 values_int8_0d, values_int8_1d, values_int8_2d, values_int8_3d, & 553 values_int16_0d, values_int16_1d, values_int16_2d, values_int16_3d, & 554 values_int32_0d, values_int32_1d, values_int32_2d, values_int32_3d, & 555 values_intwp_0d, values_intwp_1d, values_intwp_2d, values_intwp_3d, & 556 values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, & 557 values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, & 558 values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d, & 559 return_value ) 560 549 file_id, variable_id, bounds_start, value_counts, bounds_origin, & 550 write_only_by_master_rank, & 551 values_char_0d, values_char_1d, values_char_2d, values_char_3d, & 552 values_int8_0d, values_int8_1d, values_int8_2d, values_int8_3d, & 553 values_int16_0d, values_int16_1d, values_int16_2d, values_int16_3d, & 554 values_int32_0d, values_int32_1d, values_int32_2d, values_int32_3d, & 555 values_intwp_0d, values_intwp_1d, values_intwp_2d, values_intwp_3d, & 556 values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, & 557 values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, & 558 values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d, & 559 return_value ) 561 560 562 561 CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_write_variable' !< name of this routine … … 570 569 571 570 INTEGER, INTENT(IN) :: file_id !< file ID 571 INTEGER, INTENT(OUT) :: return_value !< return value 572 572 INTEGER, INTENT(IN) :: variable_id !< variable ID 573 INTEGER, INTENT(OUT) :: return_value !< return value574 573 575 574 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_origin !< starting index of each dimension … … 594 593 INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_intwp_3d !< output variable 595 594 596 LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE)595 LOGICAL, INTENT(IN) :: write_only_by_master_rank !< true if only master rank shall write variable 597 596 598 597 REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_real32_0d !< output variable … … 614 613 WRITE( temp_string, '(": write variable ",I6," into file ",I6)' ) variable_id, file_id 615 614 CALL internal_message( 'debug', routine_name // TRIM( temp_string ) ) 616 617 IF ( is_global ) CONTINUE ! reqired to prevent compiler warning 615 ! 616 !-- Required for compatibility reasons 617 IF ( write_only_by_master_rank ) CONTINUE 618 618 619 619 IF ( .NOT. ANY( value_counts == 0 ) ) THEN … … 695 695 WRITE( file_id ) values_int32_3d 696 696 ! 697 !-- working-precision integer output697 !-- Working-precision integer output 698 698 ELSEIF ( PRESENT( values_intwp_0d ) ) THEN 699 699 output_string = 'intwp' … … 749 749 WRITE( file_id ) values_real64_3d 750 750 ! 751 !-- working-precision real output751 !-- Working-precision real output 752 752 ELSEIF ( PRESENT( values_realwp_0d ) ) THEN 753 753 output_string = 'realwp'
Note: See TracChangeset
for help on using the changeset viewer.
