Home

Context Navigation

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

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