Home

Context Navigation

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

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