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

Last change on this file since 4294 was 4232, checked in by knoop, 5 years ago

Bugfix: wrong placement of INCLUDE "mpif.h" fixed.

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