Home

Context Navigation

source: palm/trunk/SOURCE/data_output_netcdf4_module.f90 @ 4410

Last change on this file since 4410 was 4408, checked in by gronemeier, 5 years ago
write fill_value attribute in virtual-measurements module; enable character-array output in data-output module
Property svn:keywords set to `Id`
File size: 40.5 KB

Rev	Line
[4106]	1	!> @file data_output_netcdf4_module.f90
[4070]	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	! ------------------
[4232]	22	!
	23	!
[4070]	24	! Former revisions:
	25	! -----------------
	26	! $Id: data_output_netcdf4_module.f90 4408 2020-02-14 10:04:39Z Giersch $
[4408]	27	! Enable character-array output
	28	!
	29	! 4232 2019-09-20 09:34:22Z knoop
[4232]	30	! Bugfix: INCLUDE "mpif.h" must be placed after IMPLICIT NONE statement
	31	!
	32	! 4147 2019-08-07 09:42:31Z gronemeier
[4147]	33	! corrected indentation according to coding standard
	34	!
	35	! 4141 2019-08-05 12:24:51Z gronemeier
[4070]	36	! Initial revision
	37	!
	38	!
	39	! Authors:
	40	! --------
	41	!> @author: Tobias Gronemeier
	42	!
	43	! Description:
	44	! ------------
[4106]	45	!> NetCDF output module to write data to NetCDF files.
	46	!> This is either done in parallel mode via parallel NetCDF4 I/O or in serial mode only by PE0.
[4070]	47	!--------------------------------------------------------------------------------------------------!
[4147]	48	MODULE data_output_netcdf4_module
[4070]	49
[4147]	50	USE kinds
[4070]	51
[4232]	52	#if defined( __parallel ) && !defined( __mpifh )
[4147]	53	USE MPI
[4070]	54	#endif
	55
[4106]	56	#if defined( __netcdf4 )
[4147]	57	USE NETCDF
[4070]	58	#endif
	59
[4147]	60	IMPLICIT NONE
[4070]	61
[4232]	62	#if defined( __parallel ) && defined( __mpifh )
	63	INCLUDE "mpif.h"
	64	#endif
	65
[4147]	66	CHARACTER(LEN=800) :: internal_error_message = '' !< string containing the last error message
	67	CHARACTER(LEN=100) :: file_suffix = '' !< file suffix added to each file name
	68	CHARACTER(LEN=800) :: temp_string !< dummy string
[4070]	69
[4147]	70	CHARACTER(LEN=*), PARAMETER :: mode_parallel = 'parallel' !< string selecting netcdf4 parallel mode
	71	CHARACTER(LEN=*), PARAMETER :: mode_serial = 'serial' !< string selecting netcdf4 serial mode
[4106]	72
[4147]	73	INTEGER :: debug_output_unit !< Fortran Unit Number of the debug-output file
	74	INTEGER :: global_id_in_file = -1 !< value of global ID within a file
	75	INTEGER :: master_rank !< master rank for tasks to be executed by single PE only
	76	INTEGER :: output_group_comm !< MPI communicator addressing all MPI ranks which participate in output
[4070]	77
[4147]	78	LOGICAL :: print_debug_output = .FALSE. !< if true, debug output is printed
[4070]	79
[4147]	80	SAVE
[4070]	81
[4147]	82	PRIVATE
[4070]	83
[4147]	84	INTERFACE netcdf4_init_module
	85	MODULE PROCEDURE netcdf4_init_module
	86	END INTERFACE netcdf4_init_module
[4070]	87
[4147]	88	INTERFACE netcdf4_open_file
	89	MODULE PROCEDURE netcdf4_open_file
	90	END INTERFACE netcdf4_open_file
[4070]	91
[4147]	92	INTERFACE netcdf4_init_dimension
	93	MODULE PROCEDURE netcdf4_init_dimension
	94	END INTERFACE netcdf4_init_dimension
[4070]	95
[4147]	96	INTERFACE netcdf4_init_variable
	97	MODULE PROCEDURE netcdf4_init_variable
	98	END INTERFACE netcdf4_init_variable
[4070]	99
[4147]	100	INTERFACE netcdf4_write_attribute
	101	MODULE PROCEDURE netcdf4_write_attribute
	102	END INTERFACE netcdf4_write_attribute
[4070]	103
[4147]	104	INTERFACE netcdf4_stop_file_header_definition
	105	MODULE PROCEDURE netcdf4_stop_file_header_definition
	106	END INTERFACE netcdf4_stop_file_header_definition
[4070]	107
[4147]	108	INTERFACE netcdf4_write_variable
	109	MODULE PROCEDURE netcdf4_write_variable
	110	END INTERFACE netcdf4_write_variable
[4070]	111
[4147]	112	INTERFACE netcdf4_finalize
	113	MODULE PROCEDURE netcdf4_finalize
	114	END INTERFACE netcdf4_finalize
[4070]	115
[4147]	116	INTERFACE netcdf4_get_error_message
	117	MODULE PROCEDURE netcdf4_get_error_message
	118	END INTERFACE netcdf4_get_error_message
[4070]	119
[4147]	120	PUBLIC &
	121	netcdf4_finalize, &
	122	netcdf4_get_error_message, &
	123	netcdf4_init_dimension, &
	124	netcdf4_stop_file_header_definition, &
	125	netcdf4_init_module, &
	126	netcdf4_init_variable, &
	127	netcdf4_open_file, &
	128	netcdf4_write_attribute, &
	129	netcdf4_write_variable
[4070]	130
	131
[4147]	132	CONTAINS
[4070]	133
	134
	135	!--------------------------------------------------------------------------------------------------!
	136	! Description:
	137	! ------------
	138	!> Initialize data-output module.
	139	!--------------------------------------------------------------------------------------------------!
[4147]	140	SUBROUTINE netcdf4_init_module( file_suffix_of_output_group, mpi_comm_of_output_group, &
	141	master_output_rank, &
	142	program_debug_output_unit, debug_output, dom_global_id )
[4070]	143
[4147]	144	CHARACTER(LEN=*), INTENT(IN) :: file_suffix_of_output_group !> file-name suffix added to each file;
	145	!> must be unique for each output group
[4107]	146
[4147]	147	INTEGER, INTENT(IN) :: dom_global_id !< global id within a file defined by DOM
	148	INTEGER, INTENT(IN) :: master_output_rank !< MPI rank executing tasks which must be executed by a single PE
	149	INTEGER, INTENT(IN) :: mpi_comm_of_output_group !< MPI communicator specifying the rank group participating in output
	150	INTEGER, INTENT(IN) :: program_debug_output_unit !< file unit number for debug output
[4070]	151
[4147]	152	LOGICAL, INTENT(IN) :: debug_output !< if true, debug output is printed
[4070]	153
	154
[4147]	155	file_suffix = file_suffix_of_output_group
	156	output_group_comm = mpi_comm_of_output_group
	157	master_rank = master_output_rank
[4107]	158
[4147]	159	debug_output_unit = program_debug_output_unit
	160	print_debug_output = debug_output
[4070]	161
[4147]	162	global_id_in_file = dom_global_id
[4070]	163
[4147]	164	END SUBROUTINE netcdf4_init_module
[4070]	165
	166	!--------------------------------------------------------------------------------------------------!
	167	! Description:
	168	! ------------
	169	!> Open netcdf file.
	170	!--------------------------------------------------------------------------------------------------!
[4147]	171	SUBROUTINE netcdf4_open_file( mode, file_name, file_id, return_value )
[4070]	172
[4147]	173	CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file
	174	CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode (either parallel or serial)
[4070]	175
[4147]	176	CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_open_file' !< name of this routine
[4070]	177
[4147]	178	INTEGER, INTENT(OUT) :: file_id !< file ID
	179	INTEGER :: my_rank !< MPI rank of processor
	180	INTEGER :: nc_stat !< netcdf return value
	181	INTEGER, INTENT(OUT) :: return_value !< return value
[4070]	182
	183
[4147]	184	return_value = 0
	185	file_id = -1
	186	!
	187	!-- Open new file
	188	CALL internal_message( 'debug', routine_name // ': create file "' // TRIM( file_name ) // '"' )
[4070]	189
[4147]	190	IF ( TRIM( mode ) == mode_serial ) THEN
[4070]	191
[4106]	192	#if defined( __netcdf4 )
[4107]	193	#if defined( __parallel )
[4147]	194	CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
	195	IF ( return_value /= 0 ) THEN
	196	CALL internal_message( 'error', routine_name // ': MPI_COMM_RANK error' )
	197	ENDIF
	198	IF ( my_rank /= master_rank ) THEN
	199	return_value = 1
	200	CALL internal_message( 'error', routine_name // &
	201	': trying to define a NetCDF file in serial mode by an MPI ' // &
	202	'rank other than the master output rank. Serial NetCDF ' // &
	203	'files can only be defined by the master output rank!' )
	204	ENDIF
[4106]	205	#else
[4147]	206	my_rank = master_rank
	207	return_value = 0
[4107]	208	#endif
	209
[4147]	210	IF ( return_value == 0 ) &
	211	nc_stat = NF90_CREATE( TRIM( file_name ) // TRIM( file_suffix ), &
	212	IOR( NF90_NOCLOBBER, NF90_NETCDF4 ), &
	213	file_id )
[4107]	214	#else
[4147]	215	nc_stat = 0
	216	return_value = 1
	217	CALL internal_message( 'error', routine_name // &
	218	': pre-processor directive "__netcdf4" not given. ' // &
	219	'Using NetCDF4 output not possible' )
[4106]	220	#endif
	221
[4147]	222	ELSEIF ( TRIM( mode ) == mode_parallel ) THEN
[4106]	223
	224	#if defined( __parallel ) && defined( __netcdf4 ) && defined( __netcdf4_parallel )
[4147]	225	nc_stat = NF90_CREATE( TRIM( file_name ) // TRIM( file_suffix ), &
	226	IOR( NF90_NOCLOBBER, IOR( NF90_NETCDF4, NF90_MPIIO ) ), &
	227	file_id, COMM = output_group_comm, INFO = MPI_INFO_NULL )
[4106]	228	#else
[4147]	229	nc_stat = 0
	230	return_value = 1
	231	CALL internal_message( 'error', routine_name // &
	232	': pre-processor directives "__parallel" and/or ' // &
	233	'"__netcdf4" and/or "__netcdf4_parallel" not given. ' // &
	234	'Using parallel NetCDF4 output not possible' )
[4106]	235	#endif
	236
[4147]	237	ELSE
	238	nc_stat = 0
	239	return_value = 1
	240	CALL internal_message( 'error', routine_name // ': selected mode "' // &
	241	TRIM( mode ) // '" must be either "' // &
	242	mode_serial // '" or "' // mode_parallel // '"' )
	243	ENDIF
[4106]	244
	245	#if defined( __netcdf4 )
[4147]	246	IF ( nc_stat /= NF90_NOERR .AND. return_value == 0 ) THEN
	247	return_value = 1
	248	CALL internal_message( 'error', routine_name // &
	249	': NetCDF error while opening file "' // &
	250	TRIM( file_name ) // '": ' // NF90_STRERROR( nc_stat ) )
	251	ENDIF
[4070]	252	#endif
	253
[4147]	254	END SUBROUTINE netcdf4_open_file
[4070]	255
	256	!--------------------------------------------------------------------------------------------------!
	257	! Description:
	258	! ------------
	259	!> Write attribute to netcdf file.
	260	!--------------------------------------------------------------------------------------------------!
[4147]	261	SUBROUTINE netcdf4_write_attribute( file_id, variable_id, attribute_name, &
	262	value_char, value_int8, value_int16, value_int32, &
	263	value_real32, value_real64, return_value )
[4070]	264
[4147]	265	CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute
	266	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: value_char !< value of attribute
[4070]	267
[4147]	268	CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_write_attribute' !< name of this routine
[4070]	269
[4147]	270	INTEGER :: nc_stat !< netcdf return value
	271	INTEGER :: target_id !< ID of target which gets attribute (either global or variable_id)
[4070]	272
[4147]	273	INTEGER, INTENT(IN) :: file_id !< file ID
	274	INTEGER, INTENT(OUT) :: return_value !< return value
	275	INTEGER, INTENT(IN) :: variable_id !< variable ID
[4070]	276
[4147]	277	INTEGER(KIND=1), INTENT(IN), OPTIONAL :: value_int8 !< value of attribute
	278	INTEGER(KIND=2), INTENT(IN), OPTIONAL :: value_int16 !< value of attribute
	279	INTEGER(KIND=4), INTENT(IN), OPTIONAL :: value_int32 !< value of attribute
[4070]	280
[4147]	281	REAL(KIND=4), INTENT(IN), OPTIONAL :: value_real32 !< value of attribute
	282	REAL(KIND=8), INTENT(IN), OPTIONAL :: value_real64 !< value of attribute
[4070]	283
	284
[4106]	285	#if defined( __netcdf4 )
[4147]	286	return_value = 0
[4070]	287
[4147]	288	IF ( variable_id == global_id_in_file ) THEN
	289	target_id = NF90_GLOBAL
	290	ELSE
	291	target_id = variable_id
	292	ENDIF
[4070]	293
[4147]	294	CALL internal_message( 'debug', routine_name // &
	295	': write attribute "' // TRIM( attribute_name ) // '"' )
[4070]	296
[4147]	297	IF ( PRESENT( value_char ) ) THEN
	298	nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), TRIM( value_char ) )
	299	ELSEIF ( PRESENT( value_int8 ) ) THEN
	300	nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int8 )
	301	ELSEIF ( PRESENT( value_int16 ) ) THEN
	302	nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int16 )
	303	ELSEIF ( PRESENT( value_int32 ) ) THEN
	304	nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int32 )
	305	ELSEIF ( PRESENT( value_real32 ) ) THEN
	306	nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_real32 )
	307	ELSEIF ( PRESENT( value_real64 ) ) THEN
	308	nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_real64 )
	309	ELSE
	310	return_value = 1
	311	CALL internal_message( 'error', routine_name // &
	312	': no value given for attribute "' // TRIM( attribute_name ) // '"' )
	313	ENDIF
[4070]	314
[4147]	315	IF ( return_value == 0 ) THEN
	316	IF ( nc_stat /= NF90_NOERR ) THEN
	317	return_value = 1
	318	CALL internal_message( 'error', routine_name // &
	319	': NetCDF error while writing attribute "' // &
	320	TRIM( attribute_name ) // '": ' // NF90_STRERROR( nc_stat ) )
	321	ENDIF
	322	ENDIF
[4070]	323	#else
[4147]	324	return_value = 1
[4070]	325	#endif
	326
[4147]	327	END SUBROUTINE netcdf4_write_attribute
[4070]	328
	329	!--------------------------------------------------------------------------------------------------!
	330	! Description:
	331	! ------------
	332	!> Initialize dimension.
	333	!--------------------------------------------------------------------------------------------------!
[4147]	334	SUBROUTINE netcdf4_init_dimension( mode, file_id, dimension_id, variable_id, &
	335	dimension_name, dimension_type, dimension_length, return_value )
[4070]	336
[4147]	337	CHARACTER(LEN=*), INTENT(IN) :: dimension_name !< name of dimension
	338	CHARACTER(LEN=*), INTENT(IN) :: dimension_type !< data type of dimension
	339	CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode (either parallel or serial)
[4070]	340
[4147]	341	CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_init_dimension' !< name of this routine
[4070]	342
[4147]	343	INTEGER, INTENT(OUT) :: dimension_id !< dimension ID
	344	INTEGER, INTENT(IN) :: dimension_length !< length of dimension
	345	INTEGER, INTENT(IN) :: file_id !< file ID
	346	INTEGER :: nc_dimension_length !< length of dimension
	347	INTEGER :: nc_stat !< netcdf return value
	348	INTEGER, INTENT(OUT) :: return_value !< return value
	349	INTEGER, INTENT(OUT) :: variable_id !< variable ID
[4070]	350
	351
[4106]	352	#if defined( __netcdf4 )
[4147]	353	return_value = 0
	354	variable_id = -1
[4070]	355
[4147]	356	CALL internal_message( 'debug', routine_name // &
	357	': init dimension "' // TRIM( dimension_name ) // '"' )
	358	!
	359	!-- Check if dimension is unlimited
	360	IF ( dimension_length < 0 ) THEN
	361	nc_dimension_length = NF90_UNLIMITED
	362	ELSE
	363	nc_dimension_length = dimension_length
	364	ENDIF
	365	!
	366	!-- Define dimension in file
	367	nc_stat = NF90_DEF_DIM( file_id, dimension_name, nc_dimension_length, dimension_id )
[4070]	368
[4147]	369	IF ( nc_stat == NF90_NOERR ) THEN
	370	!
	371	!-- Define variable holding dimension values in file
	372	CALL netcdf4_init_variable( mode, file_id, variable_id, dimension_name, dimension_type, &
	373	(/ dimension_id /), is_global=.TRUE., return_value=return_value )
[4070]	374
[4147]	375	ELSE
	376	return_value = 1
	377	CALL internal_message( 'error', routine_name // &
	378	': NetCDF error while initializing dimension "' // &
	379	TRIM( dimension_name ) // '": ' // NF90_STRERROR( nc_stat ) )
	380	ENDIF
[4070]	381	#else
[4147]	382	return_value = 1
	383	variable_id = -1
	384	dimension_id = -1
[4070]	385	#endif
	386
[4147]	387	END SUBROUTINE netcdf4_init_dimension
[4070]	388
	389	!--------------------------------------------------------------------------------------------------!
	390	! Description:
	391	! ------------
	392	!> Initialize variable.
	393	!--------------------------------------------------------------------------------------------------!
[4147]	394	SUBROUTINE netcdf4_init_variable( mode, file_id, variable_id, variable_name, variable_type, &
	395	dimension_ids, is_global, return_value )
[4070]	396
[4147]	397	CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode (either parallel or serial)
	398	CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable
	399	CHARACTER(LEN=*), INTENT(IN) :: variable_type !< data type of variable
[4070]	400
[4147]	401	CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_init_variable' !< name of this routine
[4070]	402
[4147]	403	INTEGER, INTENT(IN) :: file_id !< file ID
	404	INTEGER :: nc_stat !< netcdf return value
	405	INTEGER :: nc_variable_type !< netcdf data type
	406	INTEGER, INTENT(OUT) :: return_value !< return value
	407	INTEGER, INTENT(OUT) :: variable_id !< variable ID
[4070]	408
[4147]	409	INTEGER, DIMENSION(:), INTENT(IN) :: dimension_ids !< list of dimension IDs used by variable
[4070]	410
[4147]	411	LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE)
[4070]	412
	413
[4106]	414	#if defined( __netcdf4 )
[4147]	415	return_value = 0
[4070]	416
[4147]	417	WRITE( temp_string, * ) is_global
	418	CALL internal_message( 'debug', routine_name // &
	419	': init variable "' // TRIM( variable_name ) // &
	420	'" ( is_global = ' // TRIM( temp_string ) // ')' )
[4070]	421
[4147]	422	nc_variable_type = get_netcdf_data_type( variable_type )
[4070]	423
[4147]	424	IF ( nc_variable_type /= -1 ) THEN
	425	!
	426	!-- Define variable in file
	427	nc_stat = NF90_DEF_VAR( file_id, variable_name, nc_variable_type, dimension_ids, variable_id )
[4070]	428
[4106]	429	#if defined( __netcdf4_parallel )
[4147]	430	!
	431	!-- Define how variable can be accessed by PEs in parallel netcdf file
	432	IF ( nc_stat == NF90_NOERR .AND. TRIM( mode ) == mode_parallel ) THEN
	433	IF ( is_global ) THEN
	434	nc_stat = NF90_VAR_PAR_ACCESS( file_id, variable_id, NF90_INDEPENDENT )
	435	ELSE
	436	nc_stat = NF90_VAR_PAR_ACCESS( file_id, variable_id, NF90_COLLECTIVE )
	437	ENDIF
	438	ENDIF
[4106]	439	#endif
[4070]	440
[4147]	441	IF ( nc_stat /= NF90_NOERR ) THEN
	442	return_value = 1
	443	CALL internal_message( 'error', routine_name // &
	444	': NetCDF error while initializing variable "' // &
	445	TRIM( variable_name ) // '": ' // NF90_STRERROR( nc_stat ) )
	446	ENDIF
[4070]	447
[4147]	448	ELSE
	449	return_value = 1
	450	ENDIF
[4070]	451
	452	#else
[4147]	453	return_value = 1
	454	variable_id = -1
[4070]	455	#endif
	456
[4147]	457	END SUBROUTINE netcdf4_init_variable
[4070]	458
	459	!--------------------------------------------------------------------------------------------------!
	460	! Description:
	461	! ------------
	462	!> Leave file definition state.
	463	!--------------------------------------------------------------------------------------------------!
[4147]	464	SUBROUTINE netcdf4_stop_file_header_definition( file_id, return_value )
[4070]	465
[4147]	466	CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_stop_file_header_definition' !< name of this routine
[4070]	467
[4147]	468	INTEGER, INTENT(IN) :: file_id !< file ID
	469	INTEGER :: nc_stat !< netcdf return value
	470	INTEGER :: old_fill_mode !< previous netcdf fill mode
	471	INTEGER, INTENT(OUT) :: return_value !< return value
[4070]	472
	473
[4106]	474	#if defined( __netcdf4 )
[4147]	475	return_value = 0
[4070]	476
[4147]	477	WRITE( temp_string, * ) file_id
	478	CALL internal_message( 'debug', routine_name // &
	479	': finalize file definition (file_id=' // TRIM( temp_string ) // ')' )
	480	!
	481	!-- Set general no fill, otherwise the performance drops significantly
	482	nc_stat = NF90_SET_FILL( file_id, NF90_NOFILL, old_fill_mode )
[4070]	483
[4147]	484	IF ( nc_stat == NF90_NOERR ) THEN
	485	nc_stat = NF90_ENDDEF( file_id )
	486	ENDIF
[4070]	487
[4147]	488	IF ( nc_stat /= NF90_NOERR ) THEN
	489	return_value = 1
	490	CALL internal_message( 'error', routine_name // &
	491	': NetCDF error: ' // NF90_STRERROR( nc_stat ) )
	492	ENDIF
[4070]	493	#else
[4147]	494	return_value = 1
[4070]	495	#endif
	496
[4147]	497	END SUBROUTINE netcdf4_stop_file_header_definition
[4070]	498
	499	!--------------------------------------------------------------------------------------------------!
	500	! Description:
	501	! ------------
	502	!> Write variable of different kind into netcdf file.
	503	!--------------------------------------------------------------------------------------------------!
[4147]	504	SUBROUTINE netcdf4_write_variable( &
	505	file_id, variable_id, bounds_start, value_counts, bounds_origin, &
	506	is_global, &
[4408]	507	values_char_0d, values_char_1d, values_char_2d, values_char_3d, &
[4147]	508	values_int8_0d, values_int8_1d, values_int8_2d, values_int8_3d, &
	509	values_int16_0d, values_int16_1d, values_int16_2d, values_int16_3d, &
	510	values_int32_0d, values_int32_1d, values_int32_2d, values_int32_3d, &
	511	values_intwp_0d, values_intwp_1d, values_intwp_2d, values_intwp_3d, &
	512	values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &
	513	values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &
	514	values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d, &
	515	return_value )
[4070]	516
[4147]	517	CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_write_variable' !< name of this routine
[4070]	518
[4408]	519	CHARACTER(LEN=1), POINTER, INTENT(IN), OPTIONAL :: values_char_0d !< output variable
	520	CHARACTER(LEN=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_char_1d !< output variable
	521	CHARACTER(LEN=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_char_2d !< output variable
	522	CHARACTER(LEN=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_char_3d !< output variable
	523
[4147]	524	INTEGER :: d !< loop index
	525	INTEGER, INTENT(IN) :: file_id !< file ID
	526	INTEGER :: my_rank !< MPI rank of processor
	527	INTEGER :: nc_stat !< netcdf return value
	528	INTEGER :: ndims !< number of dimensions of variable in file
	529	INTEGER, INTENT(OUT) :: return_value !< return value
	530	INTEGER, INTENT(IN) :: variable_id !< variable ID
[4070]	531
[4147]	532	INTEGER, DIMENSION(:), INTENT(IN) :: bounds_origin !< starting index of each dimension
	533	INTEGER, DIMENSION(:), INTENT(IN) :: bounds_start !< starting index of variable
	534	INTEGER, DIMENSION(:), ALLOCATABLE :: dimension_ids !< IDs of dimensions of variable in file
	535	INTEGER, DIMENSION(:), ALLOCATABLE :: dimension_lengths !< length of dimensions of variable in file
	536	INTEGER, DIMENSION(:), INTENT(IN) :: value_counts !< count of values along each dimension to be written
[4070]	537
[4147]	538	INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL :: values_int8_0d !< output variable
	539	INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL :: values_int16_0d !< output variable
	540	INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_int32_0d !< output variable
	541	INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL :: values_intwp_0d !< output variable
	542	INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int8_1d !< output variable
	543	INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int16_1d !< output variable
	544	INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int32_1d !< output variable
	545	INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_intwp_1d !< output variable
	546	INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int8_2d !< output variable
	547	INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int16_2d !< output variable
	548	INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int32_2d !< output variable
	549	INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_intwp_2d !< output variable
	550	INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int8_3d !< output variable
	551	INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int16_3d !< output variable
	552	INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int32_3d !< output variable
	553	INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_intwp_3d !< output variable
[4070]	554
[4147]	555	LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE)
[4070]	556
[4147]	557	REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_real32_0d !< output variable
	558	REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL :: values_real64_0d !< output variable
	559	REAL(wp), POINTER, INTENT(IN), OPTIONAL :: values_realwp_0d !< output variable
	560	REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real32_1d !< output variable
	561	REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real64_1d !< output variable
	562	REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_realwp_1d !< output variable
	563	REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real32_2d !< output variable
	564	REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real64_2d !< output variable
	565	REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_realwp_2d !< output variable
	566	REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real32_3d !< output variable
	567	REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real64_3d !< output variable
	568	REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_realwp_3d !< output variable
[4070]	569
	570
[4106]	571	#if defined( __netcdf4 )
[4070]	572
	573	#if defined( __parallel )
[4147]	574	CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )
	575	IF ( return_value /= 0 ) THEN
	576	CALL internal_message( 'error', routine_name // ': MPI_COMM_RANK error' )
	577	ENDIF
[4106]	578	#else
[4147]	579	my_rank = master_rank
	580	return_value = 0
[4070]	581	#endif
	582
[4147]	583	IF ( return_value == 0 .AND. ( .NOT. is_global .OR. my_rank == master_rank ) ) THEN
[4070]	584
[4147]	585	WRITE( temp_string, * ) variable_id
	586	CALL internal_message( 'debug', routine_name // ': write variable ' // TRIM( temp_string ) )
[4070]	587
[4147]	588	ndims = SIZE( bounds_start )
[4408]	589
[4147]	590	!
[4408]	591	!-- character output
	592	IF ( PRESENT( values_char_0d ) ) THEN
	593	nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_char_0d /), &
	594	start = bounds_start - bounds_origin + 1, &
	595	count = value_counts )
	596	ELSEIF ( PRESENT( values_char_1d ) ) THEN
	597	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_char_1d, &
	598	start = bounds_start - bounds_origin + 1, &
	599	count = value_counts )
	600	ELSEIF ( PRESENT( values_char_2d ) ) THEN
	601	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_char_2d, &
	602	start = bounds_start - bounds_origin + 1, &
	603	count = value_counts )
	604	ELSEIF ( PRESENT( values_char_3d ) ) THEN
	605	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_char_3d, &
	606	start = bounds_start - bounds_origin + 1, &
	607	count = value_counts )
	608	!
[4147]	609	!-- 8bit integer output
[4408]	610	ELSEIF ( PRESENT( values_int8_0d ) ) THEN
[4147]	611	nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int8_0d /), &
	612	start = bounds_start - bounds_origin + 1, &
	613	count = value_counts )
	614	ELSEIF ( PRESENT( values_int8_1d ) ) THEN
	615	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_1d, &
	616	start = bounds_start - bounds_origin + 1, &
	617	count = value_counts )
	618	ELSEIF ( PRESENT( values_int8_2d ) ) THEN
	619	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_2d, &
	620	start = bounds_start - bounds_origin + 1, &
	621	count = value_counts )
	622	ELSEIF ( PRESENT( values_int8_3d ) ) THEN
	623	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_3d, &
	624	start = bounds_start - bounds_origin + 1, &
	625	count = value_counts )
	626	!
	627	!-- 16bit integer output
	628	ELSEIF ( PRESENT( values_int16_0d ) ) THEN
	629	nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int16_0d /), &
	630	start = bounds_start - bounds_origin + 1, &
	631	count = value_counts )
	632	ELSEIF ( PRESENT( values_int16_1d ) ) THEN
	633	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_1d, &
	634	start = bounds_start - bounds_origin + 1, &
	635	count = value_counts )
	636	ELSEIF ( PRESENT( values_int16_2d ) ) THEN
	637	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_2d, &
	638	start = bounds_start - bounds_origin + 1, &
	639	count = value_counts )
	640	ELSEIF ( PRESENT( values_int16_3d ) ) THEN
	641	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_3d, &
	642	start = bounds_start - bounds_origin + 1, &
	643	count = value_counts )
	644	!
	645	!-- 32bit integer output
	646	ELSEIF ( PRESENT( values_int32_0d ) ) THEN
	647	nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int32_0d /), &
	648	start = bounds_start - bounds_origin + 1, &
	649	count = value_counts )
	650	ELSEIF ( PRESENT( values_int32_1d ) ) THEN
	651	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_1d, &
	652	start = bounds_start - bounds_origin + 1, &
	653	count = value_counts )
	654	ELSEIF ( PRESENT( values_int32_2d ) ) THEN
	655	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_2d, &
	656	start = bounds_start - bounds_origin + 1, &
	657	count = value_counts )
	658	ELSEIF ( PRESENT( values_int32_3d ) ) THEN
	659	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_3d, &
	660	start = bounds_start - bounds_origin + 1, &
	661	count = value_counts )
	662	!
	663	!-- working-precision integer output
	664	ELSEIF ( PRESENT( values_intwp_0d ) ) THEN
	665	nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_intwp_0d /), &
	666	start = bounds_start - bounds_origin + 1, &
	667	count = value_counts )
	668	ELSEIF ( PRESENT( values_intwp_1d ) ) THEN
	669	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_1d, &
	670	start = bounds_start - bounds_origin + 1, &
	671	count = value_counts )
	672	ELSEIF ( PRESENT( values_intwp_2d ) ) THEN
	673	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_2d, &
	674	start = bounds_start - bounds_origin + 1, &
	675	count = value_counts )
	676	ELSEIF ( PRESENT( values_intwp_3d ) ) THEN
	677	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_3d, &
	678	start = bounds_start - bounds_origin + 1, &
	679	count = value_counts )
	680	!
	681	!-- 32bit real output
	682	ELSEIF ( PRESENT( values_real32_0d ) ) THEN
	683	nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_real32_0d /), &
	684	start = bounds_start - bounds_origin + 1, &
	685	count = value_counts )
	686	ELSEIF ( PRESENT( values_real32_1d ) ) THEN
	687	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_1d, &
	688	start = bounds_start - bounds_origin + 1, &
	689	count = value_counts )
	690	ELSEIF ( PRESENT( values_real32_2d ) ) THEN
	691	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_2d, &
	692	start = bounds_start - bounds_origin + 1, &
	693	count = value_counts )
	694	ELSEIF ( PRESENT( values_real32_3d ) ) THEN
	695	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_3d, &
	696	start = bounds_start - bounds_origin + 1, &
	697	count = value_counts )
	698	!
	699	!-- 64bit real output
	700	ELSEIF ( PRESENT( values_real64_0d ) ) THEN
	701	nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_real64_0d /), &
	702	start = bounds_start - bounds_origin + 1, &
	703	count = value_counts )
	704	ELSEIF ( PRESENT( values_real64_1d ) ) THEN
	705	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_1d, &
	706	start = bounds_start - bounds_origin + 1, &
	707	count = value_counts )
	708	ELSEIF ( PRESENT( values_real64_2d ) ) THEN
	709	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_2d, &
	710	start = bounds_start - bounds_origin + 1, &
	711	count = value_counts )
	712	ELSEIF ( PRESENT( values_real64_3d ) ) THEN
	713	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_3d, &
	714	start = bounds_start - bounds_origin + 1, &
	715	count = value_counts )
	716	!
	717	!-- working-precision real output
	718	ELSEIF ( PRESENT( values_realwp_0d ) ) THEN
	719	nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_realwp_0d /), &
	720	start = bounds_start - bounds_origin + 1, &
	721	count = value_counts )
	722	ELSEIF ( PRESENT( values_realwp_1d ) ) THEN
	723	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_1d, &
	724	start = bounds_start - bounds_origin + 1, &
	725	count = value_counts )
	726	ELSEIF ( PRESENT( values_realwp_2d ) ) THEN
	727	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_2d, &
	728	start = bounds_start - bounds_origin + 1, &
	729	count = value_counts )
	730	ELSEIF ( PRESENT( values_realwp_3d ) ) THEN
	731	nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_3d, &
	732	start = bounds_start - bounds_origin + 1, &
	733	count = value_counts )
	734	ELSE
	735	return_value = 1
	736	nc_stat = NF90_NOERR
	737	WRITE( temp_string, '(": variable_id=",I6,", file_id=",I6)' ) variable_id, file_id
	738	CALL internal_message( 'error', routine_name // &
	739	': no output values given ' // TRIM( temp_string ) )
	740	ENDIF
	741	!
	742	!-- Check for errors
	743	IF ( nc_stat /= NF90_NOERR ) THEN
	744	return_value = 1
[4070]	745
[4147]	746	IF ( nc_stat == NF90_EEDGE .OR. nc_stat == NF90_EINVALCOORDS ) THEN
	747	!
	748	!-- If given bounds exceed dimension bounds, get information of bounds in file
	749	WRITE( temp_string, * ) NF90_STRERROR( nc_stat )
[4070]	750
[4147]	751	ALLOCATE( dimension_ids(ndims) )
	752	ALLOCATE( dimension_lengths(ndims) )
[4106]	753
[4147]	754	nc_stat = NF90_INQUIRE_VARIABLE( file_id, variable_id, dimids=dimension_ids )
[4106]	755
[4147]	756	d = 1
	757	DO WHILE ( d <= ndims .AND. nc_stat == NF90_NOERR )
	758	nc_stat = NF90_INQUIRE_DIMENSION( file_id, dimension_ids(d), &
	759	LEN=dimension_lengths(d) )
	760	d = d + 1
	761	ENDDO
[4106]	762
[4147]	763	IF ( nc_stat == NF90_NOERR ) THEN
	764	WRITE( temp_string, * ) TRIM( temp_string ) // '; given variable bounds: ' // &
	765	'start=', bounds_start, ', count=', value_counts, ', origin=', bounds_origin
	766	CALL internal_message( 'error', routine_name // &
	767	': error while writing: ' // TRIM( temp_string ) )
	768	ELSE
	769	!
	770	!-- Error occured during NF90_INQUIRE_VARIABLE or NF90_INQUIRE_DIMENSION
	771	CALL internal_message( 'error', routine_name // &
	772	': error while accessing file: ' // &
	773	NF90_STRERROR( nc_stat ) )
	774	ENDIF
[4106]	775
[4147]	776	ELSE
	777	!
	778	!-- Other NetCDF error
	779	CALL internal_message( 'error', routine_name // &
	780	': error while writing: ' // NF90_STRERROR( nc_stat ) )
	781	ENDIF
	782	ENDIF
[4106]	783
[4147]	784	ENDIF
[4070]	785	#else
[4147]	786	return_value = 1
[4070]	787	#endif
	788
[4147]	789	END SUBROUTINE netcdf4_write_variable
[4070]	790
	791	!--------------------------------------------------------------------------------------------------!
	792	! Description:
	793	! ------------
	794	!> Close netcdf file.
	795	!--------------------------------------------------------------------------------------------------!
[4147]	796	SUBROUTINE netcdf4_finalize( file_id, return_value )
[4070]	797
[4147]	798	CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_finalize' !< name of routine
[4070]	799
[4147]	800	INTEGER, INTENT(IN) :: file_id !< file ID
	801	INTEGER :: nc_stat !< netcdf return value
	802	INTEGER, INTENT(OUT) :: return_value !< return value
[4070]	803
	804
[4106]	805	#if defined( __netcdf4 )
[4147]	806	WRITE( temp_string, * ) file_id
	807	CALL internal_message( 'debug', routine_name // &
	808	': close file (file_id=' // TRIM( temp_string ) // ')' )
[4070]	809
[4147]	810	nc_stat = NF90_CLOSE( file_id )
	811	IF ( nc_stat == NF90_NOERR ) THEN
	812	return_value = 0
	813	ELSE
	814	return_value = 1
	815	CALL internal_message( 'error', routine_name // &
	816	': NetCDF error: ' // NF90_STRERROR( nc_stat ) )
	817	ENDIF
[4070]	818	#else
[4147]	819	return_value = 1
[4070]	820	#endif
	821
[4147]	822	END SUBROUTINE netcdf4_finalize
[4070]	823
	824	!--------------------------------------------------------------------------------------------------!
	825	! Description:
	826	! ------------
	827	!> Convert data_type string into netcdf data type value.
	828	!--------------------------------------------------------------------------------------------------!
[4147]	829	FUNCTION get_netcdf_data_type( data_type ) RESULT( return_value )
[4070]	830
[4147]	831	CHARACTER(LEN=*), INTENT(IN) :: data_type !< requested data type
[4070]	832
[4147]	833	CHARACTER(LEN=*), PARAMETER :: routine_name = 'get_netcdf_data_type' !< name of this routine
[4070]	834
[4147]	835	INTEGER :: return_value !< netcdf data type
[4070]	836
	837
[4147]	838	SELECT CASE ( TRIM( data_type ) )
[4070]	839
[4106]	840	#if defined( __netcdf4 )
[4147]	841	CASE ( 'char' )
	842	return_value = NF90_CHAR
[4070]	843
[4147]	844	CASE ( 'int8' )
	845	return_value = NF90_BYTE
[4070]	846
[4147]	847	CASE ( 'int16' )
	848	return_value = NF90_SHORT
[4070]	849
[4147]	850	CASE ( 'int32' )
	851	return_value = NF90_INT
[4070]	852
[4147]	853	CASE ( 'real32' )
	854	return_value = NF90_FLOAT
[4070]	855
[4147]	856	CASE ( 'real64' )
	857	return_value = NF90_DOUBLE
[4070]	858	#endif
	859
[4147]	860	CASE DEFAULT
	861	CALL internal_message( 'error', routine_name // &
	862	': data type unknown (' // TRIM( data_type ) // ')' )
	863	return_value = -1
[4070]	864
[4147]	865	END SELECT
[4070]	866
[4147]	867	END FUNCTION get_netcdf_data_type
[4070]	868
	869	!--------------------------------------------------------------------------------------------------!
	870	! Description:
	871	! ------------
	872	!> Message routine writing debug information into the debug file
	873	!> or creating the error message string.
	874	!--------------------------------------------------------------------------------------------------!
[4147]	875	SUBROUTINE internal_message( level, string )
[4070]	876
[4147]	877	CHARACTER(LEN=*), INTENT(IN) :: level !< message importance level
	878	CHARACTER(LEN=*), INTENT(IN) :: string !< message string
[4070]	879
	880
[4147]	881	IF ( TRIM( level ) == 'error' ) THEN
[4070]	882
[4147]	883	WRITE( internal_error_message, '(A,A)' ) ': ', string
[4070]	884
[4147]	885	ELSEIF ( TRIM( level ) == 'debug' .AND. print_debug_output ) THEN
[4070]	886
[4147]	887	WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string
	888	FLUSH( debug_output_unit )
[4070]	889
[4147]	890	ENDIF
[4070]	891
[4147]	892	END SUBROUTINE internal_message
[4070]	893
	894	!--------------------------------------------------------------------------------------------------!
	895	! Description:
	896	! ------------
	897	!> Return the last created error message.
	898	!--------------------------------------------------------------------------------------------------!
[4147]	899	FUNCTION netcdf4_get_error_message() RESULT( error_message )
[4070]	900
[4147]	901	CHARACTER(LEN=800) :: error_message !< return error message to main program
[4070]	902
	903
[4147]	904	error_message = TRIM( internal_error_message )
[4070]	905
[4147]	906	internal_error_message = ''
[4070]	907
[4147]	908	END FUNCTION netcdf4_get_error_message
[4070]	909
[4141]	910
[4147]	911	END MODULE data_output_netcdf4_module

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |