Home

Context Navigation

source: palm/trunk/SOURCE/data_output_netcdf4_serial_module.f90 @ 4086

Last change on this file since 4086 was 4070, checked in by gronemeier, 5 years ago
Add new data output modules
Property svn:keywords set to `Id`
File size: 33.1 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |