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

Last change on this file since 4571 was 4559, checked in by raasch, 4 years ago

files re-formatted to follow the PALM coding standard

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