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

Last change on this file since 4329 was 4232, checked in by knoop, 5 years ago

Bugfix: wrong placement of INCLUDE "mpif.h" fixed.

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