Home

Context Navigation

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

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