Home

Context Navigation

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

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