Home

Context Navigation

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

Last change on this file since 4577 was 4577, checked in by raasch, 4 years ago
further re-formatting to follow the PALM coding standard
Property svn:keywords set to `Id`
File size: 37.5 KB

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