source: palm/trunk/SOURCE/data_output_binary_module.f90

Last change on this file was 4828, checked in by Giersch, 3 years ago

Copyright updated to year 2021, interface pmc_sort removed to accelarate the nesting code

  • Property svn:keywords set to Id
File size: 37.9 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-2021 Leibniz Universitaet Hannover
17!--------------------------------------------------------------------------------------------------!
18!
19! Current revisions:
20! ------------------
21!
22!
23! Former revisions:
24! -----------------
25! $Id: data_output_binary_module.f90 4828 2021-01-05 11:21:41Z banzhafs $
26! support for MPI Fortran77 interface (mpif.h) removed
27!
28! 4597 2020-07-09 19:21:53Z gronemeier
29! change: update argument list of routine binary_init_dimension due to changes in interface
30!
31! 4579 2020-06-25 20:05:07Z gronemeier
32! corrected formatting to follow PALM coding standard
33!
34! 4577 2020-06-25 09:53:58Z raasch
35! further re-formatting to follow the PALM coding standard
36!
37! 4559 2020-06-11 08:51:48Z raasch
38! file re-formatted to follow the PALM coding standard
39!
40! 4481 2020-03-31 18:55:54Z maronga
41! Enable character-array output
42!
43! 4232 2019-09-20 09:34:22Z knoop
44! Bugfix: INCLUDE "mpif.h" must be placed after IMPLICIT NONE statement
45!
46! 4147 2019-08-07 09:42:31Z gronemeier
47! corrected indentation according to coding standard
48!
49! 4141 2019-08-05 12:24:51Z gronemeier
50! Initial revision
51!
52!
53! Authors:
54! --------
55!> @author: Tobias Gronemeier
56!
57! Description:
58! ------------
59!> Binary output module to write output data into binary files.
60!>
61!> @todo Get iostat value of write statements.
62!--------------------------------------------------------------------------------------------------!
63 MODULE data_output_binary_module
64
65    USE kinds
66
67#if defined( __parallel )
68    USE MPI
69#endif
70
71    IMPLICIT NONE
72
73
74    CHARACTER(LEN=*), PARAMETER ::  config_file_name = 'BINARY_TO_NETCDF_CONFIG'  !< name of config file
75    CHARACTER(LEN=*), PARAMETER ::  file_prefix = 'BIN_'                          !< file prefix for binary files
76    CHARACTER(LEN=*), PARAMETER ::  mode_binary = 'binary'                        !< string to select operation mode of module
77
78    INTEGER, PARAMETER ::  charlen = 100  !< maximum length of character variables
79
80    CHARACTER(LEN=charlen)      ::  file_suffix = ''             !< file suffix added to each file name
81    CHARACTER(LEN=800)          ::  internal_error_message = ''  !< string containing the last error message
82    CHARACTER(LEN=800)          ::  temp_string                  !< dummy string
83
84    INTEGER ::  binary_file_lowest_unit = 1000  !< lowest unit number of all binary files created by this module
85    INTEGER ::  config_file_unit                !< unit number of config file
86    INTEGER ::  debug_output_unit               !< Fortran Unit Number of the debug-output file
87    INTEGER ::  global_id_in_file = -1          !< value of global ID within a file
88    INTEGER ::  master_rank                     !< master rank for tasks to be executed by single PE only
89    INTEGER ::  next_available_unit             !< next unit number available for new file
90    INTEGER ::  output_group_comm               !< MPI communicator addressing all MPI ranks which participate in output
91
92    INTEGER, DIMENSION(:), ALLOCATABLE ::  files_highest_variable_id  !< highest assigned ID of variable or dimension in a file
93
94    LOGICAL ::  binary_open_file_first_call = .TRUE.  !< true if binary_open_file routine was not called yet
95    LOGICAL ::  config_file_open = .FALSE.            !< true if config file is opened and not closed
96    LOGICAL ::  print_debug_output = .FALSE.          !< if true, debug output is printed
97
98    SAVE
99
100    PRIVATE
101
102    INTERFACE binary_init_module
103       MODULE PROCEDURE binary_init_module
104    END INTERFACE binary_init_module
105
106    INTERFACE binary_open_file
107       MODULE PROCEDURE binary_open_file
108    END INTERFACE binary_open_file
109
110    INTERFACE binary_init_dimension
111       MODULE PROCEDURE binary_init_dimension
112    END INTERFACE binary_init_dimension
113
114    INTERFACE binary_init_variable
115       MODULE PROCEDURE binary_init_variable
116    END INTERFACE binary_init_variable
117
118    INTERFACE binary_write_attribute
119       MODULE PROCEDURE binary_write_attribute
120    END INTERFACE binary_write_attribute
121
122    INTERFACE binary_stop_file_header_definition
123       MODULE PROCEDURE binary_stop_file_header_definition
124    END INTERFACE binary_stop_file_header_definition
125
126    INTERFACE binary_write_variable
127       MODULE PROCEDURE binary_write_variable
128    END INTERFACE binary_write_variable
129
130    INTERFACE binary_finalize
131       MODULE PROCEDURE binary_finalize
132    END INTERFACE binary_finalize
133
134    INTERFACE binary_get_error_message
135       MODULE PROCEDURE binary_get_error_message
136    END INTERFACE binary_get_error_message
137
138    PUBLIC                                                                                         &
139       binary_finalize,                                                                            &
140       binary_get_error_message,                                                                   &
141       binary_init_dimension,                                                                      &
142       binary_init_module,                                                                         &
143       binary_init_variable,                                                                       &
144       binary_open_file,                                                                           &
145       binary_stop_file_header_definition,                                                         &
146       binary_write_attribute,                                                                     &
147       binary_write_variable
148
149
150 CONTAINS
151
152
153!--------------------------------------------------------------------------------------------------!
154! Description:
155! ------------
156!> Initialize data-output module.
157!--------------------------------------------------------------------------------------------------!
158 SUBROUTINE binary_init_module( file_suffix_of_output_group, mpi_comm_of_output_group,             &
159                                master_output_rank, program_debug_output_unit, debug_output,       &
160                                dom_global_id )
161
162    CHARACTER(LEN=*), INTENT(IN) ::  file_suffix_of_output_group  !> file-name suffix added to each file;
163                                                                  !> must be unique for each output group
164
165    INTEGER, INTENT(IN) ::  dom_global_id              !< global id within a file defined by DOM
166    INTEGER, INTENT(IN) ::  master_output_rank         !< MPI rank executing tasks which must be executed by a single PE
167    INTEGER, INTENT(IN) ::  mpi_comm_of_output_group   !< MPI communicator specifying the rank group participating in output
168    INTEGER, INTENT(IN) ::  program_debug_output_unit  !< file unit number for debug output
169
170    LOGICAL, INTENT(IN) ::  debug_output  !< if true, debug output is printed
171
172
173    file_suffix        = file_suffix_of_output_group
174    output_group_comm  = mpi_comm_of_output_group
175    master_rank        = master_output_rank
176
177    debug_output_unit  = program_debug_output_unit
178    print_debug_output = debug_output
179
180    global_id_in_file  = dom_global_id
181
182 END SUBROUTINE binary_init_module
183
184!--------------------------------------------------------------------------------------------------!
185! Description:
186! ------------
187!> Open binary file.
188!--------------------------------------------------------------------------------------------------!
189 SUBROUTINE binary_open_file( mode, file_name, file_id, return_value )
190
191    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_open_file'  !< name of this routine
192
193    CHARACTER(LEN=charlen)             ::  bin_filename = ''  !< actual name of binary file
194    CHARACTER(LEN=charlen), INTENT(IN) ::  file_name          !< name of file
195    CHARACTER(LEN=*),       INTENT(IN) ::  mode               !< operation mode
196    CHARACTER(LEN=7)                   ::  my_rank_char       !< string containing value of my_rank with leading zeros
197
198    INTEGER, INTENT(OUT) ::  file_id       !< file ID
199    INTEGER              ::  my_rank       !< MPI rank of local processor
200    INTEGER              ::  nranks        !< number of MPI ranks participating in output
201    INTEGER, INTENT(OUT) ::  return_value  !< return value
202
203    INTEGER, DIMENSION(:), ALLOCATABLE ::  files_highest_variable_id_tmp  !< temporary list of given variable IDs in file
204
205    LOGICAL ::  file_exists  !< true if file to be opened already exists
206
207
208    return_value = 0
209
210#if defined( __parallel )
211    CALL MPI_COMM_SIZE( output_group_comm, nranks, return_value )
212    IF ( return_value == 0 )  CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
213    IF ( return_value == 0 )  THEN
214       WRITE( my_rank_char, '("_",I6.6)' )  my_rank
215    ELSE
216       CALL internal_message( 'error', routine_name // ': MPI error' )
217    ENDIF
218#else
219    nranks = 1
220    my_rank = master_rank
221    WRITE( my_rank_char, '("_",I6.6)' )  my_rank
222#endif
223!
224!-- Check mode (not required, added for compatibility reasons)
225    IF ( TRIM( mode ) == mode_binary )  CONTINUE
226!
227!-- Open binary config file for combining script
228    IF ( return_value == 0  .AND.  binary_open_file_first_call )  THEN
229
230       binary_open_file_first_call = .FALSE.
231       config_file_unit = binary_file_lowest_unit
232
233       IF ( my_rank == master_rank )  THEN
234!
235!--       Remove any pre-existing file
236          INQUIRE( FILE=TRIM( config_file_name ) // TRIM( file_suffix ), EXIST=file_exists )
237
238          IF ( file_exists )  THEN
239             CALL internal_message( 'debug', routine_name //                                       &
240                                    ': Remove existing file ' //                                   &
241                                    TRIM( config_file_name ) // TRIM( file_suffix ) )
242             !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by
243             !>       PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used
244             ! CALL EXECUTE_COMMAND_LINE( &
245             !         COMMAND='rm ' // TRIM( config_file_name ) // TRIM( file_suffix ), &
246             !         WAIT=.TRUE., EXITSTAT=return_value )
247             CALL SYSTEM( 'rm ' // TRIM( config_file_name ) // TRIM( file_suffix ) )
248          ENDIF
249
250          OPEN( config_file_unit, FILE=TRIM( config_file_name ) // TRIM( file_suffix ),            &
251                FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value )
252
253          IF ( return_value == 0 )  THEN
254
255             config_file_open = .TRUE.
256!
257!--          Write some general information to config file
258             WRITE( config_file_unit )  nranks
259             WRITE( config_file_unit )  master_rank
260             WRITE( config_file_unit )  LEN( file_prefix )
261             WRITE( config_file_unit )  file_prefix
262             WRITE( config_file_unit )  charlen
263             WRITE( config_file_unit )  global_id_in_file
264
265          ELSE
266
267             return_value = 1
268             CALL internal_message( 'error', routine_name // ': could not create config' )
269
270          ENDIF
271
272       ENDIF
273
274       next_available_unit = binary_file_lowest_unit + 1
275
276    ENDIF
277!
278!-- Initialize output file: open, write header, initialize variable/dimension IDs
279    IF ( return_value == 0 )  THEN
280
281       bin_filename = file_prefix // TRIM( file_name ) // TRIM( file_suffix ) // my_rank_char
282!
283!--    Remove any pre-existing file
284       INQUIRE( FILE=TRIM( bin_filename ), EXIST=file_exists )
285
286       IF ( file_exists )  THEN
287          CALL internal_message( 'debug', routine_name //                                          &
288                                 ': remove existing file ' // TRIM( bin_filename ) )
289          !> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by
290          !>       PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used
291          ! CALL EXECUTE_COMMAND_LINE( COMMAND='rm ' // TRIM( bin_filename ), &
292          !                            WAIT=.TRUE., EXITSTAT=return_value )
293          CALL SYSTEM( 'rm ' // TRIM( bin_filename ) )
294       ENDIF
295!
296!--    Open binary file
297       CALL internal_message( 'debug', routine_name // ': open file ' // TRIM( bin_filename ) )
298       OPEN ( next_available_unit, FILE=TRIM( bin_filename ), FORM='UNFORMATTED', STATUS='NEW',    &
299              IOSTAT=return_value )
300
301       IF ( return_value == 0 )  THEN
302!
303!--       Add file_name to config file
304          IF ( my_rank == master_rank )  THEN
305             WRITE( config_file_unit )  file_name
306          ENDIF
307!
308!--       Save file ID and increase next file unit number
309          file_id = next_available_unit
310          next_available_unit = next_available_unit + 1
311!
312!--       Write some meta data to file
313          WRITE ( file_id )  charlen
314          WRITE ( file_id )  file_id
315          WRITE ( file_id )  file_name
316!
317!--       Extend file-variable/dimension-ID list by 1 and set it to 0 for new file.
318          IF ( ALLOCATED( files_highest_variable_id ) )  THEN
319             ALLOCATE( files_highest_variable_id_tmp(SIZE( files_highest_variable_id )) )
320             files_highest_variable_id_tmp = files_highest_variable_id
321             DEALLOCATE( files_highest_variable_id )
322             ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
323             files_highest_variable_id(:file_id-1) = files_highest_variable_id_tmp
324             DEALLOCATE( files_highest_variable_id_tmp )
325          ELSE
326             ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
327          ENDIF
328          files_highest_variable_id(file_id) = 0
329
330       ELSE
331          return_value = 1
332          CALL internal_message( 'error', routine_name //                                          &
333                                 ': could not open file "' // TRIM( file_name ) // '"')
334       ENDIF
335
336    ENDIF
337
338 END SUBROUTINE binary_open_file
339
340!--------------------------------------------------------------------------------------------------!
341! Description:
342! ------------
343!> Write attribute to file.
344!--------------------------------------------------------------------------------------------------!
345 SUBROUTINE binary_write_attribute( file_id, variable_id, attribute_name, value_char, value_int8,  &
346                                    value_int16, value_int32, value_real32, value_real64,          &
347                                    return_value )
348
349    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_write_attribute'  !< name of this routine
350
351    CHARACTER(LEN=charlen), INTENT(IN)           ::  attribute_name  !< name of attribute
352    CHARACTER(LEN=charlen)                       ::  attribute_type  !< data type of attribute
353    CHARACTER(LEN=charlen)                       ::  output_string   !< output string
354    CHARACTER(LEN=charlen), INTENT(IN), OPTIONAL ::  value_char      !< value of attribute
355
356    INTEGER, INTENT(IN)  ::  file_id       !< file ID
357    INTEGER, INTENT(OUT) ::  return_value  !< return value
358    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
359
360    INTEGER(KIND=1), INTENT(IN), OPTIONAL ::  value_int8   !< value of attribute
361    INTEGER(KIND=2), INTENT(IN), OPTIONAL ::  value_int16  !< value of attribute
362    INTEGER(KIND=4), INTENT(IN), OPTIONAL ::  value_int32  !< value of attribute
363
364    REAL(KIND=4), INTENT(IN), OPTIONAL ::  value_real32  !< value of attribute
365    REAL(KIND=8), INTENT(IN), OPTIONAL ::  value_real64  !< value of attribute
366
367
368    return_value = 0
369
370    CALL internal_message( 'debug', TRIM( routine_name ) //                                        &
371                           ': write attribute ' // TRIM( attribute_name ) )
372!
373!-- Write attribute to file
374    output_string = 'attribute'
375    WRITE( file_id )  output_string
376
377    WRITE( file_id )  variable_id
378    WRITE( file_id )  attribute_name
379
380    IF ( PRESENT( value_char ) )  THEN
381       attribute_type = 'char'
382       WRITE( file_id )  attribute_type
383       WRITE( file_id )  value_char
384    ELSEIF ( PRESENT( value_int8 ) )  THEN
385       attribute_type = 'int8'
386       WRITE( file_id )  attribute_type
387       WRITE( file_id )  value_int8
388    ELSEIF ( PRESENT( value_int16 ) )  THEN
389       attribute_type = 'int16'
390       WRITE( file_id )  attribute_type
391       WRITE( file_id )  value_int16
392    ELSEIF ( PRESENT( value_int32 ) )  THEN
393       attribute_type = 'int32'
394       WRITE( file_id )  attribute_type
395       WRITE( file_id )  value_int32
396    ELSEIF ( PRESENT( value_real32 ) )  THEN
397       attribute_type = 'real32'
398       WRITE( file_id )  attribute_type
399       WRITE( file_id )  value_real32
400    ELSEIF ( PRESENT( value_real64 ) )  THEN
401       attribute_type = 'real64'
402       WRITE( file_id )  attribute_type
403       WRITE( file_id )  value_real64
404    ELSE
405       return_value = 1
406       CALL internal_message( 'error', TRIM( routine_name ) //                                     &
407                              ': no value given for attribute "' // TRIM( attribute_name ) // '"' )
408    ENDIF
409
410 END SUBROUTINE binary_write_attribute
411
412!--------------------------------------------------------------------------------------------------!
413! Description:
414! ------------
415!> Initialize dimension. Write information in file header and save dimension values to be later
416!> written to file.
417!--------------------------------------------------------------------------------------------------!
418 SUBROUTINE binary_init_dimension( mode, file_id, dimension_id, variable_id, dimension_name,       &
419                                   dimension_type, dimension_length, write_only_by_master_rank,    &
420                                   return_value )
421
422    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_init_dimension'  !< name of this routine
423
424    CHARACTER(LEN=charlen), INTENT(IN) ::  dimension_name  !< name of dimension
425    CHARACTER(LEN=charlen), INTENT(IN) ::  dimension_type  !< data type of dimension
426    CHARACTER(LEN=*),       INTENT(IN) ::  mode            !< operation mode
427    CHARACTER(LEN=charlen)             ::  output_string   !< output string
428
429    INTEGER, INTENT(OUT) ::  dimension_id      !< dimension ID
430    INTEGER, INTENT(IN)  ::  dimension_length  !< length of dimension
431    INTEGER, INTENT(IN)  ::  file_id           !< file ID
432    INTEGER, INTENT(OUT) ::  return_value      !< return value
433    INTEGER, INTENT(OUT) ::  variable_id       !< variable ID
434
435    LOGICAL, INTENT(IN) ::  write_only_by_master_rank  !< true if only master rank shall write variable
436
437
438    return_value = 0
439
440    CALL internal_message( 'debug', routine_name // ': init dimension ' // TRIM( dimension_name ) )
441!
442!-- Required for compatibility reasons
443    IF ( TRIM( mode ) == mode_binary )  CONTINUE
444!
445!-- Assign dimension ID
446    dimension_id = files_highest_variable_id( file_id ) + 1
447    files_highest_variable_id( file_id ) = dimension_id
448!
449!-- Define dimension in file
450    output_string = 'dimension'
451    WRITE( file_id )  output_string
452    WRITE( file_id )  dimension_name
453    WRITE( file_id )  dimension_id
454    WRITE( file_id )  dimension_type
455    WRITE( file_id )  dimension_length
456!
457!-- Define variable associated with dimension
458    CALL binary_init_variable( mode, file_id, variable_id, dimension_name, dimension_type,         &
459                               (/ dimension_id /),                                                 &
460                               write_only_by_master_rank=write_only_by_master_rank,                &
461                               return_value=return_value )
462
463    IF ( return_value /= 0 )  THEN
464       CALL internal_message( 'error', routine_name //                                             &
465                              ': init dimension "' // TRIM( dimension_name ) // '"' )
466    ENDIF
467
468 END SUBROUTINE binary_init_dimension
469
470!--------------------------------------------------------------------------------------------------!
471! Description:
472! ------------
473!> Initialize variable. Write information of variable into file header.
474!--------------------------------------------------------------------------------------------------!
475 SUBROUTINE binary_init_variable( mode, file_id, variable_id, variable_name, variable_type,        &
476                                  dimension_ids, write_only_by_master_rank, return_value )
477
478    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_init_variable'  !< name of this routine
479
480    CHARACTER(LEN=*),       INTENT(IN) ::  mode            !< operation mode
481    CHARACTER(LEN=charlen)             ::  output_string   !< output string
482    CHARACTER(LEN=charlen), INTENT(IN) ::  variable_name   !< name of variable
483    CHARACTER(LEN=charlen), INTENT(IN) ::  variable_type   !< data type of variable
484
485    INTEGER, INTENT(IN)  ::  file_id       !< file ID
486    INTEGER, INTENT(OUT) ::  return_value  !< return value
487    INTEGER, INTENT(OUT) ::  variable_id   !< variable ID
488
489    INTEGER, DIMENSION(:), INTENT(IN) ::  dimension_ids  !< list of dimension IDs used by variable
490
491    LOGICAL, INTENT(IN) ::  write_only_by_master_rank  !< true if only master rank shall write variable
492
493
494    return_value = 0
495
496    CALL internal_message( 'debug', routine_name // ': init variable ' // TRIM( variable_name ) )
497!
498!-- Required for compatibility reasons
499    IF ( TRIM( mode ) == mode_binary )  CONTINUE
500    IF ( write_only_by_master_rank )  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 //                                                &
536                           ': finalize file definition (file_id=' // 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               write_only_by_master_rank,                                                          &
551               values_char_0d,   values_char_1d,   values_char_2d,   values_char_3d,               &
552               values_int8_0d,   values_int8_1d,   values_int8_2d,   values_int8_3d,               &
553               values_int16_0d,  values_int16_1d,  values_int16_2d,  values_int16_3d,              &
554               values_int32_0d,  values_int32_1d,  values_int32_2d,  values_int32_3d,              &
555               values_intwp_0d,  values_intwp_1d,  values_intwp_2d,  values_intwp_3d,              &
556               values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d,             &
557               values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d,             &
558               values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d,             &
559               return_value )
560
561    CHARACTER(LEN=*), PARAMETER ::  routine_name = 'binary_write_variable'  !< name of this routine
562
563    CHARACTER(LEN=charlen) ::  output_string  !< output string
564
565    CHARACTER(LEN=1), POINTER,             INTENT(IN), OPTIONAL                   ::  values_char_0d  !< output variable
566    CHARACTER(LEN=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_char_1d  !< output variable
567    CHARACTER(LEN=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_char_2d  !< output variable
568    CHARACTER(LEN=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_char_3d  !< output variable
569
570    INTEGER, INTENT(IN)  ::  file_id       !< file ID
571    INTEGER, INTENT(OUT) ::  return_value  !< return value
572    INTEGER, INTENT(IN)  ::  variable_id   !< variable ID
573
574    INTEGER, DIMENSION(:), INTENT(IN) ::  bounds_origin  !< starting index of each dimension
575    INTEGER, DIMENSION(:), INTENT(IN) ::  bounds_start   !< starting index of variable
576    INTEGER, DIMENSION(:), INTENT(IN) ::  value_counts   !< count of values along each dimension to be written
577
578    INTEGER(KIND=1), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int8_0d   !< output variable
579    INTEGER(KIND=2), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int16_0d  !< output variable
580    INTEGER(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_int32_0d  !< output variable
581    INTEGER(iwp),    POINTER,             INTENT(IN), OPTIONAL                   ::  values_intwp_0d  !< output variable
582    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int8_1d   !< output variable
583    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int16_1d  !< output variable
584    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_int32_1d  !< output variable
585    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_intwp_1d  !< output variable
586    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int8_2d   !< output variable
587    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int16_2d  !< output variable
588    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_int32_2d  !< output variable
589    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_intwp_2d  !< output variable
590    INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int8_3d   !< output variable
591    INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int16_3d  !< output variable
592    INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_int32_3d  !< output variable
593    INTEGER(iwp),    POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_intwp_3d  !< output variable
594
595    LOGICAL, INTENT(IN) ::  write_only_by_master_rank  !< true if only master rank shall write variable
596
597    REAL(KIND=4), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real32_0d  !< output variable
598    REAL(KIND=8), POINTER,             INTENT(IN), OPTIONAL                   ::  values_real64_0d  !< output variable
599    REAL(wp),     POINTER,             INTENT(IN), OPTIONAL                   ::  values_realwp_0d  !< output variable
600    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real32_1d  !< output variable
601    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_real64_1d  !< output variable
602    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:)     ::  values_realwp_1d  !< output variable
603    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real32_2d  !< output variable
604    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_real64_2d  !< output variable
605    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:)   ::  values_realwp_2d  !< output variable
606    REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real32_3d  !< output variable
607    REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_real64_3d  !< output variable
608    REAL(wp),     POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) ::  values_realwp_3d  !< output variable
609
610
611    return_value = 0
612
613    WRITE( temp_string, '(": write variable ",I6," into file ",I6)' ) variable_id, file_id
614    CALL internal_message( 'debug', routine_name // TRIM( temp_string ) )
615!
616!-- Required for compatibility reasons
617    IF ( write_only_by_master_rank )  CONTINUE
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.