source: palm/trunk/SOURCE/data_output_binary_module.f90 @ 4174

Last change on this file since 4174 was 4147, checked in by gronemeier, 5 years ago

corrected indentation according to coding standard

  • Property svn:keywords set to Id
File size: 34.6 KB
RevLine 
[4070]1!> @file data_output_binary_module.f90
2!--------------------------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 2019-2019 Leibniz Universitaet Hannover
18!--------------------------------------------------------------------------------------------------!
19!
20! Current revisions:
21! ------------------
[4106]22!
23!
[4070]24! Former revisions:
25! -----------------
26! $Id: data_output_binary_module.f90 4147 2019-08-07 09:42:31Z gronemeier $
[4147]27! corrected indentation according to coding standard
28!
29! 4141 2019-08-05 12:24:51Z gronemeier
[4070]30! Initial revision
31!
32!
33! Authors:
34! --------
35!> @author: Tobias Gronemeier
36!
37! Description:
38! ------------
39!> Binary output module to write output data into binary files.
40!>
[4106]41!> @todo Get iostat value of write statements.
[4070]42!--------------------------------------------------------------------------------------------------!
[4147]43 MODULE data_output_binary_module
[4070]44
[4147]45    USE kinds
[4070]46
47#if defined( __parallel )
48#if defined( __mpifh )
[4147]49    INCLUDE "mpif.h"
[4070]50#else
[4147]51    USE MPI
[4070]52#endif
53#endif
54
[4147]55    IMPLICIT NONE
[4070]56
[4147]57    INTEGER, PARAMETER ::  charlen = 100  !< maximum length of character variables
[4070]58
[4147]59    CHARACTER(LEN=*), PARAMETER ::  config_file_name = 'BINARY_TO_NETCDF_CONFIG'  !< name of config file
60    CHARACTER(LEN=*), PARAMETER ::  mode_binary = 'binary'                        !< string to select operation mode of module
61    CHARACTER(LEN=*), PARAMETER ::  file_prefix = 'BIN_'                          !< file prefix for binary files
[4070]62
[4147]63    CHARACTER(LEN=charlen)      ::  file_suffix = ''             !< file suffix added to each file name
64    CHARACTER(LEN=800)          ::  internal_error_message = ''  !< string containing the last error message
65    CHARACTER(LEN=800)          ::  temp_string                  !< dummy string
[4070]66
[4147]67    INTEGER ::  binary_file_lowest_unit = 1000  !< lowest unit number of all binary files created by this module
68    INTEGER ::  config_file_unit                !< unit number of config file
69    INTEGER ::  debug_output_unit               !< Fortran Unit Number of the debug-output file
70    INTEGER ::  global_id_in_file = -1          !< value of global ID within a file
71    INTEGER ::  master_rank                     !< master rank for tasks to be executed by single PE only
72    INTEGER ::  next_available_unit             !< next unit number available for new file
73    INTEGER ::  output_group_comm               !< MPI communicator addressing all MPI ranks which participate in output
[4070]74
[4147]75    INTEGER, DIMENSION(:), ALLOCATABLE ::  files_highest_variable_id  !< highest assigned ID of variable or dimension in a file
[4070]76
[4147]77    LOGICAL ::  binary_open_file_first_call = .TRUE.  !< true if binary_open_file routine was not called yet
78    LOGICAL ::  config_file_open = .FALSE.            !< true if config file is opened and not closed
79    LOGICAL ::  print_debug_output = .FALSE.          !< if true, debug output is printed
[4070]80
[4147]81    SAVE
[4070]82
[4147]83    PRIVATE
[4070]84
[4147]85    INTERFACE binary_init_module
86       MODULE PROCEDURE binary_init_module
87    END INTERFACE binary_init_module
[4070]88
[4147]89    INTERFACE binary_open_file
90       MODULE PROCEDURE binary_open_file
91    END INTERFACE binary_open_file
[4070]92
[4147]93    INTERFACE binary_init_dimension
94       MODULE PROCEDURE binary_init_dimension
95    END INTERFACE binary_init_dimension
[4070]96
[4147]97    INTERFACE binary_init_variable
98       MODULE PROCEDURE binary_init_variable
99    END INTERFACE binary_init_variable
[4070]100
[4147]101    INTERFACE binary_write_attribute
102       MODULE PROCEDURE binary_write_attribute
103    END INTERFACE binary_write_attribute
[4070]104
[4147]105    INTERFACE binary_stop_file_header_definition
106       MODULE PROCEDURE binary_stop_file_header_definition
107    END INTERFACE binary_stop_file_header_definition
[4070]108
[4147]109    INTERFACE binary_write_variable
110       MODULE PROCEDURE binary_write_variable
111    END INTERFACE binary_write_variable
[4070]112
[4147]113    INTERFACE binary_finalize
114       MODULE PROCEDURE binary_finalize
115    END INTERFACE binary_finalize
[4070]116
[4147]117    INTERFACE binary_get_error_message
118       MODULE PROCEDURE binary_get_error_message
119    END INTERFACE binary_get_error_message
[4070]120
[4147]121    PUBLIC &
122       binary_finalize, &
123       binary_get_error_message, &
124       binary_init_dimension, &
125       binary_stop_file_header_definition, &
126       binary_init_module, &
127       binary_init_variable, &
128       binary_open_file, &
129       binary_write_attribute, &
130       binary_write_variable
[4070]131
132
[4147]133 CONTAINS
[4070]134
135
136!--------------------------------------------------------------------------------------------------!
137! Description:
138! ------------
139!> Initialize data-output module.
140!--------------------------------------------------------------------------------------------------!
[4147]141 SUBROUTINE binary_init_module( file_suffix_of_output_group, mpi_comm_of_output_group, &
142                                master_output_rank,                                    &
143                                program_debug_output_unit, debug_output, dom_global_id )
[4070]144
[4147]145    CHARACTER(LEN=*), INTENT(IN) ::  file_suffix_of_output_group  !> file-name suffix added to each file;
146                                                                  !> must be unique for each output group
[4107]147
[4147]148    INTEGER, INTENT(IN) ::  dom_global_id              !< global id within a file defined by DOM
149    INTEGER, INTENT(IN) ::  master_output_rank         !< MPI rank executing tasks which must be executed by a single PE
150    INTEGER, INTENT(IN) ::  mpi_comm_of_output_group   !< MPI communicator specifying the rank group participating in output
151    INTEGER, INTENT(IN) ::  program_debug_output_unit  !< file unit number for debug output
[4070]152
[4147]153    LOGICAL, INTENT(IN) ::  debug_output  !< if true, debug output is printed
[4070]154
155
[4147]156    file_suffix = file_suffix_of_output_group
157    output_group_comm = mpi_comm_of_output_group
158    master_rank = master_output_rank
[4107]159
[4147]160    debug_output_unit = program_debug_output_unit
161    print_debug_output = debug_output
[4070]162
[4147]163    global_id_in_file = dom_global_id
[4070]164
[4147]165 END SUBROUTINE binary_init_module
[4070]166
167!--------------------------------------------------------------------------------------------------!
168! Description:
169! ------------
170!> Open binary file.
171!--------------------------------------------------------------------------------------------------!
[4147]172 SUBROUTINE binary_open_file( mode, file_name, file_id, return_value )
[4070]173
[4147]174    CHARACTER(LEN=charlen)             ::  bin_filename = ''  !< actual name of binary file
175    CHARACTER(LEN=charlen), INTENT(IN) ::  file_name          !< name of file
176    CHARACTER(LEN=7)                   ::  my_rank_char       !< string containing value of my_rank with leading zeros
177    CHARACTER(LEN=*),       INTENT(IN) ::  mode               !< operation mode
[4070]178
[4147]179    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_open_file'  !< name of this routine
[4070]180
[4147]181    INTEGER, INTENT(OUT) ::  file_id       !< file ID
182    INTEGER              ::  my_rank       !< MPI rank of local processor
183    INTEGER              ::  nranks        !< number of MPI ranks participating in output
184    INTEGER, INTENT(OUT) ::  return_value  !< return value
[4070]185
[4147]186    INTEGER, DIMENSION(:), ALLOCATABLE ::  files_highest_variable_id_tmp  !< temporary list of given variable IDs in file
[4070]187
[4147]188    LOGICAL ::  file_exists  !< true if file to be opened already exists
[4070]189
190
[4147]191    return_value = 0
[4070]192
193#if defined( __parallel )
[4147]194    CALL MPI_COMM_SIZE( output_group_comm, nranks, return_value )
195    IF ( return_value == 0 )  CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
196    IF ( return_value == 0 )  THEN
197       WRITE( my_rank_char, '("_",I6.6)' )  my_rank
198    ELSE
199       CALL internal_message( 'error', routine_name // ': MPI error' )
200    ENDIF
[4070]201#else
[4147]202    nranks = 1
203    my_rank = master_rank
204    WRITE( my_rank_char, '("_",I6.6)' )  my_rank
[4070]205#endif
[4147]206!
207!-- Check mode (not required, added for compatibility reasons)
208    IF ( TRIM( mode ) == mode_binary )  CONTINUE
209!
210!-- Open binary config file for combining script
211    IF ( return_value == 0  .AND.  binary_open_file_first_call )  THEN
[4070]212
[4147]213       binary_open_file_first_call = .FALSE.
214       config_file_unit = binary_file_lowest_unit
[4106]215
[4147]216       IF ( my_rank == master_rank )  THEN
217!
218!--       Remove any pre-existing file
219          INQUIRE( FILE=TRIM( config_file_name ) // TRIM( file_suffix ), &
220                   EXIST=file_exists )
[4070]221
[4147]222          IF ( file_exists )  THEN
223             CALL internal_message( 'debug', routine_name //     &
224                                    ': Remove existing file ' // &
225                                    TRIM( config_file_name ) // TRIM( file_suffix ) )
226             !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by
227             !>       PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used
228             ! CALL EXECUTE_COMMAND_LINE(                                                &
229             !         COMMAND='rm ' // TRIM( config_file_name ) // TRIM( file_suffix ), &
230             !         WAIT=.TRUE., EXITSTAT=return_value )
231             CALL SYSTEM( 'rm ' // TRIM( config_file_name ) // TRIM( file_suffix ) )
232          ENDIF
[4070]233
[4147]234          OPEN( config_file_unit, FILE=TRIM( config_file_name ) // TRIM( file_suffix ), &
235                FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value )
[4070]236
[4147]237          IF ( return_value == 0 )  THEN
[4070]238
[4147]239             config_file_open = .TRUE.
240!
241!--          Write some general information to config file
242             WRITE( config_file_unit )  nranks
243             WRITE( config_file_unit )  master_rank
244             WRITE( config_file_unit )  LEN( file_prefix )
245             WRITE( config_file_unit )  file_prefix
246             WRITE( config_file_unit )  charlen
247             WRITE( config_file_unit )  global_id_in_file
[4070]248
[4147]249          ELSE
[4070]250
[4147]251             return_value = 1
252             CALL internal_message( 'error', routine_name // ': could not create config' )
[4070]253
[4147]254          ENDIF
[4070]255
[4147]256       ENDIF
[4070]257
[4147]258       next_available_unit = binary_file_lowest_unit + 1
[4070]259
[4147]260    ENDIF
261!
262!-- Initialize output file: open, write header, initialize variable/dimension IDs
263    IF ( return_value == 0 )  THEN
[4070]264
[4147]265       bin_filename = file_prefix // TRIM( file_name ) // TRIM( file_suffix ) // my_rank_char
266!
267!--    Remove any pre-existing file
268       INQUIRE( FILE=TRIM( bin_filename ), EXIST=file_exists )
[4070]269
[4147]270       IF ( file_exists )  THEN
271          CALL internal_message( 'debug', routine_name // &
272                                 ': remove existing file ' // TRIM( bin_filename ) )
273          !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by
274          !>       PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used
275          ! CALL EXECUTE_COMMAND_LINE( COMMAND='rm ' // TRIM( bin_filename ), &
276          !                            WAIT=.TRUE., EXITSTAT=return_value )
277          CALL SYSTEM( 'rm ' // TRIM( bin_filename ) )
278       ENDIF
279!
280!--    Open binary file
281       CALL internal_message( 'debug', routine_name // ': open file ' // TRIM( bin_filename ) )
282       OPEN ( next_available_unit, FILE=TRIM( bin_filename ), &
283              FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value )
[4070]284
[4147]285       IF ( return_value == 0 )  THEN
286!
287!--       Add file_name to config file
288          IF ( my_rank == master_rank )  THEN
289             WRITE( config_file_unit )  file_name
290          ENDIF
291!
292!--       Save file ID and increase next file unit number
293          file_id = next_available_unit
294          next_available_unit = next_available_unit + 1
295!
296!--       Write some meta data to file
297          WRITE ( file_id )  charlen
298          WRITE ( file_id )  file_id
299          WRITE ( file_id )  file_name
300!
301!--       Extend file-variable/dimension-ID list by 1 and set it to 0 for new file.
302          IF ( ALLOCATED( files_highest_variable_id ) )  THEN
303             ALLOCATE( files_highest_variable_id_tmp(SIZE( files_highest_variable_id )) )
304             files_highest_variable_id_tmp = files_highest_variable_id
305             DEALLOCATE( files_highest_variable_id )
306             ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
307             files_highest_variable_id(:file_id-1) = files_highest_variable_id_tmp
308             DEALLOCATE( files_highest_variable_id_tmp )
309          ELSE
310             ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
311          ENDIF
312          files_highest_variable_id(file_id) = 0
[4070]313
[4147]314       ELSE
315          return_value = 1
316          CALL internal_message( 'error', routine_name // &
317                                 ': could not open file "' // TRIM( file_name ) // '"')
318       ENDIF
[4070]319
[4147]320    ENDIF
[4070]321
[4147]322 END SUBROUTINE binary_open_file
[4070]323
324!--------------------------------------------------------------------------------------------------!
325! Description:
326! ------------
327!> Write attribute to file.
328!--------------------------------------------------------------------------------------------------!
[4147]329 SUBROUTINE binary_write_attribute( file_id, variable_id, attribute_name, &
330               value_char, value_int8, value_int16, value_int32,          &
331               value_real32, value_real64, return_value )
[4070]332
[4147]333    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_write_attribute'  !< name of this routine
[4070]334
[4147]335    CHARACTER(LEN=charlen), INTENT(IN)           ::  attribute_name        !< name of attribute
336    CHARACTER(LEN=charlen), INTENT(IN), OPTIONAL ::  value_char  !< value of attribute
337    CHARACTER(LEN=charlen)                       ::  attribute_type        !< data type of attribute
338    CHARACTER(LEN=charlen)                       ::  output_string         !< output string
[4070]339
[4147]340    INTEGER(KIND=1), INTENT(IN), OPTIONAL ::  value_int8   !< value of attribute
341    INTEGER(KIND=2), INTENT(IN), OPTIONAL ::  value_int16  !< value of attribute
342    INTEGER(KIND=4), INTENT(IN), OPTIONAL ::  value_int32  !< value of attribute
[4070]343
[4147]344    INTEGER, INTENT(IN)  ::  file_id       !< file ID
345    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
346    INTEGER, INTENT(OUT) ::  return_value  !< return value
[4070]347
[4147]348    REAL(KIND=4), INTENT(IN), OPTIONAL ::  value_real32  !< value of attribute
349    REAL(KIND=8), INTENT(IN), OPTIONAL ::  value_real64  !< value of attribute
[4070]350
351
[4147]352    return_value = 0
[4070]353
[4147]354    CALL internal_message( 'debug', TRIM( routine_name ) // &
355                           ': write attribute ' // TRIM( attribute_name ) )
356!
357!-- Write attribute to file
358    output_string = 'attribute'
359    WRITE( file_id )  output_string
[4070]360
[4147]361    WRITE( file_id )  variable_id
362    WRITE( file_id )  attribute_name
[4070]363
[4147]364    IF ( PRESENT( value_char ) )  THEN
365       attribute_type = 'char'
366       WRITE( file_id )  attribute_type
367       WRITE( file_id )  value_char
368    ELSEIF ( PRESENT( value_int8 ) )  THEN
369       attribute_type = 'int8'
370       WRITE( file_id )  attribute_type
371       WRITE( file_id )  value_int8
372    ELSEIF ( PRESENT( value_int16 ) )  THEN
373       attribute_type = 'int16'
374       WRITE( file_id )  attribute_type
375       WRITE( file_id )  value_int16
376    ELSEIF ( PRESENT( value_int32 ) )  THEN
377       attribute_type = 'int32'
378       WRITE( file_id )  attribute_type
379       WRITE( file_id )  value_int32
380    ELSEIF ( PRESENT( value_real32 ) )  THEN
381       attribute_type = 'real32'
382       WRITE( file_id )  attribute_type
383       WRITE( file_id )  value_real32
384    ELSEIF ( PRESENT( value_real64 ) )  THEN
385       attribute_type = 'real64'
386       WRITE( file_id )  attribute_type
387       WRITE( file_id )  value_real64
388    ELSE
389       return_value = 1
390       CALL internal_message( 'error', TRIM( routine_name ) // &
391                              ': no value given for attribute "' // TRIM( attribute_name ) // '"' )
392    ENDIF
[4070]393
[4147]394 END SUBROUTINE binary_write_attribute
[4070]395
396!--------------------------------------------------------------------------------------------------!
397! Description:
398! ------------
[4141]399!> Initialize dimension. Write information in file header
400!> and save dimension values to be later written to file.
[4070]401!--------------------------------------------------------------------------------------------------!
[4147]402 SUBROUTINE binary_init_dimension( mode, file_id, dimension_id, variable_id, &
403               dimension_name, dimension_type, dimension_length, return_value )
[4070]404
[4147]405    CHARACTER(LEN=charlen), INTENT(IN) ::  dimension_name  !< name of dimension
406    CHARACTER(LEN=charlen), INTENT(IN) ::  dimension_type  !< data type of dimension
407    CHARACTER(LEN=charlen)             ::  output_string   !< output string
408    CHARACTER(LEN=*),       INTENT(IN) ::  mode            !< operation mode
[4070]409
[4147]410    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_init_dimension'  !< name of this routine
[4070]411
[4147]412    INTEGER, INTENT(OUT) ::  dimension_id      !< dimension ID
413    INTEGER, INTENT(IN)  ::  dimension_length  !< length of dimension
414    INTEGER, INTENT(IN)  ::  file_id           !< file ID
415    INTEGER, INTENT(OUT) ::  return_value      !< return value
416    INTEGER, INTENT(OUT) ::  variable_id       !< variable ID
[4070]417
418
[4147]419    return_value = 0
[4070]420
[4147]421    CALL internal_message( 'debug', routine_name // ': init dimension ' // TRIM( dimension_name ) )
422!
423!-- Check mode (not required, added for compatibility reasons only)
424    IF ( TRIM( mode ) == mode_binary )  CONTINUE
425!
426!-- Assign dimension ID
427    dimension_id = files_highest_variable_id( file_id ) + 1
428    files_highest_variable_id( file_id ) = dimension_id
429!
430!-- Define dimension in file
431    output_string = 'dimension'
432    WRITE( file_id )  output_string
433    WRITE( file_id )  dimension_name
434    WRITE( file_id )  dimension_id
435    WRITE( file_id )  dimension_type
436    WRITE( file_id )  dimension_length
437!
438!-- Define variable associated with dimension
439    CALL binary_init_variable( mode, file_id, variable_id, dimension_name, dimension_type, &
440                               (/ dimension_id /), is_global=.TRUE., return_value=return_value )
441    IF ( return_value /= 0 )  THEN
442       CALL internal_message( 'error', routine_name // &
443                              ': init dimension "' // TRIM( dimension_name ) // '"' )
444    ENDIF
[4070]445
[4147]446 END SUBROUTINE binary_init_dimension
[4106]447
[4070]448!--------------------------------------------------------------------------------------------------!
449! Description:
450! ------------
451!> Initialize variable. Write information of variable into file header.
452!--------------------------------------------------------------------------------------------------!
[4147]453 SUBROUTINE binary_init_variable( mode, file_id, variable_id, variable_name, variable_type, &
454                                  dimension_ids, is_global, return_value )
[4070]455
[4147]456    CHARACTER(LEN=charlen)             ::  output_string   !< output string
457    CHARACTER(LEN=charlen), INTENT(IN) ::  variable_name   !< name of variable
458    CHARACTER(LEN=charlen), INTENT(IN) ::  variable_type   !< data type of variable
459    CHARACTER(LEN=*),       INTENT(IN) ::  mode            !< operation mode
[4070]460
[4147]461    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_init_variable'  !< name of this routine
[4070]462
[4147]463    INTEGER, INTENT(IN)  ::  file_id       !< file ID
464    INTEGER, INTENT(OUT) ::  variable_id   !< variable ID
465    INTEGER, INTENT(OUT) ::  return_value  !< return value
[4070]466
[4147]467    INTEGER, DIMENSION(:), INTENT(IN) ::  dimension_ids  !< list of dimension IDs used by variable
[4070]468
[4147]469    LOGICAL, INTENT(IN)  ::  is_global  !< true if variable is global (same on all PE)
[4070]470
471
[4147]472    return_value = 0
[4070]473
[4147]474    CALL internal_message( 'debug', routine_name // ': init variable ' // TRIM( variable_name ) )
475!
476!-- Check mode (not required, added for compatibility reasons only)
477    IF ( TRIM( mode ) == mode_binary )  CONTINUE
478!
479!-- Check if variable is global (not required, added for compatibility reasons only)
480    IF ( is_global )  CONTINUE
481!
482!-- Assign variable ID
483    variable_id = files_highest_variable_id( file_id ) + 1
484    files_highest_variable_id( file_id ) = variable_id
485!
486!-- Write variable information in file
487    output_string = 'variable'
488    WRITE( file_id )  output_string
489    WRITE( file_id )  variable_name
490    WRITE( file_id )  variable_id
491    WRITE( file_id )  variable_type
492    WRITE( file_id )  SIZE( dimension_ids )
493    WRITE( file_id )  dimension_ids
[4070]494
[4147]495 END SUBROUTINE binary_init_variable
[4070]496
497!--------------------------------------------------------------------------------------------------!
498! Description:
499! ------------
500!> Leave file definition state.
501!--------------------------------------------------------------------------------------------------!
[4147]502 SUBROUTINE binary_stop_file_header_definition( file_id, return_value )
[4070]503
[4147]504    CHARACTER(LEN=charlen) ::  output_string  !< output string
[4070]505
[4147]506    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_stop_file_header_definition'  !< name of this routine
[4070]507
[4147]508    INTEGER, INTENT(IN)  ::  file_id       !< file ID
509    INTEGER, INTENT(OUT) ::  return_value  !< return value
[4070]510
511
[4147]512    return_value = 0
[4070]513
[4147]514    WRITE( temp_string, * ) file_id
515    CALL internal_message( 'debug', routine_name // &
516                           ': finalize file definition (file_id=' // TRIM( temp_string ) // ')' )
[4070]517
[4147]518    output_string = '*** end file header ***'
519    WRITE( file_id )  output_string
[4070]520
[4147]521 END SUBROUTINE binary_stop_file_header_definition
[4070]522
523!--------------------------------------------------------------------------------------------------!
524! Description:
525! ------------
526!> Write variable to file.
527!--------------------------------------------------------------------------------------------------!
[4147]528 SUBROUTINE binary_write_variable(                                                     &
529               file_id, variable_id, bounds_start, value_counts, bounds_origin,        &
530               is_global,                                                              &
531               values_int8_0d,   values_int8_1d,   values_int8_2d,   values_int8_3d,   &
532               values_int16_0d,  values_int16_1d,  values_int16_2d,  values_int16_3d,  &
533               values_int32_0d,  values_int32_1d,  values_int32_2d,  values_int32_3d,  &
534               values_intwp_0d,  values_intwp_1d,  values_intwp_2d,  values_intwp_3d,  &
535               values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &
536               values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &
537               values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d, &
538               return_value )
[4070]539
[4147]540    CHARACTER(LEN=charlen) ::  output_string  !< output string
[4106]541
[4147]542    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_write_variable'  !< name of this routine
[4070]543
[4147]544    INTEGER, INTENT(IN)  ::  file_id       !< file ID
545    INTEGER, INTENT(OUT) ::  return_value  !< return value
546    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
[4070]547
[4147]548    INTEGER, DIMENSION(:), INTENT(IN) ::  bounds_origin  !< starting index of each dimension
549    INTEGER, DIMENSION(:), INTENT(IN) ::  bounds_start   !< starting index of variable
550    INTEGER, DIMENSION(:), INTENT(IN) ::  value_counts   !< count of values along each dimension to be written
[4070]551
[4147]552    INTEGER(KIND=1), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int8_0d   !< output variable
553    INTEGER(KIND=2), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int16_0d  !< output variable
554    INTEGER(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int32_0d  !< output variable
555    INTEGER(iwp),    POINTER,             INTENT(IN), OPTIONAL                   ::  values_intwp_0d  !< output variable
556    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int8_1d   !< output variable
557    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int16_1d  !< output variable
558    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int32_1d  !< output variable
559    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_intwp_1d  !< output variable
560    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int8_2d   !< output variable
561    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int16_2d  !< output variable
562    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int32_2d  !< output variable
563    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_intwp_2d  !< output variable
564    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int8_3d   !< output variable
565    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int16_3d  !< output variable
566    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int32_3d  !< output variable
567    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_intwp_3d  !< output variable
[4070]568
[4147]569    LOGICAL, INTENT(IN) ::  is_global  !< true if variable is global (same on all PE)
[4070]570
[4147]571    REAL(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real32_0d  !< output variable
572    REAL(KIND=8), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real64_0d  !< output variable
573    REAL(wp),     POINTER,             INTENT(IN), OPTIONAL                   ::  values_realwp_0d  !< output variable
574    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real32_1d  !< output variable
575    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real64_1d  !< output variable
576    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_realwp_1d  !< output variable
577    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real32_2d  !< output variable
578    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real64_2d  !< output variable
579    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_realwp_2d  !< output variable
580    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real32_3d  !< output variable
581    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real64_3d  !< output variable
582    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_realwp_3d  !< output variable
[4070]583
584
[4147]585    return_value = 0
[4070]586
[4147]587    WRITE( temp_string, '(": write variable ",I6," into file ",I6)' ) variable_id, file_id
588    CALL internal_message( 'debug', routine_name // TRIM( temp_string ) )
[4070]589
[4147]590    IF ( is_global )  CONTINUE  ! reqired to prevent compiler warning
[4070]591
[4147]592    IF ( .NOT. ANY( value_counts == 0 ) )  THEN
593       WRITE( file_id )  variable_id
594       WRITE( file_id )  bounds_start
595       WRITE( file_id )  value_counts
596       WRITE( file_id )  bounds_origin
597!
598!--    8bit integer output
599       IF ( PRESENT( values_int8_0d ) )  THEN
600          output_string = 'int8'
601          WRITE( file_id )  output_string
602          WRITE( file_id )  values_int8_0d
603       ELSEIF ( PRESENT( values_int8_1d ) )  THEN
604          output_string = 'int8'
605          WRITE( file_id )  output_string
606          WRITE( file_id )  values_int8_1d
607       ELSEIF ( PRESENT( values_int8_2d ) )  THEN
608          output_string = 'int8'
609          WRITE( file_id )  output_string
610          WRITE( file_id )  values_int8_2d
611       ELSEIF ( PRESENT( values_int8_3d ) )  THEN
612          output_string = 'int8'
613          WRITE( file_id )  output_string
614          WRITE( file_id )  values_int8_3d
615!
616!--    16bit integer output
617       ELSEIF ( PRESENT( values_int16_0d ) )  THEN
618          output_string = 'int16'
619          WRITE( file_id )  output_string
620          WRITE( file_id )  values_int16_0d
621       ELSEIF ( PRESENT( values_int16_1d ) )  THEN
622          output_string = 'int16'
623          WRITE( file_id )  output_string
624          WRITE( file_id )  values_int16_1d
625       ELSEIF ( PRESENT( values_int16_2d ) )  THEN
626          output_string = 'int16'
627          WRITE( file_id )  output_string
628          WRITE( file_id )  values_int16_2d
629       ELSEIF ( PRESENT( values_int16_3d ) )  THEN
630          output_string = 'int16'
631          WRITE( file_id )  output_string
632          WRITE( file_id )  values_int16_3d
633!
634!--    32bit integer output
635       ELSEIF ( PRESENT( values_int32_0d ) )  THEN
636          output_string = 'int32'
637          WRITE( file_id )  output_string
638          WRITE( file_id )  values_int32_0d
639       ELSEIF ( PRESENT( values_int32_1d ) )  THEN
640          output_string = 'int32'
641          WRITE( file_id )  output_string
642          WRITE( file_id )  values_int32_1d
643       ELSEIF ( PRESENT( values_int32_2d ) )  THEN
644          output_string = 'int32'
645          WRITE( file_id )  output_string
646          WRITE( file_id )  values_int32_2d
647       ELSEIF ( PRESENT( values_int32_3d ) )  THEN
648          output_string = 'int32'
649          WRITE( file_id )  output_string
650          WRITE( file_id )  values_int32_3d
651!
652!--    working-precision integer output
653       ELSEIF ( PRESENT( values_intwp_0d ) )  THEN
654          output_string = 'intwp'
655          WRITE( file_id )  output_string
656          WRITE( file_id )  values_intwp_0d
657       ELSEIF ( PRESENT( values_intwp_1d ) )  THEN
658          output_string = 'intwp'
659          WRITE( file_id )  output_string
660          WRITE( file_id )  values_intwp_1d
661       ELSEIF ( PRESENT( values_intwp_2d ) )  THEN
662          output_string = 'intwp'
663          WRITE( file_id )  output_string
664          WRITE( file_id )  values_intwp_2d
665       ELSEIF ( PRESENT( values_intwp_3d ) )  THEN
666          output_string = 'intwp'
667          WRITE( file_id )  output_string
668          WRITE( file_id )  values_intwp_3d
669!
670!--    32bit real output
671       ELSEIF ( PRESENT( values_real32_0d ) )  THEN
672          output_string = 'real32'
673          WRITE( file_id )  output_string
674          WRITE( file_id )  values_real32_0d
675       ELSEIF ( PRESENT( values_real32_1d ) )  THEN
676          output_string = 'real32'
677          WRITE( file_id )  output_string
678          WRITE( file_id )  values_real32_1d
679       ELSEIF ( PRESENT( values_real32_2d ) )  THEN
680          output_string = 'real32'
681          WRITE( file_id )  output_string
682          WRITE( file_id )  values_real32_2d
683       ELSEIF ( PRESENT( values_real32_3d ) )  THEN
684          output_string = 'real32'
685          WRITE( file_id )  output_string
686          WRITE( file_id )  values_real32_3d
687!
688!--    64bit real output
689       ELSEIF ( PRESENT( values_real64_0d ) )  THEN
690          output_string = 'real64'
691          WRITE( file_id )  output_string
692          WRITE( file_id )  values_real64_0d
693       ELSEIF ( PRESENT( values_real64_1d ) )  THEN
694          output_string = 'real64'
695          WRITE( file_id )  output_string
696          WRITE( file_id )  values_real64_1d
697       ELSEIF ( PRESENT( values_real64_2d ) )  THEN
698          output_string = 'real64'
699          WRITE( file_id )  output_string
700          WRITE( file_id )  values_real64_2d
701       ELSEIF ( PRESENT( values_real64_3d ) )  THEN
702          output_string = 'real64'
703          WRITE( file_id )  output_string
704          WRITE( file_id )  values_real64_3d
705!
706!--    working-precision real output
707       ELSEIF ( PRESENT( values_realwp_0d ) )  THEN
708          output_string = 'realwp'
709          WRITE( file_id )  output_string
710          WRITE( file_id )  values_realwp_0d
711       ELSEIF ( PRESENT( values_realwp_1d ) )  THEN
712          output_string = 'realwp'
713          WRITE( file_id )  output_string
714          WRITE( file_id )  values_realwp_1d
715       ELSEIF ( PRESENT( values_realwp_2d ) )  THEN
716          output_string = 'realwp'
717          WRITE( file_id )  output_string
718          WRITE( file_id )  values_realwp_2d
719       ELSEIF ( PRESENT( values_realwp_3d ) )  THEN
720          output_string = 'realwp'
721          WRITE( file_id )  output_string
722          WRITE( file_id )  values_realwp_3d
723       ELSE
724          return_value = 1
725          CALL internal_message( 'error', routine_name // ': no values given' )
726       ENDIF
[4070]727
[4147]728    ENDIF
[4070]729
[4147]730 END SUBROUTINE binary_write_variable
[4070]731
732!--------------------------------------------------------------------------------------------------!
733! Description:
734! ------------
735!> Close opened files.
736!--------------------------------------------------------------------------------------------------!
[4147]737 SUBROUTINE binary_finalize( file_id, return_value )
[4070]738
[4147]739    CHARACTER(LEN=charlen) ::  output_string  !< output string
[4070]740
[4147]741    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_finalize'  !< name of this routine
[4070]742
[4147]743    INTEGER, INTENT(IN)  ::  file_id       !< file ID
744    INTEGER, INTENT(OUT) ::  return_value  !< return value
[4070]745
746
[4147]747    IF ( config_file_open )  THEN
[4070]748
[4147]749       output_string = '*** end config file ***'
750       WRITE( config_file_unit )  output_string
[4070]751
[4147]752       CLOSE( config_file_unit, IOSTAT=return_value )
[4070]753
[4147]754       IF ( return_value /= 0 )  THEN
755          CALL internal_message( 'error', routine_name // ': cannot close configuration file' )
756       ELSE
757          config_file_open = .FALSE.
758       ENDIF
[4070]759
[4147]760    ELSE
[4070]761
[4147]762       return_value = 0
[4070]763
[4147]764    ENDIF
[4070]765
[4147]766    IF ( return_value == 0 )  THEN
[4070]767
[4147]768       WRITE( temp_string, * ) file_id
769       CALL internal_message( 'debug', routine_name // &
770                              ': close file (file_id=' // TRIM( temp_string ) // ')' )
[4070]771
[4147]772       CLOSE( file_id, IOSTAT=return_value )
773       IF ( return_value /= 0 )  THEN
774          WRITE( temp_string, * ) file_id
775          CALL internal_message( 'error', routine_name // &
776                                 ': cannot close file (file_id=' // TRIM( temp_string ) // ')' )
777       ENDIF
[4070]778
[4147]779    ENDIF
[4070]780
[4147]781 END SUBROUTINE binary_finalize
[4070]782
783!--------------------------------------------------------------------------------------------------!
784! Description:
785! ------------
786!> Message routine writing debug information into the debug file
787!> or creating the error message string.
788!--------------------------------------------------------------------------------------------------!
[4147]789 SUBROUTINE internal_message( level, string )
[4070]790
[4147]791    CHARACTER(LEN=*), INTENT(IN) ::  level   !< message importance level
792    CHARACTER(LEN=*), INTENT(IN) ::  string  !< message string
[4070]793
794
[4147]795    IF ( TRIM( level ) == 'error' )  THEN
[4070]796
[4147]797       WRITE( internal_error_message, '(A,A)' ) ': ', string
[4070]798
[4147]799    ELSEIF ( TRIM( level ) == 'debug'  .AND.  print_debug_output )  THEN
[4070]800
[4147]801       WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
802       FLUSH( debug_output_unit )
[4070]803
[4147]804    ENDIF
[4070]805
[4147]806 END SUBROUTINE internal_message
[4070]807
808!--------------------------------------------------------------------------------------------------!
809! Description:
810! ------------
811!> Return the last created error message.
812!--------------------------------------------------------------------------------------------------!
[4147]813 FUNCTION binary_get_error_message() RESULT( error_message )
[4070]814
[4147]815    CHARACTER(LEN=800) ::  error_message  !< return error message to main program
[4070]816
817
[4147]818    error_message = TRIM( internal_error_message )
[4070]819
[4147]820    internal_error_message = ''
[4070]821
[4147]822 END FUNCTION binary_get_error_message
823
824 END MODULE data_output_binary_module
Note: See TracBrowser for help on using the repository browser.