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

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

combine new netcdf4 output modules into a single module; improvements of DOM error messages; check initialization state of file before defining/writing anything; improvements in binary output

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