Home

Context Navigation

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

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