Home

Context Navigation

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

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