Home

Context Navigation

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

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |