Home

Context Navigation

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

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