Home

Context Navigation

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

Last change on this file since 4594 was 4579, checked in by gronemeier, 4 years ago
corrected formatting to follow PALM coding standard (data_output_module, data_output_binary_module, data_output_netcdf4_module)
Property svn:keywords set to `Id`
File size: 37.7 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 4579 2020-06-25 20:05:07Z suehring $
[4579]	26	! corrected formatting to follow PALM coding standard
	27	!
	28	! 4577 2020-06-25 09:53:58Z raasch
[4577]	29	! further re-formatting to follow the PALM coding standard
	30	!
	31	! 4559 2020-06-11 08:51:48Z raasch
[4559]	32	! file re-formatted to follow the PALM coding standard
	33	!
	34	! 4481 2020-03-31 18:55:54Z maronga
[4408]	35	! Enable character-array output
	36	!
	37	! 4232 2019-09-20 09:34:22Z knoop
[4232]	38	! Bugfix: INCLUDE "mpif.h" must be placed after IMPLICIT NONE statement
	39	!
	40	! 4147 2019-08-07 09:42:31Z gronemeier
[4147]	41	! corrected indentation according to coding standard
	42	!
	43	! 4141 2019-08-05 12:24:51Z gronemeier
[4070]	44	! Initial revision
	45	!
	46	!
	47	! Authors:
	48	! --------
	49	!> @author: Tobias Gronemeier
	50	!
	51	! Description:
	52	! ------------
	53	!> Binary output module to write output data into binary files.
	54	!>
[4106]	55	!> @todo Get iostat value of write statements.
[4070]	56	!--------------------------------------------------------------------------------------------------!
[4147]	57	MODULE data_output_binary_module
[4070]	58
[4147]	59	USE kinds
[4070]	60
[4232]	61	#if defined( __parallel ) && !defined( __mpifh )
[4147]	62	USE MPI
[4070]	63	#endif
	64
[4147]	65	IMPLICIT NONE
[4070]	66
[4232]	67	#if defined( __parallel ) && defined( __mpifh )
	68	INCLUDE "mpif.h"
	69	#endif
	70
[4559]	71
[4577]	72	CHARACTER(LEN=*), PARAMETER :: config_file_name = 'BINARY_TO_NETCDF_CONFIG' !< name of config file
	73	CHARACTER(LEN=*), PARAMETER :: file_prefix = 'BIN_' !< file prefix for binary files
	74	CHARACTER(LEN=*), PARAMETER :: mode_binary = 'binary' !< string to select operation mode of module
[4559]	75
[4147]	76	INTEGER, PARAMETER :: charlen = 100 !< maximum length of character variables
[4070]	77
[4577]	78	CHARACTER(LEN=charlen) :: file_suffix = '' !< file suffix added to each file name
	79	CHARACTER(LEN=800) :: internal_error_message = '' !< string containing the last error message
[4147]	80	CHARACTER(LEN=800) :: temp_string !< dummy string
[4070]	81
[4577]	82	INTEGER :: binary_file_lowest_unit = 1000 !< lowest unit number of all binary files created by 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
[4577]	86	INTEGER :: master_rank !< master rank for tasks to be executed by single PE only
[4147]	87	INTEGER :: next_available_unit !< next unit number available for new file
[4577]	88	INTEGER :: output_group_comm !< MPI communicator addressing all MPI ranks which participate in output
[4070]	89
[4559]	90	INTEGER, DIMENSION(:), ALLOCATABLE :: files_highest_variable_id !< highest assigned ID of
	91	!< variable or dimension in a file
[4070]	92
[4559]	93	LOGICAL :: binary_open_file_first_call = .TRUE. !< true if binary_open_file routine was not
	94	!< called yet
	95	LOGICAL :: config_file_open = .FALSE. !< true if config file is opened and not
	96	!< closed
[4147]	97	LOGICAL :: print_debug_output = .FALSE. !< if true, debug output is printed
[4070]	98
[4147]	99	SAVE
[4070]	100
[4147]	101	PRIVATE
[4070]	102
[4147]	103	INTERFACE binary_init_module
	104	MODULE PROCEDURE binary_init_module
	105	END INTERFACE binary_init_module
[4070]	106
[4147]	107	INTERFACE binary_open_file
	108	MODULE PROCEDURE binary_open_file
	109	END INTERFACE binary_open_file
[4070]	110
[4147]	111	INTERFACE binary_init_dimension
	112	MODULE PROCEDURE binary_init_dimension
	113	END INTERFACE binary_init_dimension
[4070]	114
[4147]	115	INTERFACE binary_init_variable
	116	MODULE PROCEDURE binary_init_variable
	117	END INTERFACE binary_init_variable
[4070]	118
[4147]	119	INTERFACE binary_write_attribute
	120	MODULE PROCEDURE binary_write_attribute
	121	END INTERFACE binary_write_attribute
[4070]	122
[4147]	123	INTERFACE binary_stop_file_header_definition
	124	MODULE PROCEDURE binary_stop_file_header_definition
	125	END INTERFACE binary_stop_file_header_definition
[4070]	126
[4147]	127	INTERFACE binary_write_variable
	128	MODULE PROCEDURE binary_write_variable
	129	END INTERFACE binary_write_variable
[4070]	130
[4147]	131	INTERFACE binary_finalize
	132	MODULE PROCEDURE binary_finalize
	133	END INTERFACE binary_finalize
[4070]	134
[4147]	135	INTERFACE binary_get_error_message
	136	MODULE PROCEDURE binary_get_error_message
	137	END INTERFACE binary_get_error_message
[4070]	138
[4559]	139	PUBLIC &
	140	binary_finalize, &
	141	binary_get_error_message, &
	142	binary_init_dimension, &
	143	binary_init_module, &
	144	binary_init_variable, &
	145	binary_open_file, &
	146	binary_stop_file_header_definition, &
	147	binary_write_attribute, &
[4147]	148	binary_write_variable
[4070]	149
	150
[4147]	151	CONTAINS
[4070]	152
	153
	154	!--------------------------------------------------------------------------------------------------!
	155	! Description:
	156	! ------------
	157	!> Initialize data-output module.
	158	!--------------------------------------------------------------------------------------------------!
[4559]	159	SUBROUTINE binary_init_module( file_suffix_of_output_group, mpi_comm_of_output_group, &
	160	master_output_rank, program_debug_output_unit, debug_output, &
	161	dom_global_id )
[4070]	162
[4147]	163	CHARACTER(LEN=*), INTENT(IN) :: file_suffix_of_output_group !> file-name suffix added to each file;
	164	!> must be unique for each output group
[4107]	165
[4147]	166	INTEGER, INTENT(IN) :: dom_global_id !< global id within a file defined by DOM
[4559]	167	INTEGER, INTENT(IN) :: master_output_rank !< MPI rank executing tasks which must be
	168	!< executed by a single PE
	169	INTEGER, INTENT(IN) :: mpi_comm_of_output_group !< MPI communicator specifying the rank group
	170	!< participating in output
[4147]	171	INTEGER, INTENT(IN) :: program_debug_output_unit !< file unit number for debug output
[4070]	172
[4147]	173	LOGICAL, INTENT(IN) :: debug_output !< if true, debug output is printed
[4070]	174
	175
[4559]	176	file_suffix = file_suffix_of_output_group
[4147]	177	output_group_comm = mpi_comm_of_output_group
[4559]	178	master_rank = master_output_rank
[4107]	179
[4559]	180	debug_output_unit = program_debug_output_unit
[4147]	181	print_debug_output = debug_output
[4070]	182
[4147]	183	global_id_in_file = dom_global_id
[4070]	184
[4147]	185	END SUBROUTINE binary_init_module
[4070]	186
	187	!--------------------------------------------------------------------------------------------------!
	188	! Description:
	189	! ------------
	190	!> Open binary file.
	191	!--------------------------------------------------------------------------------------------------!
[4147]	192	SUBROUTINE binary_open_file( mode, file_name, file_id, return_value )
[4070]	193
[4577]	194	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_open_file' !< name of this routine
	195
[4147]	196	CHARACTER(LEN=charlen) :: bin_filename = '' !< actual name of binary file
	197	CHARACTER(LEN=charlen), INTENT(IN) :: file_name !< name of file
	198	CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode
[4579]	199	CHARACTER(LEN=7) :: my_rank_char !< string containing value of my_rank with leading zeros
[4070]	200
[4579]	201	INTEGER, INTENT(OUT) :: file_id !< file ID
[4147]	202	INTEGER :: my_rank !< MPI rank of local processor
	203	INTEGER :: nranks !< number of MPI ranks participating in output
	204	INTEGER, INTENT(OUT) :: return_value !< return value
[4070]	205
[4559]	206	INTEGER, DIMENSION(:), ALLOCATABLE :: files_highest_variable_id_tmp !< temporary list of given
	207	!< variable IDs in file
[4070]	208
[4147]	209	LOGICAL :: file_exists !< true if file to be opened already exists
[4070]	210
	211
[4147]	212	return_value = 0
[4070]	213
	214	#if defined( __parallel )
[4147]	215	CALL MPI_COMM_SIZE( output_group_comm, nranks, return_value )
	216	IF ( return_value == 0 ) CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
	217	IF ( return_value == 0 ) THEN
	218	WRITE( my_rank_char, '("_",I6.6)' ) my_rank
	219	ELSE
	220	CALL internal_message( 'error', routine_name // ': MPI error' )
	221	ENDIF
[4070]	222	#else
[4147]	223	nranks = 1
	224	my_rank = master_rank
	225	WRITE( my_rank_char, '("_",I6.6)' ) my_rank
[4070]	226	#endif
[4147]	227	!
	228	!-- Check mode (not required, added for compatibility reasons)
	229	IF ( TRIM( mode ) == mode_binary ) CONTINUE
	230	!
	231	!-- Open binary config file for combining script
	232	IF ( return_value == 0 .AND. binary_open_file_first_call ) THEN
[4070]	233
[4147]	234	binary_open_file_first_call = .FALSE.
	235	config_file_unit = binary_file_lowest_unit
[4106]	236
[4147]	237	IF ( my_rank == master_rank ) THEN
	238	!
	239	!-- Remove any pre-existing file
[4559]	240	INQUIRE( FILE=TRIM( config_file_name ) // TRIM( file_suffix ), EXIST = file_exists )
[4070]	241
[4147]	242	IF ( file_exists ) THEN
[4559]	243	CALL internal_message( 'debug', routine_name // ': Remove existing file ' // &
[4147]	244	TRIM( config_file_name ) // TRIM( file_suffix ) )
	245	!> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by
	246	!> PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used
	247	! CALL EXECUTE_COMMAND_LINE( &
	248	! COMMAND='rm ' // TRIM( config_file_name ) // TRIM( file_suffix ), &
	249	! WAIT=.TRUE., EXITSTAT=return_value )
	250	CALL SYSTEM( 'rm ' // TRIM( config_file_name ) // TRIM( file_suffix ) )
	251	ENDIF
[4070]	252
[4579]	253	OPEN( config_file_unit, FILE=TRIM( config_file_name ) // TRIM( file_suffix ), &
[4577]	254	FORM='UNFORMATTED', STATUS='NEW', IOSTAT=return_value )
[4070]	255
[4147]	256	IF ( return_value == 0 ) THEN
[4070]	257
[4147]	258	config_file_open = .TRUE.
	259	!
	260	!-- Write some general information to config file
	261	WRITE( config_file_unit ) nranks
	262	WRITE( config_file_unit ) master_rank
	263	WRITE( config_file_unit ) LEN( file_prefix )
	264	WRITE( config_file_unit ) file_prefix
	265	WRITE( config_file_unit ) charlen
	266	WRITE( config_file_unit ) global_id_in_file
[4070]	267
[4147]	268	ELSE
[4070]	269
[4147]	270	return_value = 1
	271	CALL internal_message( 'error', routine_name // ': could not create config' )
[4070]	272
[4147]	273	ENDIF
[4070]	274
[4147]	275	ENDIF
[4070]	276
[4147]	277	next_available_unit = binary_file_lowest_unit + 1
[4070]	278
[4147]	279	ENDIF
	280	!
	281	!-- Initialize output file: open, write header, initialize variable/dimension IDs
	282	IF ( return_value == 0 ) THEN
[4070]	283
[4147]	284	bin_filename = file_prefix // TRIM( file_name ) // TRIM( file_suffix ) // my_rank_char
	285	!
	286	!-- Remove any pre-existing file
[4577]	287	INQUIRE( FILE=TRIM( bin_filename ), EXIST=file_exists )
[4070]	288
[4147]	289	IF ( file_exists ) THEN
[4559]	290	CALL internal_message( 'debug', routine_name // ': remove existing file ' // &
	291	TRIM( bin_filename ) )
[4147]	292	!> @note Fortran2008 feature 'EXECUTE_COMMAND_LINE' not yet supported by
	293	!> PGI 18.10 compiler. Hence, non-standard 'SYSTEM' call must be used
	294	! CALL EXECUTE_COMMAND_LINE( COMMAND='rm ' // TRIM( bin_filename ), &
	295	! WAIT=.TRUE., EXITSTAT=return_value )
	296	CALL SYSTEM( 'rm ' // TRIM( bin_filename ) )
	297	ENDIF
	298	!
	299	!-- Open binary file
	300	CALL internal_message( 'debug', routine_name // ': open file ' // TRIM( bin_filename ) )
[4577]	301	OPEN ( next_available_unit, FILE=TRIM( bin_filename ), FORM='UNFORMATTED', STATUS='NEW', &
	302	IOSTAT=return_value )
[4070]	303
[4147]	304	IF ( return_value == 0 ) THEN
	305	!
	306	!-- Add file_name to config file
	307	IF ( my_rank == master_rank ) THEN
	308	WRITE( config_file_unit ) file_name
	309	ENDIF
	310	!
	311	!-- Save file ID and increase next file unit number
	312	file_id = next_available_unit
	313	next_available_unit = next_available_unit + 1
	314	!
	315	!-- Write some meta data to file
	316	WRITE ( file_id ) charlen
	317	WRITE ( file_id ) file_id
	318	WRITE ( file_id ) file_name
	319	!
	320	!-- Extend file-variable/dimension-ID list by 1 and set it to 0 for new file.
	321	IF ( ALLOCATED( files_highest_variable_id ) ) THEN
[4559]	322	ALLOCATE( files_highest_variable_id_tmp( SIZE( files_highest_variable_id ) ) )
[4147]	323	files_highest_variable_id_tmp = files_highest_variable_id
	324	DEALLOCATE( files_highest_variable_id )
	325	ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
	326	files_highest_variable_id(:file_id-1) = files_highest_variable_id_tmp
	327	DEALLOCATE( files_highest_variable_id_tmp )
	328	ELSE
	329	ALLOCATE( files_highest_variable_id(binary_file_lowest_unit+1:file_id) )
	330	ENDIF
	331	files_highest_variable_id(file_id) = 0
[4070]	332
[4147]	333	ELSE
	334	return_value = 1
[4559]	335	CALL internal_message( 'error', routine_name // ': could not open file "' // &
	336	TRIM( file_name ) // '"')
[4147]	337	ENDIF
[4070]	338
[4147]	339	ENDIF
[4070]	340
[4147]	341	END SUBROUTINE binary_open_file
[4070]	342
	343	!--------------------------------------------------------------------------------------------------!
	344	! Description:
	345	! ------------
	346	!> Write attribute to file.
	347	!--------------------------------------------------------------------------------------------------!
[4559]	348	SUBROUTINE binary_write_attribute( file_id, variable_id, attribute_name, value_char, value_int8, &
	349	value_int16, value_int32, value_real32, value_real64, &
	350	return_value )
[4070]	351
[4577]	352
	353	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_write_attribute' !< name of this routine
	354
[4579]	355	CHARACTER(LEN=charlen), INTENT(IN) :: attribute_name !< name of attribute
	356	CHARACTER(LEN=charlen) :: attribute_type !< data type of attribute
	357	CHARACTER(LEN=charlen) :: output_string !< output string
	358	CHARACTER(LEN=charlen), INTENT(IN), OPTIONAL :: value_char !< value of attribute
[4070]	359
[4147]	360	INTEGER, INTENT(IN) :: file_id !< file ID
[4579]	361	INTEGER, INTENT(OUT) :: return_value !< return value
[4147]	362	INTEGER, INTENT(IN) :: variable_id !< variable ID
[4559]	363
	364	INTEGER(KIND=1), INTENT(IN), OPTIONAL :: value_int8 !< value of attribute
	365	INTEGER(KIND=2), INTENT(IN), OPTIONAL :: value_int16 !< value of attribute
	366	INTEGER(KIND=4), INTENT(IN), OPTIONAL :: value_int32 !< value of attribute
	367
[4147]	368	REAL(KIND=4), INTENT(IN), OPTIONAL :: value_real32 !< value of attribute
	369	REAL(KIND=8), INTENT(IN), OPTIONAL :: value_real64 !< value of attribute
[4070]	370
	371
[4147]	372	return_value = 0
[4070]	373
[4559]	374	CALL internal_message( 'debug', TRIM( routine_name ) // ': write attribute ' // &
	375	TRIM( attribute_name ) )
[4147]	376	!
	377	!-- Write attribute to file
	378	output_string = 'attribute'
	379	WRITE( file_id ) output_string
[4070]	380
[4147]	381	WRITE( file_id ) variable_id
	382	WRITE( file_id ) attribute_name
[4070]	383
[4147]	384	IF ( PRESENT( value_char ) ) THEN
	385	attribute_type = 'char'
	386	WRITE( file_id ) attribute_type
	387	WRITE( file_id ) value_char
	388	ELSEIF ( PRESENT( value_int8 ) ) THEN
	389	attribute_type = 'int8'
	390	WRITE( file_id ) attribute_type
	391	WRITE( file_id ) value_int8
	392	ELSEIF ( PRESENT( value_int16 ) ) THEN
	393	attribute_type = 'int16'
	394	WRITE( file_id ) attribute_type
	395	WRITE( file_id ) value_int16
	396	ELSEIF ( PRESENT( value_int32 ) ) THEN
	397	attribute_type = 'int32'
	398	WRITE( file_id ) attribute_type
	399	WRITE( file_id ) value_int32
	400	ELSEIF ( PRESENT( value_real32 ) ) THEN
	401	attribute_type = 'real32'
	402	WRITE( file_id ) attribute_type
	403	WRITE( file_id ) value_real32
	404	ELSEIF ( PRESENT( value_real64 ) ) THEN
	405	attribute_type = 'real64'
	406	WRITE( file_id ) attribute_type
	407	WRITE( file_id ) value_real64
	408	ELSE
	409	return_value = 1
[4559]	410	CALL internal_message( 'error', TRIM( routine_name ) // &
[4147]	411	': no value given for attribute "' // TRIM( attribute_name ) // '"' )
	412	ENDIF
[4070]	413
[4147]	414	END SUBROUTINE binary_write_attribute
[4070]	415
	416	!--------------------------------------------------------------------------------------------------!
	417	! Description:
	418	! ------------
[4559]	419	!> Initialize dimension. Write information in file header and save dimension values to be later
	420	!< written to file.
[4070]	421	!--------------------------------------------------------------------------------------------------!
[4559]	422	SUBROUTINE binary_init_dimension( mode, file_id, dimension_id, variable_id, dimension_name, &
	423	dimension_type, dimension_length, return_value )
[4070]	424
[4577]	425	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_dimension' !< name of this routine
	426
[4147]	427	CHARACTER(LEN=charlen), INTENT(IN) :: dimension_name !< name of dimension
	428	CHARACTER(LEN=charlen), INTENT(IN) :: dimension_type !< data type of dimension
	429	CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode
[4579]	430	CHARACTER(LEN=charlen) :: output_string !< output string
[4070]	431
[4579]	432	INTEGER, INTENT(OUT) :: dimension_id !< dimension ID
[4147]	433	INTEGER, INTENT(IN) :: dimension_length !< length of dimension
	434	INTEGER, INTENT(IN) :: file_id !< file ID
	435	INTEGER, INTENT(OUT) :: return_value !< return value
	436	INTEGER, INTENT(OUT) :: variable_id !< variable ID
[4070]	437
	438
[4147]	439	return_value = 0
[4070]	440
[4147]	441	CALL internal_message( 'debug', routine_name // ': init dimension ' // TRIM( dimension_name ) )
	442	!
	443	!-- Check mode (not required, added for compatibility reasons only)
	444	IF ( TRIM( mode ) == mode_binary ) CONTINUE
	445	!
	446	!-- Assign dimension ID
	447	dimension_id = files_highest_variable_id( file_id ) + 1
	448	files_highest_variable_id( file_id ) = dimension_id
	449	!
	450	!-- Define dimension in file
	451	output_string = 'dimension'
	452	WRITE( file_id ) output_string
	453	WRITE( file_id ) dimension_name
	454	WRITE( file_id ) dimension_id
	455	WRITE( file_id ) dimension_type
	456	WRITE( file_id ) dimension_length
	457	!
	458	!-- Define variable associated with dimension
[4579]	459	CALL binary_init_variable( mode, file_id, variable_id, dimension_name, dimension_type, &
	460	(/ dimension_id /), is_global=.TRUE., return_value=return_value )
[4147]	461	IF ( return_value /= 0 ) THEN
[4559]	462	CALL internal_message( 'error', routine_name // &
[4147]	463	': init dimension "' // TRIM( dimension_name ) // '"' )
	464	ENDIF
[4070]	465
[4147]	466	END SUBROUTINE binary_init_dimension
[4106]	467
[4070]	468	!--------------------------------------------------------------------------------------------------!
	469	! Description:
	470	! ------------
	471	!> Initialize variable. Write information of variable into file header.
	472	!--------------------------------------------------------------------------------------------------!
[4559]	473	SUBROUTINE binary_init_variable( mode, file_id, variable_id, variable_name, variable_type, &
[4147]	474	dimension_ids, is_global, return_value )
[4579]	475
[4577]	476	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_init_variable' !< name of this routine
[4070]	477
[4147]	478	CHARACTER(LEN=charlen) :: output_string !< output string
[4559]	479	CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode
[4147]	480	CHARACTER(LEN=charlen), INTENT(IN) :: variable_name !< name of variable
	481	CHARACTER(LEN=charlen), INTENT(IN) :: variable_type !< data type of variable
[4070]	482
[4147]	483	INTEGER, INTENT(IN) :: file_id !< file ID
[4577]	484	INTEGER, INTENT(OUT) :: return_value !< return value
[4147]	485	INTEGER, INTENT(OUT) :: variable_id !< variable ID
[4070]	486
[4147]	487	INTEGER, DIMENSION(:), INTENT(IN) :: dimension_ids !< list of dimension IDs used by variable
[4070]	488
[4147]	489	LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE)
[4070]	490
	491
[4147]	492	return_value = 0
[4070]	493
[4147]	494	CALL internal_message( 'debug', routine_name // ': init variable ' // TRIM( variable_name ) )
	495	!
	496	!-- Check mode (not required, added for compatibility reasons only)
	497	IF ( TRIM( mode ) == mode_binary ) CONTINUE
	498	!
	499	!-- Check if variable is global (not required, added for compatibility reasons only)
	500	IF ( is_global ) CONTINUE
	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
[4559]	535	CALL internal_message( 'debug', routine_name // ': finalize file definition (file_id=' // &
	536	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( &
	549	file_id, variable_id, bounds_start, value_counts, bounds_origin, &
	550	is_global, &
	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
[4106]	561
[4147]	562	CHARACTER(LEN=*), PARAMETER :: routine_name = 'binary_write_variable' !< name of this routine
[4070]	563
[4577]	564	CHARACTER(LEN=charlen) :: output_string !< output string
	565
[4408]	566	CHARACTER(LEN=1), POINTER, INTENT(IN), OPTIONAL :: values_char_0d !< output variable
	567	CHARACTER(LEN=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_char_1d !< output variable
	568	CHARACTER(LEN=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_char_2d !< output variable
	569	CHARACTER(LEN=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_char_3d !< output variable
	570
[4147]	571	INTEGER, INTENT(IN) :: file_id !< file ID
[4559]	572	INTEGER, INTENT(IN) :: variable_id !< variable ID
[4147]	573	INTEGER, INTENT(OUT) :: return_value !< return value
[4070]	574
[4147]	575	INTEGER, DIMENSION(:), INTENT(IN) :: bounds_origin !< starting index of each dimension
	576	INTEGER, DIMENSION(:), INTENT(IN) :: bounds_start !< starting index of variable
	577	INTEGER, DIMENSION(:), INTENT(IN) :: value_counts !< count of values along each dimension to be written
[4070]	578
[4147]	579	INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL :: values_int8_0d !< output variable
	580	INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL :: values_int16_0d !< output variable
	581	INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_int32_0d !< output variable
	582	INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL :: values_intwp_0d !< output variable
	583	INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int8_1d !< output variable
	584	INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int16_1d !< output variable
	585	INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int32_1d !< output variable
	586	INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_intwp_1d !< output variable
	587	INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int8_2d !< output variable
	588	INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int16_2d !< output variable
	589	INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int32_2d !< output variable
	590	INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_intwp_2d !< output variable
	591	INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int8_3d !< output variable
	592	INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int16_3d !< output variable
	593	INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int32_3d !< output variable
	594	INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_intwp_3d !< output variable
[4070]	595
[4147]	596	LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE)
[4070]	597
[4147]	598	REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_real32_0d !< output variable
	599	REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL :: values_real64_0d !< output variable
	600	REAL(wp), POINTER, INTENT(IN), OPTIONAL :: values_realwp_0d !< output variable
	601	REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real32_1d !< output variable
	602	REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real64_1d !< output variable
	603	REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_realwp_1d !< output variable
	604	REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real32_2d !< output variable
	605	REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real64_2d !< output variable
	606	REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_realwp_2d !< output variable
	607	REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real32_3d !< output variable
	608	REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real64_3d !< output variable
	609	REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_realwp_3d !< output variable
[4070]	610
	611
[4147]	612	return_value = 0
[4070]	613
[4147]	614	WRITE( temp_string, '(": write variable ",I6," into file ",I6)' ) variable_id, file_id
	615	CALL internal_message( 'debug', routine_name // TRIM( temp_string ) )
[4070]	616
[4147]	617	IF ( is_global ) CONTINUE ! reqired to prevent compiler warning
[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	!
	697	!-- working-precision integer output
	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	!
	751	!-- working-precision real output
	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 |