Home

Context Navigation

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

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