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

Last change on this file since 4554 was 4481, checked in by maronga, 5 years ago

Bugfix for copyright updates in document_changes; copyright update applied to all files

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