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

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

changes in data-output module (data_output_module.f90, data_output_binary_module.f90, data_output_netcdf4_module.f90, binary_to_netcdf.f90):

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