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

Last change on this file since 4106 was 4106, checked in by gronemeier, 2 years ago

combine new netcdf4 output modules into a single module; improvements of DOM error messages; check initialization state of file before defining/writing anything; improvements in binary output

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