Home

Context Navigation

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

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