Home

Context Navigation

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

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