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

Last change on this file since 4185 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
Line 
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! ------------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: data_output_binary_module.f90 4147 2019-08-07 09:42:31Z oliver.maas $
27! corrected indentation according to coding standard
28!
29! 4141 2019-08-05 12:24:51Z gronemeier
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!>
41!> @todo Get iostat value of write statements.
42!--------------------------------------------------------------------------------------------------!
43 MODULE data_output_binary_module
44
45    USE kinds
46
47#if defined( __parallel )
48#if defined( __mpifh )
49    INCLUDE "mpif.h"
50#else
51    USE MPI
52#endif
53#endif
54
55    IMPLICIT NONE
56
57    INTEGER, PARAMETER ::  charlen = 100  !< maximum length of character variables
58
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
62
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
66
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
74
75    INTEGER, DIMENSION(:), ALLOCATABLE ::  files_highest_variable_id  !< highest assigned ID of variable or dimension in a file
76
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
80
81    SAVE
82
83    PRIVATE
84
85    INTERFACE binary_init_module
86       MODULE PROCEDURE binary_init_module
87    END INTERFACE binary_init_module
88
89    INTERFACE binary_open_file
90       MODULE PROCEDURE binary_open_file
91    END INTERFACE binary_open_file
92
93    INTERFACE binary_init_dimension
94       MODULE PROCEDURE binary_init_dimension
95    END INTERFACE binary_init_dimension
96
97    INTERFACE binary_init_variable
98       MODULE PROCEDURE binary_init_variable
99    END INTERFACE binary_init_variable
100
101    INTERFACE binary_write_attribute
102       MODULE PROCEDURE binary_write_attribute
103    END INTERFACE binary_write_attribute
104
105    INTERFACE binary_stop_file_header_definition
106       MODULE PROCEDURE binary_stop_file_header_definition
107    END INTERFACE binary_stop_file_header_definition
108
109    INTERFACE binary_write_variable
110       MODULE PROCEDURE binary_write_variable
111    END INTERFACE binary_write_variable
112
113    INTERFACE binary_finalize
114       MODULE PROCEDURE binary_finalize
115    END INTERFACE binary_finalize
116
117    INTERFACE binary_get_error_message
118       MODULE PROCEDURE binary_get_error_message
119    END INTERFACE binary_get_error_message
120
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
131
132
133 CONTAINS
134
135
136!--------------------------------------------------------------------------------------------------!
137! Description:
138! ------------
139!> Initialize data-output module.
140!--------------------------------------------------------------------------------------------------!
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 )
144
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
147
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
152
153    LOGICAL, INTENT(IN) ::  debug_output  !< if true, debug output is printed
154
155
156    file_suffix = file_suffix_of_output_group
157    output_group_comm = mpi_comm_of_output_group
158    master_rank = master_output_rank
159
160    debug_output_unit = program_debug_output_unit
161    print_debug_output = debug_output
162
163    global_id_in_file = dom_global_id
164
165 END SUBROUTINE binary_init_module
166
167!--------------------------------------------------------------------------------------------------!
168! Description:
169! ------------
170!> Open binary file.
171!--------------------------------------------------------------------------------------------------!
172 SUBROUTINE binary_open_file( mode, file_name, file_id, return_value )
173
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
178
179    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_open_file'  !< name of this routine
180
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
185
186    INTEGER, DIMENSION(:), ALLOCATABLE ::  files_highest_variable_id_tmp  !< temporary list of given variable IDs in file
187
188    LOGICAL ::  file_exists  !< true if file to be opened already exists
189
190
191    return_value = 0
192
193#if defined( __parallel )
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
201#else
202    nranks = 1
203    my_rank = master_rank
204    WRITE( my_rank_char, '("_",I6.6)' )  my_rank
205#endif
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
212
213       binary_open_file_first_call = .FALSE.
214       config_file_unit = binary_file_lowest_unit
215
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 )
221
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
233
234          OPEN( config_file_unit, FILE=TRIM( config_file_name ) // TRIM( file_suffix ), &
235                FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value )
236
237          IF ( return_value == 0 )  THEN
238
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
248
249          ELSE
250
251             return_value = 1
252             CALL internal_message( 'error', routine_name // ': could not create config' )
253
254          ENDIF
255
256       ENDIF
257
258       next_available_unit = binary_file_lowest_unit + 1
259
260    ENDIF
261!
262!-- Initialize output file: open, write header, initialize variable/dimension IDs
263    IF ( return_value == 0 )  THEN
264
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 )
269
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 )
284
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
313
314       ELSE
315          return_value = 1
316          CALL internal_message( 'error', routine_name // &
317                                 ': could not open file "' // TRIM( file_name ) // '"')
318       ENDIF
319
320    ENDIF
321
322 END SUBROUTINE binary_open_file
323
324!--------------------------------------------------------------------------------------------------!
325! Description:
326! ------------
327!> Write attribute to file.
328!--------------------------------------------------------------------------------------------------!
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 )
332
333    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_write_attribute'  !< name of this routine
334
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
339
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
343
344    INTEGER, INTENT(IN)  ::  file_id       !< file ID
345    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
346    INTEGER, INTENT(OUT) ::  return_value  !< return value
347
348    REAL(KIND=4), INTENT(IN), OPTIONAL ::  value_real32  !< value of attribute
349    REAL(KIND=8), INTENT(IN), OPTIONAL ::  value_real64  !< value of attribute
350
351
352    return_value = 0
353
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
360
361    WRITE( file_id )  variable_id
362    WRITE( file_id )  attribute_name
363
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
393
394 END SUBROUTINE binary_write_attribute
395
396!--------------------------------------------------------------------------------------------------!
397! Description:
398! ------------
399!> Initialize dimension. Write information in file header
400!> and save dimension values to be later written to file.
401!--------------------------------------------------------------------------------------------------!
402 SUBROUTINE binary_init_dimension( mode, file_id, dimension_id, variable_id, &
403               dimension_name, dimension_type, dimension_length, return_value )
404
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
409
410    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_init_dimension'  !< name of this routine
411
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
417
418
419    return_value = 0
420
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
445
446 END SUBROUTINE binary_init_dimension
447
448!--------------------------------------------------------------------------------------------------!
449! Description:
450! ------------
451!> Initialize variable. Write information of variable into file header.
452!--------------------------------------------------------------------------------------------------!
453 SUBROUTINE binary_init_variable( mode, file_id, variable_id, variable_name, variable_type, &
454                                  dimension_ids, is_global, return_value )
455
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
460
461    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_init_variable'  !< name of this routine
462
463    INTEGER, INTENT(IN)  ::  file_id       !< file ID
464    INTEGER, INTENT(OUT) ::  variable_id   !< variable ID
465    INTEGER, INTENT(OUT) ::  return_value  !< return value
466
467    INTEGER, DIMENSION(:), INTENT(IN) ::  dimension_ids  !< list of dimension IDs used by variable
468
469    LOGICAL, INTENT(IN)  ::  is_global  !< true if variable is global (same on all PE)
470
471
472    return_value = 0
473
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
494
495 END SUBROUTINE binary_init_variable
496
497!--------------------------------------------------------------------------------------------------!
498! Description:
499! ------------
500!> Leave file definition state.
501!--------------------------------------------------------------------------------------------------!
502 SUBROUTINE binary_stop_file_header_definition( file_id, return_value )
503
504    CHARACTER(LEN=charlen) ::  output_string  !< output string
505
506    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_stop_file_header_definition'  !< name of this routine
507
508    INTEGER, INTENT(IN)  ::  file_id       !< file ID
509    INTEGER, INTENT(OUT) ::  return_value  !< return value
510
511
512    return_value = 0
513
514    WRITE( temp_string, * ) file_id
515    CALL internal_message( 'debug', routine_name // &
516                           ': finalize file definition (file_id=' // TRIM( temp_string ) // ')' )
517
518    output_string = '*** end file header ***'
519    WRITE( file_id )  output_string
520
521 END SUBROUTINE binary_stop_file_header_definition
522
523!--------------------------------------------------------------------------------------------------!
524! Description:
525! ------------
526!> Write variable to file.
527!--------------------------------------------------------------------------------------------------!
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 )
539
540    CHARACTER(LEN=charlen) ::  output_string  !< output string
541
542    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_write_variable'  !< name of this routine
543
544    INTEGER, INTENT(IN)  ::  file_id       !< file ID
545    INTEGER, INTENT(OUT) ::  return_value  !< return value
546    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
547
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
551
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
568
569    LOGICAL, INTENT(IN) ::  is_global  !< true if variable is global (same on all PE)
570
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
583
584
585    return_value = 0
586
587    WRITE( temp_string, '(": write variable ",I6," into file ",I6)' ) variable_id, file_id
588    CALL internal_message( 'debug', routine_name // TRIM( temp_string ) )
589
590    IF ( is_global )  CONTINUE  ! reqired to prevent compiler warning
591
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
727
728    ENDIF
729
730 END SUBROUTINE binary_write_variable
731
732!--------------------------------------------------------------------------------------------------!
733! Description:
734! ------------
735!> Close opened files.
736!--------------------------------------------------------------------------------------------------!
737 SUBROUTINE binary_finalize( file_id, return_value )
738
739    CHARACTER(LEN=charlen) ::  output_string  !< output string
740
741    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_finalize'  !< name of this routine
742
743    INTEGER, INTENT(IN)  ::  file_id       !< file ID
744    INTEGER, INTENT(OUT) ::  return_value  !< return value
745
746
747    IF ( config_file_open )  THEN
748
749       output_string = '*** end config file ***'
750       WRITE( config_file_unit )  output_string
751
752       CLOSE( config_file_unit, IOSTAT=return_value )
753
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
759
760    ELSE
761
762       return_value = 0
763
764    ENDIF
765
766    IF ( return_value == 0 )  THEN
767
768       WRITE( temp_string, * ) file_id
769       CALL internal_message( 'debug', routine_name // &
770                              ': close file (file_id=' // TRIM( temp_string ) // ')' )
771
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
778
779    ENDIF
780
781 END SUBROUTINE binary_finalize
782
783!--------------------------------------------------------------------------------------------------!
784! Description:
785! ------------
786!> Message routine writing debug information into the debug file
787!> or creating the error message string.
788!--------------------------------------------------------------------------------------------------!
789 SUBROUTINE internal_message( level, string )
790
791    CHARACTER(LEN=*), INTENT(IN) ::  level   !< message importance level
792    CHARACTER(LEN=*), INTENT(IN) ::  string  !< message string
793
794
795    IF ( TRIM( level ) == 'error' )  THEN
796
797       WRITE( internal_error_message, '(A,A)' ) ': ', string
798
799    ELSEIF ( TRIM( level ) == 'debug'  .AND.  print_debug_output )  THEN
800
801       WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
802       FLUSH( debug_output_unit )
803
804    ENDIF
805
806 END SUBROUTINE internal_message
807
808!--------------------------------------------------------------------------------------------------!
809! Description:
810! ------------
811!> Return the last created error message.
812!--------------------------------------------------------------------------------------------------!
813 FUNCTION binary_get_error_message() RESULT( error_message )
814
815    CHARACTER(LEN=800) ::  error_message  !< return error message to main program
816
817
818    error_message = TRIM( internal_error_message )
819
820    internal_error_message = ''
821
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.