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

Last change on this file since 4558 was 4481, checked in by maronga, 5 years ago

Bugfix for copyright updates in document_changes; copyright update applied to all files

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