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

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

bugfix: replace f08 procedure "execute_command_line" by non-standard procedure "system" due to missing compiler implementation in PGI compiler

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