Home

Context Navigation

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

Last change on this file since 4143 was 4141, checked in by gronemeier, 5 years ago

changes in data-output module (data_output_binary_module, data_output_module, data_output_netcdf4_module, binary_to_netcdf):

renaming of variables
changes to formatting and layout
update routine descriptions

Property svn:keywords set to Id

File size: 34.0 KB

Rev	Line
[4070]	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	! ------------------
[4106]	22	!
	23	!
[4070]	24	! Former revisions:
	25	! -----------------
	26	! $Id: data_output_binary_module.f90 4141 2019-08-05 12:24:51Z schwenkel $
	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	!>
[4106]	38	!> @todo Get iostat value of write statements.
[4070]	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
[4141]	54	INTEGER, PARAMETER :: charlen = 100 !< maximum length of character variables
[4070]	55
	56	CHARACTER(LEN=*), PARAMETER :: config_file_name = 'BINARY_TO_NETCDF_CONFIG' !< name of config file
[4106]	57	CHARACTER(LEN=*), PARAMETER :: mode_binary = 'binary' !< string to select operation mode of module
[4107]	58	CHARACTER(LEN=*), PARAMETER :: file_prefix = 'BIN_' !< file prefix for binary files
[4070]	59
[4107]	60	CHARACTER(LEN=charlen) :: file_suffix = '' !< file suffix added to each file name
[4070]	61	CHARACTER(LEN=800) :: internal_error_message = '' !< string containing the last error message
	62	CHARACTER(LEN=800) :: temp_string !< dummy string
	63
[4141]	64	INTEGER :: binary_file_lowest_unit = 1000 !< lowest unit number of all binary files created by this module
	65	INTEGER :: config_file_unit !< unit number of config file
	66	INTEGER :: debug_output_unit !< Fortran Unit Number of the debug-output file
	67	INTEGER :: 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 :: 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
[4070]	71
[4141]	72	INTEGER, DIMENSION(:), ALLOCATABLE :: files_highest_variable_id !< highest assigned ID of variable or dimension in a file
[4070]	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
[4141]	102	INTERFACE binary_stop_file_header_definition
	103	MODULE PROCEDURE binary_stop_file_header_definition
	104	END INTERFACE binary_stop_file_header_definition
[4070]	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, &
[4141]	122	binary_stop_file_header_definition, &
[4070]	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	!--------------------------------------------------------------------------------------------------!
[4107]	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 )
[4070]	141
[4107]	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
[4141]	145	INTEGER, 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, INTENT(IN) :: program_debug_output_unit !< file unit number for debug output
[4070]	149
	150	LOGICAL, INTENT(IN) :: debug_output !< if true, debug output is printed
	151
	152
[4107]	153	file_suffix = file_suffix_of_output_group
	154	output_group_comm = mpi_comm_of_output_group
	155	master_rank = master_output_rank
	156
[4070]	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	!--------------------------------------------------------------------------------------------------!
[4141]	169	SUBROUTINE binary_open_file( mode, file_name, file_id, return_value )
[4070]	170
	171	CHARACTER(LEN=charlen) :: bin_filename = '' !< actual name of binary file
[4141]	172	CHARACTER(LEN=charlen), INTENT(IN) :: file_name !< name of file
[4107]	173	CHARACTER(LEN=7) :: my_rank_char !< string containing value of my_rank with leading zeros
[4106]	174	CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode
[4070]	175
	176	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_open_file' !< name of this routine
	177
[4141]	178	INTEGER, INTENT(OUT) :: file_id !< file ID
	179	INTEGER :: my_rank !< MPI rank of local processor
	180	INTEGER :: nranks !< number of MPI ranks participating in output
	181	INTEGER, INTENT(OUT) :: return_value !< return value
[4070]	182
[4141]	183	INTEGER, DIMENSION(:), ALLOCATABLE :: files_highest_variable_id_tmp !< temporary list of given variable IDs in file
[4070]	184
	185	LOGICAL :: file_exists !< true if file to be opened already exists
	186
	187
	188	return_value = 0
	189
	190	#if defined( __parallel )
[4141]	191	CALL MPI_COMM_SIZE( output_group_comm, nranks, return_value )
[4107]	192	IF ( return_value == 0 ) CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
[4070]	193	IF ( return_value == 0 ) THEN
[4107]	194	WRITE( my_rank_char, '("_",I6.6)' ) my_rank
[4070]	195	ELSE
[4107]	196	CALL internal_message( 'error', routine_name // ': MPI error' )
[4070]	197	ENDIF
	198	#else
[4141]	199	nranks = 1
[4107]	200	my_rank = master_rank
	201	WRITE( my_rank_char, '("_",I6.6)' ) my_rank
[4070]	202	#endif
	203
[4106]	204	!-- Check mode (not required, added for compatibility reasons)
	205	IF ( TRIM( mode ) == mode_binary ) CONTINUE
	206
[4070]	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
[4107]	213	IF ( my_rank == master_rank ) THEN
[4070]	214
	215	!-- Remove any pre-existing file
[4107]	216	INQUIRE( FILE=TRIM( config_file_name ) // TRIM( file_suffix ), &
	217	EXIST=file_exists )
[4070]	218
	219	IF ( file_exists ) THEN
[4107]	220	CALL internal_message( 'debug', routine_name // &
	221	': Remove existing file ' // &
	222	TRIM( config_file_name ) // TRIM( file_suffix ) )
[4108]	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 ) )
[4070]	229	ENDIF
	230
[4107]	231	OPEN( config_file_unit, FILE=TRIM( config_file_name ) // TRIM( file_suffix ), &
[4070]	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
[4141]	239	WRITE( config_file_unit ) nranks
[4107]	240	WRITE( config_file_unit ) master_rank
	241	WRITE( config_file_unit ) LEN( file_prefix )
	242	WRITE( config_file_unit ) file_prefix
[4070]	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
[4141]	262	bin_filename = file_prefix // TRIM( file_name ) // TRIM( file_suffix ) // my_rank_char
[4070]	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 // &
[4141]	269	': remove existing file ' // TRIM( bin_filename ) )
[4108]	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 ) )
[4070]	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
[4141]	284	!-- Add file_name to config file
[4107]	285	IF ( my_rank == master_rank ) THEN
[4141]	286	WRITE( config_file_unit ) file_name
[4070]	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
[4141]	296	WRITE ( file_id ) file_name
[4070]	297
	298	!-- Extend file-variable/dimension-ID list by 1 and set it to 0 for new file.
[4141]	299	IF ( ALLOCATED( files_highest_variable_id ) ) THEN
	300	ALLOCATE( files_highest_variable_id_tmp(SIZE( files_highest_variable_id )) )
	301	files_highest_variable_id_tmp = files_highest_variable_id
	302	DEALLOCATE( files_highest_variable_id )
	303	ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
	304	files_highest_variable_id(:file_id-1) = files_highest_variable_id_tmp
	305	DEALLOCATE( files_highest_variable_id_tmp )
[4070]	306	ELSE
[4141]	307	ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
[4070]	308	ENDIF
[4141]	309	files_highest_variable_id(file_id) = 0
[4070]	310
	311	ELSE
	312	return_value = 1
	313	CALL internal_message( 'error', routine_name // &
[4141]	314	': could not open file "' // TRIM( file_name ) // '"')
[4070]	315	ENDIF
	316
	317	ENDIF
	318
	319	END SUBROUTINE binary_open_file
	320
	321	!--------------------------------------------------------------------------------------------------!
	322	! Description:
	323	! ------------
	324	!> Write attribute to file.
	325	!--------------------------------------------------------------------------------------------------!
[4141]	326	SUBROUTINE binary_write_attribute( file_id, variable_id, attribute_name, &
	327	value_char, value_int8, value_int16, value_int32, &
	328	value_real32, value_real64, return_value )
[4070]	329
	330	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_write_attribute' !< name of this routine
	331
[4141]	332	CHARACTER(LEN=charlen), INTENT(IN) :: attribute_name !< name of attribute
	333	CHARACTER(LEN=charlen), INTENT(IN), OPTIONAL :: value_char !< value of attribute
	334	CHARACTER(LEN=charlen) :: attribute_type !< data type of attribute
	335	CHARACTER(LEN=charlen) :: output_string !< output string
[4070]	336
[4141]	337	INTEGER(KIND=1), INTENT(IN), OPTIONAL :: value_int8 !< value of attribute
	338	INTEGER(KIND=2), INTENT(IN), OPTIONAL :: value_int16 !< value of attribute
	339	INTEGER(KIND=4), INTENT(IN), OPTIONAL :: value_int32 !< value of attribute
[4070]	340
[4141]	341	INTEGER, INTENT(IN) :: file_id !< file ID
	342	INTEGER, INTENT(IN) :: variable_id !< variable ID
	343	INTEGER, INTENT(OUT) :: return_value !< return value
[4070]	344
[4141]	345	REAL(KIND=4), INTENT(IN), OPTIONAL :: value_real32 !< value of attribute
	346	REAL(KIND=8), INTENT(IN), OPTIONAL :: value_real64 !< value of attribute
[4070]	347
	348
	349	return_value = 0
	350
	351	CALL internal_message( 'debug', TRIM( routine_name ) // &
[4141]	352	': write attribute ' // TRIM( attribute_name ) )
[4070]	353
	354	!-- Write attribute to file
[4141]	355	output_string = 'attribute'
	356	WRITE( file_id ) output_string
[4070]	357
[4141]	358	WRITE( file_id ) variable_id
	359	WRITE( file_id ) attribute_name
[4070]	360
[4141]	361	IF ( PRESENT( value_char ) ) THEN
	362	attribute_type = 'char'
	363	WRITE( file_id ) attribute_type
	364	WRITE( file_id ) value_char
	365	ELSEIF ( PRESENT( value_int8 ) ) THEN
	366	attribute_type = 'int8'
	367	WRITE( file_id ) attribute_type
	368	WRITE( file_id ) value_int8
	369	ELSEIF ( PRESENT( value_int16 ) ) THEN
	370	attribute_type = 'int16'
	371	WRITE( file_id ) attribute_type
	372	WRITE( file_id ) value_int16
	373	ELSEIF ( PRESENT( value_int32 ) ) THEN
	374	attribute_type = 'int32'
	375	WRITE( file_id ) attribute_type
	376	WRITE( file_id ) value_int32
	377	ELSEIF ( PRESENT( value_real32 ) ) THEN
	378	attribute_type = 'real32'
	379	WRITE( file_id ) attribute_type
	380	WRITE( file_id ) value_real32
	381	ELSEIF ( PRESENT( value_real64 ) ) THEN
	382	attribute_type = 'real64'
	383	WRITE( file_id ) attribute_type
	384	WRITE( file_id ) value_real64
[4070]	385	ELSE
	386	return_value = 1
	387	CALL internal_message( 'error', TRIM( routine_name ) // &
[4141]	388	': no value given for attribute "' // TRIM( attribute_name ) // '"' )
[4070]	389	ENDIF
	390
	391	END SUBROUTINE binary_write_attribute
	392
	393	!--------------------------------------------------------------------------------------------------!
	394	! Description:
	395	! ------------
[4141]	396	!> Initialize dimension. Write information in file header
	397	!> and save dimension values to be later written to file.
[4070]	398	!--------------------------------------------------------------------------------------------------!
[4141]	399	SUBROUTINE binary_init_dimension( mode, file_id, dimension_id, variable_id, &
	400	dimension_name, dimension_type, dimension_length, return_value )
[4070]	401
[4141]	402	CHARACTER(LEN=charlen), INTENT(IN) :: dimension_name !< name of dimension
	403	CHARACTER(LEN=charlen), INTENT(IN) :: dimension_type !< data type of dimension
	404	CHARACTER(LEN=charlen) :: output_string !< output string
	405	CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode
[4070]	406
	407	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_dimension' !< name of this routine
	408
[4141]	409	INTEGER, INTENT(OUT) :: dimension_id !< dimension ID
	410	INTEGER, INTENT(IN) :: dimension_length !< length of dimension
	411	INTEGER, INTENT(IN) :: file_id !< file ID
	412	INTEGER, INTENT(OUT) :: return_value !< return value
	413	INTEGER, INTENT(OUT) :: variable_id !< variable ID
[4070]	414
	415
	416	return_value = 0
	417
[4141]	418	CALL internal_message( 'debug', routine_name // ': init dimension ' // TRIM( dimension_name ) )
[4070]	419
[4106]	420	!-- Check mode (not required, added for compatibility reasons only)
	421	IF ( TRIM( mode ) == mode_binary ) CONTINUE
	422
[4070]	423	!-- Assign dimension ID
[4141]	424	dimension_id = files_highest_variable_id( file_id ) + 1
	425	files_highest_variable_id( file_id ) = dimension_id
[4070]	426
	427	!-- Define dimension in file
[4141]	428	output_string = 'dimension'
	429	WRITE( file_id ) output_string
	430	WRITE( file_id ) dimension_name
	431	WRITE( file_id ) dimension_id
	432	WRITE( file_id ) dimension_type
	433	WRITE( file_id ) dimension_length
[4070]	434
	435	!-- Define variable associated with dimension
[4141]	436	CALL binary_init_variable( mode, file_id, variable_id, dimension_name, dimension_type, &
	437	(/ dimension_id /), is_global=.TRUE., return_value=return_value )
[4070]	438	IF ( return_value /= 0 ) THEN
	439	CALL internal_message( 'error', routine_name // &
[4141]	440	': init dimension "' // TRIM( dimension_name ) // '"' )
[4070]	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	!--------------------------------------------------------------------------------------------------!
[4141]	450	SUBROUTINE binary_init_variable( mode, file_id, variable_id, variable_name, variable_type, &
	451	dimension_ids, is_global, return_value )
[4070]	452
[4141]	453	CHARACTER(LEN=charlen) :: output_string !< output string
	454	CHARACTER(LEN=charlen), INTENT(IN) :: variable_name !< name of variable
	455	CHARACTER(LEN=charlen), INTENT(IN) :: variable_type !< data type of variable
	456	CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode
[4070]	457
	458	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_variable' !< name of this routine
	459
[4141]	460	INTEGER, INTENT(IN) :: file_id !< file ID
	461	INTEGER, INTENT(OUT) :: variable_id !< variable ID
	462	INTEGER, INTENT(OUT) :: return_value !< return value
[4070]	463
[4141]	464	INTEGER, DIMENSION(:), INTENT(IN) :: dimension_ids !< list of dimension IDs used by variable
[4070]	465
	466	LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE)
	467
	468
	469	return_value = 0
	470
[4141]	471	CALL internal_message( 'debug', routine_name // ': init variable ' // TRIM( variable_name ) )
[4070]	472
[4106]	473	!-- Check mode (not required, added for compatibility reasons only)
	474	IF ( TRIM( mode ) == mode_binary ) CONTINUE
[4070]	475
[4106]	476	!-- Check if variable is global (not required, added for compatibility reasons only)
	477	IF ( is_global ) CONTINUE
	478
[4070]	479	!-- Assign variable ID
[4141]	480	variable_id = files_highest_variable_id( file_id ) + 1
	481	files_highest_variable_id( file_id ) = variable_id
[4070]	482
	483	!-- Write variable information in file
[4141]	484	output_string = 'variable'
	485	WRITE( file_id ) output_string
	486	WRITE( file_id ) variable_name
	487	WRITE( file_id ) variable_id
	488	WRITE( file_id ) variable_type
	489	WRITE( file_id ) SIZE( dimension_ids )
	490	WRITE( file_id ) dimension_ids
[4070]	491
	492	END SUBROUTINE binary_init_variable
	493
	494	!--------------------------------------------------------------------------------------------------!
	495	! Description:
	496	! ------------
	497	!> Leave file definition state.
	498	!--------------------------------------------------------------------------------------------------!
[4141]	499	SUBROUTINE binary_stop_file_header_definition( file_id, return_value )
[4070]	500
[4141]	501	CHARACTER(LEN=charlen) :: output_string !< output string
[4070]	502
[4141]	503	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_stop_file_header_definition' !< name of this routine
[4070]	504
[4141]	505	INTEGER, INTENT(IN) :: file_id !< file ID
	506	INTEGER, INTENT(OUT) :: return_value !< return value
[4070]	507
	508
	509	return_value = 0
	510
	511	WRITE( temp_string, * ) file_id
[4141]	512	CALL internal_message( 'debug', routine_name // &
[4070]	513	': finalize file definition (file_id=' // TRIM( temp_string ) // ')' )
	514
[4141]	515	output_string = '* end file header *'
	516	WRITE( file_id ) output_string
[4070]	517
[4141]	518	END SUBROUTINE binary_stop_file_header_definition
[4070]	519
	520	!--------------------------------------------------------------------------------------------------!
	521	! Description:
	522	! ------------
	523	!> Write variable to file.
	524	!--------------------------------------------------------------------------------------------------!
[4141]	525	SUBROUTINE binary_write_variable( &
	526	file_id, variable_id, bounds_start, value_counts, bounds_origin, &
	527	is_global, &
	528	values_int8_0d, values_int8_1d, values_int8_2d, values_int8_3d, &
	529	values_int16_0d, values_int16_1d, values_int16_2d, values_int16_3d, &
	530	values_int32_0d, values_int32_1d, values_int32_2d, values_int32_3d, &
	531	values_intwp_0d, values_intwp_1d, values_intwp_2d, values_intwp_3d, &
	532	values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &
	533	values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &
	534	values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d, &
[4070]	535	return_value )
	536
[4141]	537	CHARACTER(LEN=charlen) :: output_string !< output string
[4106]	538
[4070]	539	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_write_variable' !< name of this routine
	540
[4141]	541	INTEGER, INTENT(IN) :: file_id !< file ID
	542	INTEGER, INTENT(OUT) :: return_value !< return value
	543	INTEGER, INTENT(IN) :: variable_id !< variable ID
[4070]	544
[4141]	545	INTEGER, DIMENSION(:), INTENT(IN) :: bounds_origin !< starting index of each dimension
	546	INTEGER, DIMENSION(:), INTENT(IN) :: bounds_start !< starting index of variable
	547	INTEGER, DIMENSION(:), INTENT(IN) :: value_counts !< count of values along each dimension to be written
[4070]	548
[4141]	549	INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL :: values_int8_0d !< output variable
	550	INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL :: values_int16_0d !< output variable
	551	INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_int32_0d !< output variable
	552	INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL :: values_intwp_0d !< output variable
	553	INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int8_1d !< output variable
	554	INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int16_1d !< output variable
	555	INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int32_1d !< output variable
	556	INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_intwp_1d !< output variable
	557	INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int8_2d !< output variable
	558	INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int16_2d !< output variable
	559	INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int32_2d !< output variable
	560	INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_intwp_2d !< output variable
	561	INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int8_3d !< output variable
	562	INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int16_3d !< output variable
	563	INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int32_3d !< output variable
	564	INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_intwp_3d !< output variable
[4070]	565
	566	LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE)
	567
[4141]	568	REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_real32_0d !< output variable
	569	REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL :: values_real64_0d !< output variable
	570	REAL(wp), POINTER, INTENT(IN), OPTIONAL :: values_realwp_0d !< output variable
	571	REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real32_1d !< output variable
	572	REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real64_1d !< output variable
	573	REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_realwp_1d !< output variable
	574	REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real32_2d !< output variable
	575	REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real64_2d !< output variable
	576	REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_realwp_2d !< output variable
	577	REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real32_3d !< output variable
	578	REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real64_3d !< output variable
	579	REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_realwp_3d !< output variable
[4070]	580
	581
	582	return_value = 0
	583
[4141]	584	WRITE( temp_string, '(": write variable ",I6," into file ",I6)' ) variable_id, file_id
[4070]	585	CALL internal_message( 'debug', routine_name // TRIM( temp_string ) )
	586
	587	IF ( is_global ) CONTINUE ! reqired to prevent compiler warning
	588
[4123]	589	IF ( .NOT. ANY( value_counts == 0 ) ) THEN
[4141]	590	WRITE( file_id ) variable_id
[4070]	591	WRITE( file_id ) bounds_start
[4123]	592	WRITE( file_id ) value_counts
[4070]	593	WRITE( file_id ) bounds_origin
	594	!-- 8bit integer output
[4141]	595	IF ( PRESENT( values_int8_0d ) ) THEN
	596	output_string = 'int8'
	597	WRITE( file_id ) output_string
	598	WRITE( file_id ) values_int8_0d
	599	ELSEIF ( PRESENT( values_int8_1d ) ) THEN
	600	output_string = 'int8'
	601	WRITE( file_id ) output_string
	602	WRITE( file_id ) values_int8_1d
	603	ELSEIF ( PRESENT( values_int8_2d ) ) THEN
	604	output_string = 'int8'
	605	WRITE( file_id ) output_string
	606	WRITE( file_id ) values_int8_2d
	607	ELSEIF ( PRESENT( values_int8_3d ) ) THEN
	608	output_string = 'int8'
	609	WRITE( file_id ) output_string
	610	WRITE( file_id ) values_int8_3d
[4070]	611	!-- 16bit integer output
[4141]	612	ELSEIF ( PRESENT( values_int16_0d ) ) THEN
	613	output_string = 'int16'
	614	WRITE( file_id ) output_string
	615	WRITE( file_id ) values_int16_0d
	616	ELSEIF ( PRESENT( values_int16_1d ) ) THEN
	617	output_string = 'int16'
	618	WRITE( file_id ) output_string
	619	WRITE( file_id ) values_int16_1d
	620	ELSEIF ( PRESENT( values_int16_2d ) ) THEN
	621	output_string = 'int16'
	622	WRITE( file_id ) output_string
	623	WRITE( file_id ) values_int16_2d
	624	ELSEIF ( PRESENT( values_int16_3d ) ) THEN
	625	output_string = 'int16'
	626	WRITE( file_id ) output_string
	627	WRITE( file_id ) values_int16_3d
[4070]	628	!-- 32bit integer output
[4141]	629	ELSEIF ( PRESENT( values_int32_0d ) ) THEN
	630	output_string = 'int32'
	631	WRITE( file_id ) output_string
	632	WRITE( file_id ) values_int32_0d
	633	ELSEIF ( PRESENT( values_int32_1d ) ) THEN
	634	output_string = 'int32'
	635	WRITE( file_id ) output_string
	636	WRITE( file_id ) values_int32_1d
	637	ELSEIF ( PRESENT( values_int32_2d ) ) THEN
	638	output_string = 'int32'
	639	WRITE( file_id ) output_string
	640	WRITE( file_id ) values_int32_2d
	641	ELSEIF ( PRESENT( values_int32_3d ) ) THEN
	642	output_string = 'int32'
	643	WRITE( file_id ) output_string
	644	WRITE( file_id ) values_int32_3d
[4070]	645	!-- working-precision integer output
[4141]	646	ELSEIF ( PRESENT( values_intwp_0d ) ) THEN
	647	output_string = 'intwp'
	648	WRITE( file_id ) output_string
	649	WRITE( file_id ) values_intwp_0d
	650	ELSEIF ( PRESENT( values_intwp_1d ) ) THEN
	651	output_string = 'intwp'
	652	WRITE( file_id ) output_string
	653	WRITE( file_id ) values_intwp_1d
	654	ELSEIF ( PRESENT( values_intwp_2d ) ) THEN
	655	output_string = 'intwp'
	656	WRITE( file_id ) output_string
	657	WRITE( file_id ) values_intwp_2d
	658	ELSEIF ( PRESENT( values_intwp_3d ) ) THEN
	659	output_string = 'intwp'
	660	WRITE( file_id ) output_string
	661	WRITE( file_id ) values_intwp_3d
[4070]	662	!-- 32bit real output
[4141]	663	ELSEIF ( PRESENT( values_real32_0d ) ) THEN
	664	output_string = 'real32'
	665	WRITE( file_id ) output_string
	666	WRITE( file_id ) values_real32_0d
	667	ELSEIF ( PRESENT( values_real32_1d ) ) THEN
	668	output_string = 'real32'
	669	WRITE( file_id ) output_string
	670	WRITE( file_id ) values_real32_1d
	671	ELSEIF ( PRESENT( values_real32_2d ) ) THEN
	672	output_string = 'real32'
	673	WRITE( file_id ) output_string
	674	WRITE( file_id ) values_real32_2d
	675	ELSEIF ( PRESENT( values_real32_3d ) ) THEN
	676	output_string = 'real32'
	677	WRITE( file_id ) output_string
	678	WRITE( file_id ) values_real32_3d
[4070]	679	!-- 64bit real output
[4141]	680	ELSEIF ( PRESENT( values_real64_0d ) ) THEN
	681	output_string = 'real64'
	682	WRITE( file_id ) output_string
	683	WRITE( file_id ) values_real64_0d
	684	ELSEIF ( PRESENT( values_real64_1d ) ) THEN
	685	output_string = 'real64'
	686	WRITE( file_id ) output_string
	687	WRITE( file_id ) values_real64_1d
	688	ELSEIF ( PRESENT( values_real64_2d ) ) THEN
	689	output_string = 'real64'
	690	WRITE( file_id ) output_string
	691	WRITE( file_id ) values_real64_2d
	692	ELSEIF ( PRESENT( values_real64_3d ) ) THEN
	693	output_string = 'real64'
	694	WRITE( file_id ) output_string
	695	WRITE( file_id ) values_real64_3d
[4070]	696	!-- working-precision real output
[4141]	697	ELSEIF ( PRESENT( values_realwp_0d ) ) THEN
	698	output_string = 'realwp'
	699	WRITE( file_id ) output_string
	700	WRITE( file_id ) values_realwp_0d
	701	ELSEIF ( PRESENT( values_realwp_1d ) ) THEN
	702	output_string = 'realwp'
	703	WRITE( file_id ) output_string
	704	WRITE( file_id ) values_realwp_1d
	705	ELSEIF ( PRESENT( values_realwp_2d ) ) THEN
	706	output_string = 'realwp'
	707	WRITE( file_id ) output_string
	708	WRITE( file_id ) values_realwp_2d
	709	ELSEIF ( PRESENT( values_realwp_3d ) ) THEN
	710	output_string = 'realwp'
	711	WRITE( file_id ) output_string
	712	WRITE( file_id ) values_realwp_3d
[4070]	713	ELSE
	714	return_value = 1
[4106]	715	CALL internal_message( 'error', routine_name // ': no values given' )
[4070]	716	ENDIF
	717
	718	ENDIF
	719
	720	END SUBROUTINE binary_write_variable
	721
	722	!--------------------------------------------------------------------------------------------------!
	723	! Description:
	724	! ------------
	725	!> Close opened files.
	726	!--------------------------------------------------------------------------------------------------!
	727	SUBROUTINE binary_finalize( file_id, return_value )
	728
[4141]	729	CHARACTER(LEN=charlen) :: output_string !< output string
[4070]	730
	731	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_finalize' !< name of this routine
	732
[4141]	733	INTEGER, INTENT(IN) :: file_id !< file ID
	734	INTEGER, INTENT(OUT) :: return_value !< return value
[4070]	735
	736
	737	IF ( config_file_open ) THEN
	738
[4141]	739	output_string = '* end config file *'
	740	WRITE( config_file_unit ) output_string
[4070]	741
	742	CLOSE( config_file_unit, IOSTAT=return_value )
	743
	744	IF ( return_value /= 0 ) THEN
	745	CALL internal_message( 'error', routine_name // ': cannot close configuration file' )
	746	ELSE
	747	config_file_open = .FALSE.
	748	ENDIF
	749
	750	ELSE
	751
	752	return_value = 0
	753
	754	ENDIF
	755
	756	IF ( return_value == 0 ) THEN
	757
[4141]	758	WRITE( temp_string, * ) file_id
[4070]	759	CALL internal_message( 'debug', routine_name // &
[4141]	760	': close file (file_id=' // TRIM( temp_string ) // ')' )
[4070]	761
	762	CLOSE( file_id, IOSTAT=return_value )
	763	IF ( return_value /= 0 ) THEN
[4141]	764	WRITE( temp_string, * ) file_id
	765	CALL internal_message( 'error', routine_name // &
[4070]	766	': cannot close file (file_id=' // TRIM( temp_string ) // ')' )
	767	ENDIF
	768
	769	ENDIF
	770
	771	END SUBROUTINE binary_finalize
	772
	773	!--------------------------------------------------------------------------------------------------!
	774	! Description:
	775	! ------------
	776	!> Message routine writing debug information into the debug file
	777	!> or creating the error message string.
	778	!--------------------------------------------------------------------------------------------------!
	779	SUBROUTINE internal_message( level, string )
	780
	781	CHARACTER(LEN=*), INTENT(IN) :: level !< message importance level
	782	CHARACTER(LEN=*), INTENT(IN) :: string !< message string
	783
	784
	785	IF ( TRIM( level ) == 'error' ) THEN
	786
[4106]	787	WRITE( internal_error_message, '(A,A)' ) ': ', string
[4070]	788
	789	ELSEIF ( TRIM( level ) == 'debug' .AND. print_debug_output ) THEN
	790
	791	WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
	792	FLUSH( debug_output_unit )
	793
	794	ENDIF
	795
	796	END SUBROUTINE internal_message
	797
	798	!--------------------------------------------------------------------------------------------------!
	799	! Description:
	800	! ------------
	801	!> Return the last created error message.
	802	!--------------------------------------------------------------------------------------------------!
[4141]	803	FUNCTION binary_get_error_message() RESULT( error_message )
[4070]	804
[4141]	805	CHARACTER(LEN=800) :: error_message !< return error message to main program
[4070]	806
	807
[4141]	808	error_message = TRIM( internal_error_message )
	809
	810	internal_error_message = ''
[4070]	811
[4141]	812	END FUNCTION binary_get_error_message
[4070]	813
	814	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 |