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

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

corrected indentation according to coding standard

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