source: palm/trunk/SOURCE/data_output_netcdf4_serial_module.f90 @ 4096

Last change on this file since 4096 was 4070, checked in by gronemeier, 5 years ago

Add new data output modules

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