Home

Context Navigation

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

Last change on this file since 4554 was 4481, checked in by maronga, 5 years ago
Bugfix for copyright updates in document_changes; copyright update applied to all files
Property svn:keywords set to `Id`
File size: 36.0 KB

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