Home

Context Navigation

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

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