Home

Context Navigation

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

Last change on this file since 4106 was 4106, checked in by gronemeier, 5 years ago
combine new netcdf4 output modules into a single module; improvements of DOM error messages; check initialization state of file before defining/writing anything; improvements in binary output
Property svn:keywords set to `Id`
File size: 30.8 KB

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