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

Last change on this file since 4418 was 4408, checked in by gronemeier, 4 years ago

write fill_value attribute in virtual-measurements module; enable character-array output in data-output module

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