Home

Context Navigation

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

Last change on this file since 4113 was 4107, checked in by gronemeier, 5 years ago

changes in data-output module (data_output_module.f90, data_output_binary_module.f90, data_output_netcdf4_module.f90, binary_to_netcdf.f90):

add support for different output groups of MPI ranks (required for, e.g., nesting runs)
revise output messages

Property svn:keywords set to Id

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