Home

Context Navigation

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

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