Home

Context Navigation

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

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