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

Last change on this file since 4586 was 4579, checked in by gronemeier, 4 years ago

corrected formatting to follow PALM coding standard (data_output_module, data_output_binary_module, data_output_netcdf4_module)

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