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

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

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

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