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

Last change on this file since 4141 was 4141, checked in by gronemeier, 2 years ago

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

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