Home

Context Navigation

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

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