Home

Context Navigation

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

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