Home

Context Navigation

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

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