Home

Context Navigation

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

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |