Home

Context Navigation

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

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