Changeset 4147 for palm/trunk/SOURCE/data_output_netcdf4_module.f90
- Timestamp:
- Aug 7, 2019 9:42:31 AM (5 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/data_output_netcdf4_module.f90 (modified) (14 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/data_output_netcdf4_module.f90
r4141 r4147 25 25 ! ----------------- 26 26 ! $Id$ 27 ! corrected indentation according to coding standard 28 ! 29 ! 4141 2019-08-05 12:24:51Z gronemeier 27 30 ! Initial revision 28 31 ! … … 37 40 !> This is either done in parallel mode via parallel NetCDF4 I/O or in serial mode only by PE0. 38 41 !--------------------------------------------------------------------------------------------------! 39 MODULE data_output_netcdf4_module40 41 USE kinds42 MODULE data_output_netcdf4_module 43 44 USE kinds 42 45 43 46 #if defined( __parallel ) 44 47 #if defined( __mpifh ) 45 INCLUDE "mpif.h"46 #else 47 USE MPI48 #endif 49 #endif 50 51 #if defined( __netcdf4 ) 52 USE NETCDF53 #endif 54 55 IMPLICIT NONE56 57 CHARACTER(LEN=800) :: internal_error_message = '' !< string containing the last error message58 CHARACTER(LEN=100) :: file_suffix = '' !< file suffix added to each file name59 CHARACTER(LEN=800) :: temp_string !< dummy string60 61 CHARACTER(LEN=*), PARAMETER :: mode_parallel = 'parallel' !< string selecting netcdf4 parallel mode62 CHARACTER(LEN=*), PARAMETER :: mode_serial = 'serial' !< string selecting netcdf4 serial mode63 64 INTEGER :: debug_output_unit !< Fortran Unit Number of the debug-output file65 INTEGER :: global_id_in_file = -1 !< value of global ID within a file66 INTEGER :: master_rank !< master rank for tasks to be executed by single PE only67 INTEGER :: output_group_comm !< MPI communicator addressing all MPI ranks which participate in output68 69 LOGICAL :: print_debug_output = .FALSE. !< if true, debug output is printed70 71 SAVE72 73 PRIVATE74 75 INTERFACE netcdf4_init_module76 MODULE PROCEDURE netcdf4_init_module77 END INTERFACE netcdf4_init_module78 79 INTERFACE netcdf4_open_file80 MODULE PROCEDURE netcdf4_open_file81 END INTERFACE netcdf4_open_file82 83 INTERFACE netcdf4_init_dimension84 MODULE PROCEDURE netcdf4_init_dimension85 END INTERFACE netcdf4_init_dimension86 87 INTERFACE netcdf4_init_variable88 MODULE PROCEDURE netcdf4_init_variable89 END INTERFACE netcdf4_init_variable90 91 INTERFACE netcdf4_write_attribute92 MODULE PROCEDURE netcdf4_write_attribute93 END INTERFACE netcdf4_write_attribute94 95 INTERFACE netcdf4_stop_file_header_definition96 MODULE PROCEDURE netcdf4_stop_file_header_definition97 END INTERFACE netcdf4_stop_file_header_definition98 99 INTERFACE netcdf4_write_variable100 MODULE PROCEDURE netcdf4_write_variable101 END INTERFACE netcdf4_write_variable102 103 INTERFACE netcdf4_finalize104 MODULE PROCEDURE netcdf4_finalize105 END INTERFACE netcdf4_finalize106 107 INTERFACE netcdf4_get_error_message108 MODULE PROCEDURE netcdf4_get_error_message109 END INTERFACE netcdf4_get_error_message110 111 PUBLIC &112 netcdf4_finalize, &113 netcdf4_get_error_message, &114 netcdf4_init_dimension, &115 netcdf4_stop_file_header_definition, &116 netcdf4_init_module, &117 netcdf4_init_variable, &118 netcdf4_open_file, &119 netcdf4_write_attribute, &120 netcdf4_write_variable121 122 123 CONTAINS48 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 124 127 125 128 … … 129 132 !> Initialize data-output module. 130 133 !--------------------------------------------------------------------------------------------------! 131 SUBROUTINE netcdf4_init_module( file_suffix_of_output_group, mpi_comm_of_output_group, &132 master_output_rank, &133 program_debug_output_unit, debug_output, dom_global_id )134 135 CHARACTER(LEN=*), INTENT(IN) :: file_suffix_of_output_group !> file-name suffix added to each file;136 !> must be unique for each output group137 138 INTEGER, INTENT(IN) :: dom_global_id !< global id within a file defined by DOM139 INTEGER, INTENT(IN) :: master_output_rank !< MPI rank executing tasks which must be executed by a single PE140 INTEGER, INTENT(IN) :: mpi_comm_of_output_group !< MPI communicator specifying the rank group participating in output141 INTEGER, INTENT(IN) :: program_debug_output_unit !< file unit number for debug output142 143 LOGICAL, INTENT(IN) :: debug_output !< if true, debug output is printed144 145 146 file_suffix = file_suffix_of_output_group147 output_group_comm = mpi_comm_of_output_group148 master_rank = master_output_rank149 150 debug_output_unit = program_debug_output_unit151 print_debug_output = debug_output152 153 global_id_in_file = dom_global_id154 155 END SUBROUTINE netcdf4_init_module134 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 156 159 157 160 !--------------------------------------------------------------------------------------------------! … … 160 163 !> Open netcdf file. 161 164 !--------------------------------------------------------------------------------------------------! 162 SUBROUTINE netcdf4_open_file( mode, file_name, file_id, return_value )163 164 CHARACTER(LEN=*), INTENT(IN) :: file_name !< name of file165 CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode (either parallel or serial)166 167 CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_open_file' !< name of this routine168 169 INTEGER, INTENT(OUT) :: file_id !< file ID170 INTEGER :: my_rank !< MPI rank of processor171 INTEGER :: nc_stat !< netcdf return value172 INTEGER, INTENT(OUT) :: return_value !< return value173 174 175 return_value = 0176 file_id = -1177 178 179 CALL internal_message( 'debug', routine_name // ': create file "' // TRIM( file_name ) // '"' )180 181 IF ( TRIM( mode ) == mode_serial ) THEN165 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 182 185 183 186 #if defined( __netcdf4 ) 184 187 #if defined( __parallel ) 185 CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value )186 IF ( return_value /= 0 ) THEN187 CALL internal_message( 'error', routine_name // ': MPI_COMM_RANK error' )188 ENDIF189 IF ( my_rank /= master_rank ) THEN190 return_value = 1191 CALL internal_message( 'error', routine_name // &192 ': trying to define a NetCDF file in serial mode by an MPI ' // &193 'rank other than the master output rank. Serial NetCDF ' // &194 'files can only be defined by the master output rank!' )195 ENDIF196 #else 197 my_rank = master_rank198 return_value = 0199 #endif 200 201 IF ( return_value == 0 ) &202 nc_stat = NF90_CREATE( TRIM( file_name ) // TRIM( file_suffix ), &203 IOR( NF90_NOCLOBBER, NF90_NETCDF4 ), &204 file_id )205 #else 206 nc_stat = 0207 return_value = 1208 CALL internal_message( 'error', routine_name // &209 ': pre-processor directive "__netcdf4" not given. ' // &210 'Using NetCDF4 output not possible' )211 #endif 212 213 ELSEIF ( TRIM( mode ) == mode_parallel ) THEN188 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 214 217 215 218 #if defined( __parallel ) && defined( __netcdf4 ) && defined( __netcdf4_parallel ) 216 nc_stat = NF90_CREATE( TRIM( file_name ) // TRIM( file_suffix ), &217 IOR( NF90_NOCLOBBER, IOR( NF90_NETCDF4, NF90_MPIIO ) ), &218 file_id, COMM = output_group_comm, INFO = MPI_INFO_NULL )219 #else 220 nc_stat = 0221 return_value = 1222 CALL internal_message( 'error', routine_name // &223 ': pre-processor directives "__parallel" and/or ' // &224 '"__netcdf4" and/or "__netcdf4_parallel" not given. ' // &225 'Using parallel NetCDF4 output not possible' )226 #endif 227 228 ELSE229 nc_stat = 0230 return_value = 1231 CALL internal_message( 'error', routine_name // ': selected mode "' // &232 TRIM( mode ) // '" must be either "' // &233 mode_serial // '" or "' // mode_parallel // '"' )234 ENDIF235 236 #if defined( __netcdf4 ) 237 IF ( nc_stat /= NF90_NOERR .AND. return_value == 0 ) THEN238 return_value = 1239 CALL internal_message( 'error', routine_name // &240 ': NetCDF error while opening file "' // &241 TRIM( file_name ) // '": ' // NF90_STRERROR( nc_stat ) )242 ENDIF243 #endif 244 245 END SUBROUTINE netcdf4_open_file219 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 246 249 247 250 !--------------------------------------------------------------------------------------------------! … … 250 253 !> Write attribute to netcdf file. 251 254 !--------------------------------------------------------------------------------------------------! 252 SUBROUTINE netcdf4_write_attribute( file_id, variable_id, attribute_name, &253 value_char, value_int8, value_int16, value_int32, &254 value_real32, value_real64, return_value )255 256 CHARACTER(LEN=*), INTENT(IN) :: attribute_name !< name of attribute257 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: value_char !< value of attribute258 259 CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_write_attribute' !< name of this routine260 261 INTEGER :: nc_stat !< netcdf return value262 INTEGER :: target_id !< ID of target which gets attribute (either global or variable_id)263 264 INTEGER, INTENT(IN) :: file_id !< file ID265 INTEGER, INTENT(OUT) :: return_value !< return value266 INTEGER, INTENT(IN) :: variable_id !< variable ID267 268 INTEGER(KIND=1), INTENT(IN), OPTIONAL :: value_int8 !< value of attribute269 INTEGER(KIND=2), INTENT(IN), OPTIONAL :: value_int16 !< value of attribute270 INTEGER(KIND=4), INTENT(IN), OPTIONAL :: value_int32 !< value of attribute271 272 REAL(KIND=4), INTENT(IN), OPTIONAL :: value_real32 !< value of attribute273 REAL(KIND=8), INTENT(IN), OPTIONAL :: value_real64 !< value of attribute274 275 276 #if defined( __netcdf4 ) 277 return_value = 0278 279 IF ( variable_id == global_id_in_file ) THEN280 target_id = NF90_GLOBAL281 ELSE282 target_id = variable_id283 ENDIF284 285 CALL internal_message( 'debug', routine_name // &286 ': write attribute "' // TRIM( attribute_name ) // '"' )287 288 IF ( PRESENT( value_char ) ) THEN289 nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), TRIM( value_char ) )290 ELSEIF ( PRESENT( value_int8 ) ) THEN291 nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int8 )292 ELSEIF ( PRESENT( value_int16 ) ) THEN293 nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int16 )294 ELSEIF ( PRESENT( value_int32 ) ) THEN295 nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_int32 )296 ELSEIF ( PRESENT( value_real32 ) ) THEN297 nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_real32 )298 ELSEIF ( PRESENT( value_real64 ) ) THEN299 nc_stat = NF90_PUT_ATT( file_id, target_id, TRIM( attribute_name ), value_real64 )300 ELSE301 return_value = 1302 CALL internal_message( 'error', routine_name // &303 ': no value given for attribute "' // TRIM( attribute_name ) // '"' )304 ENDIF305 306 IF ( return_value == 0 ) THEN307 IF ( nc_stat /= NF90_NOERR ) THEN308 return_value = 1309 CALL internal_message( 'error', routine_name // &310 ': NetCDF error while writing attribute "' // &311 TRIM( attribute_name ) // '": ' // NF90_STRERROR( nc_stat ) )312 ENDIF313 ENDIF314 #else 315 return_value = 1316 #endif 317 318 END SUBROUTINE netcdf4_write_attribute255 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 319 322 320 323 !--------------------------------------------------------------------------------------------------! … … 323 326 !> Initialize dimension. 324 327 !--------------------------------------------------------------------------------------------------! 325 SUBROUTINE netcdf4_init_dimension( mode, file_id, dimension_id, variable_id, &326 dimension_name, dimension_type, dimension_length, return_value )327 328 CHARACTER(LEN=*), INTENT(IN) :: dimension_name !< name of dimension329 CHARACTER(LEN=*), INTENT(IN) :: dimension_type !< data type of dimension330 CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode (either parallel or serial)331 332 CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_init_dimension' !< name of this routine333 334 INTEGER, INTENT(OUT) :: dimension_id !< dimension ID335 INTEGER, INTENT(IN) :: dimension_length !< length of dimension336 INTEGER, INTENT(IN) :: file_id !< file ID337 INTEGER :: nc_dimension_length !< length of dimension338 INTEGER :: nc_stat !< netcdf return value339 INTEGER, INTENT(OUT) :: return_value !< return value340 INTEGER, INTENT(OUT) :: variable_id !< variable ID341 342 343 #if defined( __netcdf4 ) 344 return_value = 0345 variable_id = -1346 347 CALL internal_message( 'debug', routine_name // &348 ': init dimension "' // TRIM( dimension_name ) // '"' )349 350 351 IF ( dimension_length < 0 ) THEN352 nc_dimension_length = NF90_UNLIMITED353 ELSE354 nc_dimension_length = dimension_length355 ENDIF356 357 358 nc_stat = NF90_DEF_DIM( file_id, dimension_name, nc_dimension_length, dimension_id )359 360 IF ( nc_stat == NF90_NOERR ) THEN361 362 !--Define variable holding dimension values in file363 CALL netcdf4_init_variable( mode, file_id, variable_id, dimension_name, dimension_type, &364 (/ dimension_id /), is_global=.TRUE., return_value=return_value )365 366 ELSE367 return_value = 1368 CALL internal_message( 'error', routine_name // &369 ': NetCDF error while initializing dimension "' // &370 TRIM( dimension_name ) // '": ' // NF90_STRERROR( nc_stat ) )371 ENDIF372 #else 373 return_value = 1374 variable_id = -1375 dimension_id = -1376 #endif 377 378 END SUBROUTINE netcdf4_init_dimension328 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 379 382 380 383 !--------------------------------------------------------------------------------------------------! … … 383 386 !> Initialize variable. 384 387 !--------------------------------------------------------------------------------------------------! 385 SUBROUTINE netcdf4_init_variable( mode, file_id, variable_id, variable_name, variable_type, &386 dimension_ids, is_global, return_value )387 388 CHARACTER(LEN=*), INTENT(IN) :: mode !< operation mode (either parallel or serial)389 CHARACTER(LEN=*), INTENT(IN) :: variable_name !< name of variable390 CHARACTER(LEN=*), INTENT(IN) :: variable_type !< data type of variable391 392 CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_init_variable' !< name of this routine393 394 INTEGER, INTENT(IN) :: file_id !< file ID395 INTEGER :: nc_stat !< netcdf return value396 INTEGER :: nc_variable_type !< netcdf data type397 INTEGER, INTENT(OUT) :: return_value !< return value398 INTEGER, INTENT(OUT) :: variable_id !< variable ID399 400 INTEGER, DIMENSION(:), INTENT(IN) :: dimension_ids !< list of dimension IDs used by variable401 402 LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE)403 404 405 #if defined( __netcdf4 ) 406 return_value = 0407 408 WRITE( temp_string, * ) is_global409 CALL internal_message( 'debug', routine_name // &410 ': init variable "' // TRIM( variable_name ) // &411 '" ( is_global = ' // TRIM( temp_string ) // ')' )412 413 nc_variable_type = get_netcdf_data_type( variable_type )414 415 IF ( nc_variable_type /= -1 ) THEN416 417 !--Define variable in file418 nc_stat = NF90_DEF_VAR( file_id, variable_name, nc_variable_type, dimension_ids, variable_id )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 ) 419 422 420 423 #if defined( __netcdf4_parallel ) 421 !-- Define how variable can be accessed by PEs in parallel netcdf file 422 IF ( nc_stat == NF90_NOERR .AND. TRIM( mode ) == mode_parallel ) THEN 423 IF ( is_global ) THEN 424 nc_stat = NF90_VAR_PAR_ACCESS( file_id, variable_id, NF90_INDEPENDENT ) 425 ELSE 426 nc_stat = NF90_VAR_PAR_ACCESS( file_id, variable_id, NF90_COLLECTIVE ) 427 ENDIF 428 ENDIF 429 #endif 430 431 IF ( nc_stat /= NF90_NOERR ) THEN 432 return_value = 1 433 CALL internal_message( 'error', routine_name // & 434 ': NetCDF error while initializing variable "' // & 435 TRIM( variable_name ) // '": ' // NF90_STRERROR( nc_stat ) ) 436 ENDIF 437 438 ELSE 439 return_value = 1 440 ENDIF 441 442 #else 443 return_value = 1 444 variable_id = -1 445 #endif 446 447 END SUBROUTINE netcdf4_init_variable 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 448 452 449 453 !--------------------------------------------------------------------------------------------------! … … 452 456 !> Leave file definition state. 453 457 !--------------------------------------------------------------------------------------------------! 454 SUBROUTINE netcdf4_stop_file_header_definition( file_id, return_value )455 456 CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_stop_file_header_definition' !< name of this routine457 458 INTEGER, INTENT(IN) :: file_id !< file ID459 INTEGER :: nc_stat !< netcdf return value460 INTEGER :: old_fill_mode !< previous netcdf fill mode461 INTEGER, INTENT(OUT) :: return_value !< return value462 463 464 #if defined( __netcdf4 ) 465 return_value = 0466 467 WRITE( temp_string, * ) file_id468 CALL internal_message( 'debug', routine_name // &469 ': finalize file definition (file_id=' // TRIM( temp_string ) // ')' )470 471 472 nc_stat = NF90_SET_FILL( file_id, NF90_NOFILL, old_fill_mode )473 474 IF ( nc_stat == NF90_NOERR ) THEN475 nc_stat = NF90_ENDDEF( file_id )476 ENDIF477 478 IF ( nc_stat /= NF90_NOERR ) THEN479 return_value = 1480 CALL internal_message( 'error', routine_name // &481 ': NetCDF error: ' // NF90_STRERROR( nc_stat ) )482 ENDIF483 #else 484 return_value = 1485 #endif 486 487 END SUBROUTINE netcdf4_stop_file_header_definition458 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 488 492 489 493 !--------------------------------------------------------------------------------------------------! … … 492 496 !> Write variable of different kind into netcdf file. 493 497 !--------------------------------------------------------------------------------------------------! 494 SUBROUTINE netcdf4_write_variable( &495 file_id, variable_id, bounds_start, value_counts, bounds_origin, &496 is_global, &497 values_int8_0d, values_int8_1d, values_int8_2d, values_int8_3d, &498 values_int16_0d, values_int16_1d, values_int16_2d, values_int16_3d, &499 values_int32_0d, values_int32_1d, values_int32_2d, values_int32_3d, &500 values_intwp_0d, values_intwp_1d, values_intwp_2d, values_intwp_3d, &501 values_real32_0d, values_real32_1d, values_real32_2d, values_real32_3d, &502 values_real64_0d, values_real64_1d, values_real64_2d, values_real64_3d, &503 values_realwp_0d, values_realwp_1d, values_realwp_2d, values_realwp_3d, &504 return_value )505 506 CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_write_variable' !< name of this routine507 508 INTEGER :: d !< loop index509 INTEGER, INTENT(IN) :: file_id !< file ID510 INTEGER :: my_rank !< MPI rank of processor511 INTEGER :: nc_stat !< netcdf return value512 INTEGER :: ndims !< number of dimensions of variable in file513 INTEGER, INTENT(OUT) :: return_value !< return value514 INTEGER, INTENT(IN) :: variable_id !< variable ID515 516 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_origin !< starting index of each dimension517 INTEGER, DIMENSION(:), INTENT(IN) :: bounds_start !< starting index of variable518 INTEGER, DIMENSION(:), ALLOCATABLE :: dimension_ids !< IDs of dimensions of variable in file519 INTEGER, DIMENSION(:), ALLOCATABLE :: dimension_lengths !< length of dimensions of variable in file520 INTEGER, DIMENSION(:), INTENT(IN) :: value_counts !< count of values along each dimension to be written521 522 INTEGER(KIND=1), POINTER, INTENT(IN), OPTIONAL :: values_int8_0d !< output variable523 INTEGER(KIND=2), POINTER, INTENT(IN), OPTIONAL :: values_int16_0d !< output variable524 INTEGER(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_int32_0d !< output variable525 INTEGER(iwp), POINTER, INTENT(IN), OPTIONAL :: values_intwp_0d !< output variable526 INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int8_1d !< output variable527 INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int16_1d !< output variable528 INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_int32_1d !< output variable529 INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_intwp_1d !< output variable530 INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int8_2d !< output variable531 INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int16_2d !< output variable532 INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_int32_2d !< output variable533 INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_intwp_2d !< output variable534 INTEGER(KIND=1), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int8_3d !< output variable535 INTEGER(KIND=2), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int16_3d !< output variable536 INTEGER(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_int32_3d !< output variable537 INTEGER(iwp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_intwp_3d !< output variable538 539 LOGICAL, INTENT(IN) :: is_global !< true if variable is global (same on all PE)540 541 REAL(KIND=4), POINTER, INTENT(IN), OPTIONAL :: values_real32_0d !< output variable542 REAL(KIND=8), POINTER, INTENT(IN), OPTIONAL :: values_real64_0d !< output variable543 REAL(wp), POINTER, INTENT(IN), OPTIONAL :: values_realwp_0d !< output variable544 REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real32_1d !< output variable545 REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_real64_1d !< output variable546 REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:) :: values_realwp_1d !< output variable547 REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real32_2d !< output variable548 REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_real64_2d !< output variable549 REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: values_realwp_2d !< output variable550 REAL(KIND=4), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real32_3d !< output variable551 REAL(KIND=8), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_real64_3d !< output variable552 REAL(wp), POINTER, CONTIGUOUS, INTENT(IN), OPTIONAL, DIMENSION(:,:,:) :: values_realwp_3d !< output variable498 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 553 557 554 558 … … 556 560 557 561 #if defined( __parallel ) 558 CALL MPI_COMM_RANK( output_group_comm, my_rank, return_value ) 559 IF ( return_value /= 0 ) THEN 560 CALL internal_message( 'error', routine_name // ': MPI_COMM_RANK error' ) 561 ENDIF 562 #else 563 my_rank = master_rank 564 return_value = 0 565 #endif 566 567 IF ( return_value == 0 .AND. ( .NOT. is_global .OR. my_rank == master_rank ) ) THEN 568 569 WRITE( temp_string, * ) variable_id 570 CALL internal_message( 'debug', routine_name // ': write variable ' // TRIM( temp_string ) ) 571 572 ndims = SIZE( bounds_start ) 573 574 !-- 8bit integer output 575 IF ( PRESENT( values_int8_0d ) ) THEN 576 nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int8_0d /), & 577 start = bounds_start - bounds_origin + 1, & 578 count = value_counts ) 579 ELSEIF ( PRESENT( values_int8_1d ) ) THEN 580 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_1d, & 581 start = bounds_start - bounds_origin + 1, & 582 count = value_counts ) 583 ELSEIF ( PRESENT( values_int8_2d ) ) THEN 584 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_2d, & 585 start = bounds_start - bounds_origin + 1, & 586 count = value_counts ) 587 ELSEIF ( PRESENT( values_int8_3d ) ) THEN 588 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int8_3d, & 589 start = bounds_start - bounds_origin + 1, & 590 count = value_counts ) 591 !-- 16bit integer output 592 ELSEIF ( PRESENT( values_int16_0d ) ) THEN 593 nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int16_0d /), & 594 start = bounds_start - bounds_origin + 1, & 595 count = value_counts ) 596 ELSEIF ( PRESENT( values_int16_1d ) ) THEN 597 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_1d, & 598 start = bounds_start - bounds_origin + 1, & 599 count = value_counts ) 600 ELSEIF ( PRESENT( values_int16_2d ) ) THEN 601 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_2d, & 602 start = bounds_start - bounds_origin + 1, & 603 count = value_counts ) 604 ELSEIF ( PRESENT( values_int16_3d ) ) THEN 605 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int16_3d, & 606 start = bounds_start - bounds_origin + 1, & 607 count = value_counts ) 608 !-- 32bit integer output 609 ELSEIF ( PRESENT( values_int32_0d ) ) THEN 610 nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_int32_0d /), & 611 start = bounds_start - bounds_origin + 1, & 612 count = value_counts ) 613 ELSEIF ( PRESENT( values_int32_1d ) ) THEN 614 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_1d, & 615 start = bounds_start - bounds_origin + 1, & 616 count = value_counts ) 617 ELSEIF ( PRESENT( values_int32_2d ) ) THEN 618 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_2d, & 619 start = bounds_start - bounds_origin + 1, & 620 count = value_counts ) 621 ELSEIF ( PRESENT( values_int32_3d ) ) THEN 622 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_int32_3d, & 623 start = bounds_start - bounds_origin + 1, & 624 count = value_counts ) 625 !-- working-precision integer output 626 ELSEIF ( PRESENT( values_intwp_0d ) ) THEN 627 nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_intwp_0d /), & 628 start = bounds_start - bounds_origin + 1, & 629 count = value_counts ) 630 ELSEIF ( PRESENT( values_intwp_1d ) ) THEN 631 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_1d, & 632 start = bounds_start - bounds_origin + 1, & 633 count = value_counts ) 634 ELSEIF ( PRESENT( values_intwp_2d ) ) THEN 635 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_2d, & 636 start = bounds_start - bounds_origin + 1, & 637 count = value_counts ) 638 ELSEIF ( PRESENT( values_intwp_3d ) ) THEN 639 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_intwp_3d, & 640 start = bounds_start - bounds_origin + 1, & 641 count = value_counts ) 642 !-- 32bit real output 643 ELSEIF ( PRESENT( values_real32_0d ) ) THEN 644 nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_real32_0d /), & 645 start = bounds_start - bounds_origin + 1, & 646 count = value_counts ) 647 ELSEIF ( PRESENT( values_real32_1d ) ) THEN 648 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_1d, & 649 start = bounds_start - bounds_origin + 1, & 650 count = value_counts ) 651 ELSEIF ( PRESENT( values_real32_2d ) ) THEN 652 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_2d, & 653 start = bounds_start - bounds_origin + 1, & 654 count = value_counts ) 655 ELSEIF ( PRESENT( values_real32_3d ) ) THEN 656 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real32_3d, & 657 start = bounds_start - bounds_origin + 1, & 658 count = value_counts ) 659 !-- 64bit real output 660 ELSEIF ( PRESENT( values_real64_0d ) ) THEN 661 nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_real64_0d /), & 662 start = bounds_start - bounds_origin + 1, & 663 count = value_counts ) 664 ELSEIF ( PRESENT( values_real64_1d ) ) THEN 665 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_1d, & 666 start = bounds_start - bounds_origin + 1, & 667 count = value_counts ) 668 ELSEIF ( PRESENT( values_real64_2d ) ) THEN 669 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_2d, & 670 start = bounds_start - bounds_origin + 1, & 671 count = value_counts ) 672 ELSEIF ( PRESENT( values_real64_3d ) ) THEN 673 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_real64_3d, & 674 start = bounds_start - bounds_origin + 1, & 675 count = value_counts ) 676 !-- working-precision real output 677 ELSEIF ( PRESENT( values_realwp_0d ) ) THEN 678 nc_stat = NF90_PUT_VAR( file_id, variable_id, (/ values_realwp_0d /), & 679 start = bounds_start - bounds_origin + 1, & 680 count = value_counts ) 681 ELSEIF ( PRESENT( values_realwp_1d ) ) THEN 682 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_1d, & 683 start = bounds_start - bounds_origin + 1, & 684 count = value_counts ) 685 ELSEIF ( PRESENT( values_realwp_2d ) ) THEN 686 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_2d, & 687 start = bounds_start - bounds_origin + 1, & 688 count = value_counts ) 689 ELSEIF ( PRESENT( values_realwp_3d ) ) THEN 690 nc_stat = NF90_PUT_VAR( file_id, variable_id, values_realwp_3d, & 691 start = bounds_start - bounds_origin + 1, & 692 count = value_counts ) 693 ELSE 694 return_value = 1 695 nc_stat = NF90_NOERR 696 WRITE( temp_string, '(": variable_id=",I6,", file_id=",I6)' ) variable_id, file_id 697 CALL internal_message( 'error', routine_name // & 698 ': no output values given ' // TRIM( temp_string ) ) 699 ENDIF 700 701 !-- Check for errors 702 IF ( nc_stat /= NF90_NOERR ) THEN 703 return_value = 1 704 705 IF ( nc_stat == NF90_EEDGE .OR. nc_stat == NF90_EINVALCOORDS ) THEN 706 707 !-- If given bounds exceed dimension bounds, get information of bounds in file 708 WRITE( temp_string, * ) NF90_STRERROR( nc_stat ) 709 710 ALLOCATE( dimension_ids(ndims) ) 711 ALLOCATE( dimension_lengths(ndims) ) 712 713 nc_stat = NF90_INQUIRE_VARIABLE( file_id, variable_id, dimids=dimension_ids ) 714 715 d = 1 716 DO WHILE ( d <= ndims .AND. nc_stat == NF90_NOERR ) 717 nc_stat = NF90_INQUIRE_DIMENSION( file_id, dimension_ids(d), & 718 LEN=dimension_lengths(d) ) 719 d = d + 1 720 ENDDO 721 722 IF ( nc_stat == NF90_NOERR ) THEN 723 WRITE( temp_string, * ) TRIM( temp_string ) // '; given variable bounds: ' // & 724 'start=', bounds_start, ', count=', value_counts, ', origin=', bounds_origin 725 CALL internal_message( 'error', routine_name // & 726 ': error while writing: ' // TRIM( temp_string ) ) 727 ELSE 728 !-- Error occured during NF90_INQUIRE_VARIABLE or NF90_INQUIRE_DIMENSION 729 CALL internal_message( 'error', routine_name // & 730 ': error while accessing file: ' // & 731 NF90_STRERROR( nc_stat ) ) 732 ENDIF 733 734 ELSE 735 !-- Other NetCDF error 736 CALL internal_message( 'error', routine_name // & 737 ': error while writing: ' // NF90_STRERROR( nc_stat ) ) 738 ENDIF 739 ENDIF 740 741 ENDIF 742 #else 743 return_value = 1 744 #endif 745 746 END SUBROUTINE netcdf4_write_variable 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 747 759 748 760 !--------------------------------------------------------------------------------------------------! … … 751 763 !> Close netcdf file. 752 764 !--------------------------------------------------------------------------------------------------! 753 SUBROUTINE netcdf4_finalize( file_id, return_value )754 755 CHARACTER(LEN=*), PARAMETER :: routine_name = 'netcdf4_finalize' !< name of routine756 757 INTEGER, INTENT(IN) :: file_id !< file ID758 INTEGER :: nc_stat !< netcdf return value759 INTEGER, INTENT(OUT) :: return_value !< return value760 761 762 #if defined( __netcdf4 ) 763 WRITE( temp_string, * ) file_id764 CALL internal_message( 'debug', routine_name // &765 ': close file (file_id=' // TRIM( temp_string ) // ')' )766 767 nc_stat = NF90_CLOSE( file_id )768 IF ( nc_stat == NF90_NOERR ) THEN769 return_value = 0770 ELSE771 return_value = 1772 CALL internal_message( 'error', routine_name // &773 ': NetCDF error: ' // NF90_STRERROR( nc_stat ) )774 ENDIF775 #else 776 return_value = 1777 #endif 778 779 END SUBROUTINE netcdf4_finalize765 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 780 792 781 793 !--------------------------------------------------------------------------------------------------! … … 784 796 !> Convert data_type string into netcdf data type value. 785 797 !--------------------------------------------------------------------------------------------------! 786 FUNCTION get_netcdf_data_type( data_type ) RESULT( return_value )787 788 CHARACTER(LEN=*), INTENT(IN) :: data_type !< requested data type789 790 CHARACTER(LEN=*), PARAMETER :: routine_name = 'get_netcdf_data_type' !< name of this routine791 792 INTEGER :: return_value !< netcdf data type793 794 795 SELECT CASE ( TRIM( data_type ) )796 797 #if defined( __netcdf4 ) 798 CASE ( 'char' )799 return_value = NF90_CHAR800 801 CASE ( 'int8' )802 return_value = NF90_BYTE803 804 CASE ( 'int16' )805 return_value = NF90_SHORT806 807 CASE ( 'int32' )808 return_value = NF90_INT809 810 CASE ( 'real32' )811 return_value = NF90_FLOAT812 813 CASE ( 'real64' )814 return_value = NF90_DOUBLE815 #endif 816 817 CASE DEFAULT818 CALL internal_message( 'error', routine_name // &819 ': data type unknown (' // TRIM( data_type ) // ')' )820 return_value = -1821 822 END SELECT823 824 END FUNCTION get_netcdf_data_type798 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 825 837 826 838 !--------------------------------------------------------------------------------------------------! … … 830 842 !> or creating the error message string. 831 843 !--------------------------------------------------------------------------------------------------! 832 SUBROUTINE internal_message( level, string )833 834 CHARACTER(LEN=*), INTENT(IN) :: level !< message importance level835 CHARACTER(LEN=*), INTENT(IN) :: string !< message string836 837 838 IF ( TRIM( level ) == 'error' ) THEN839 840 WRITE( internal_error_message, '(A,A)' ) ': ', string841 842 ELSEIF ( TRIM( level ) == 'debug' .AND. print_debug_output ) THEN843 844 WRITE( debug_output_unit, '(A,A)' ) 'DOM DEBUG: ', string845 FLUSH( debug_output_unit )846 847 ENDIF848 849 END SUBROUTINE internal_message844 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 850 862 851 863 !--------------------------------------------------------------------------------------------------! … … 854 866 !> Return the last created error message. 855 867 !--------------------------------------------------------------------------------------------------! 856 FUNCTION netcdf4_get_error_message() RESULT( error_message )857 858 CHARACTER(LEN=800) :: error_message !< return error message to main program859 860 861 error_message = TRIM( internal_error_message )862 863 internal_error_message = ''864 865 END FUNCTION netcdf4_get_error_message866 867 868 END MODULE data_output_netcdf4_module868 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 TracChangeset
for help on using the changeset viewer.
