Home

Context Navigation

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

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