Home


About us
PALM
PALM-4U
Installation
Release notes
Documentation
Getting Help
Gallery
Developers area

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

Last change on this file since 4096 was 4070, checked in by gronemeier, 5 years ago

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