1!****h* root/fortran/test/tH5T.f90 2! 3! NAME 4! tH5T.f90 5! 6! FUNCTION 7! Basic testing of Fortran H5T APIs. 8! 9! COPYRIGHT 10! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 11! Copyright by The HDF Group. * 12! Copyright by the Board of Trustees of the University of Illinois. * 13! All rights reserved. * 14! * 15! This file is part of HDF5. The full HDF5 copyright notice, including * 16! terms governing use, modification, and redistribution, is contained in * 17! the COPYING file, which can be found at the root of the source code * 18! distribution tree, or in https://support.hdfgroup.org/ftp/HDF5/releases. * 19! If you do not have access to either file, you may request a copy from * 20! help@hdfgroup.org. * 21! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 22! 23! CONTAINS SUBROUTINES 24! compoundtest, basic_data_type_test, enumtest, test_derived_flt 25! 26!***** 27 28MODULE TH5T 29 30 USE HDF5 31 USE TH5_MISC 32 USE TH5_MISC_GEN 33 34CONTAINS 35 36 SUBROUTINE compoundtest(cleanup, total_error) 37! 38! This program creates a dataset that is one dimensional array of 39! structures { 40! character*2 41! integer 42! double precision 43! real 44! } 45! Data is written and read back by fields. 46! 47! The following H5T interface functions are tested: 48! h5tcopy_f, h5tset(get)_size_f, h5tcreate_f, h5tinsert_f, h5tclose_f, 49! h5tget_class_f, h5tget_member_name_f, h5tget_member_offset_f, h5tget_member_type_f, 50! h5tequal_f, h5tinsert_array_f, h5tcommit_f, h5tencode_f, h5tdecode_f 51 52 53 IMPLICIT NONE 54 LOGICAL, INTENT(IN) :: cleanup 55 INTEGER, INTENT(OUT) :: total_error 56 57 CHARACTER(LEN=8), PARAMETER :: filename = "compound" ! File name 58 CHARACTER(LEN=80) :: fix_filename 59 CHARACTER(LEN=8), PARAMETER :: dsetname = "Compound" ! Dataset name 60 INTEGER, PARAMETER :: dimsize = 6 ! Size of the dataset 61 INTEGER, PARAMETER :: COMP_NUM_MEMBERS = 4 ! Number of members in the compound datatype 62 63 INTEGER(HID_T) :: file_id ! File identifier 64 INTEGER(HID_T) :: dset_id ! Dataset identifier 65 INTEGER(HID_T) :: dspace_id ! Dataspace identifier 66 INTEGER(HID_T) :: dtype_id ! Compound datatype identifier 67 INTEGER(HID_T) :: dtarray_id ! Compound datatype identifier 68 INTEGER(HID_T) :: arrayt_id ! Array datatype identifier 69 INTEGER(HID_T) :: dt1_id ! Memory datatype identifier (for character field) 70 INTEGER(HID_T) :: dt2_id ! Memory datatype identifier (for integer field) 71 INTEGER(HID_T) :: dt3_id ! Memory datatype identifier (for double precision field) 72 INTEGER(HID_T) :: dt4_id ! Memory datatype identifier (for real field) 73 INTEGER(HID_T) :: dt5_id ! Memory datatype identifier 74 INTEGER(HID_T) :: membtype_id ! Datatype identifier 75 INTEGER(HID_T) :: plist_id ! Dataset trasfer property 76 77 78 INTEGER(HSIZE_T), DIMENSION(1) :: dims = (/dimsize/) ! Dataset dimensions 79 INTEGER :: rank = 1 ! Dataset rank 80 81 INTEGER :: error ! Error flag 82 INTEGER(SIZE_T) :: type_size ! Size of the datatype 83 INTEGER(SIZE_T) :: type_sizec ! Size of the character datatype 84 INTEGER(SIZE_T) :: type_sizei ! Size of the integer datatype 85 INTEGER(SIZE_T) :: type_sized ! Size of the double precision datatype 86 INTEGER(SIZE_T) :: type_sizer ! Size of the real datatype 87 INTEGER(SIZE_T) :: offset ! Member's offset 88 INTEGER(SIZE_T) :: offset_out ! Member's offset 89 CHARACTER(LEN=2), DIMENSION(dimsize) :: char_member 90 CHARACTER(LEN=2), DIMENSION(dimsize) :: char_member_out ! Buffer to read data out 91 INTEGER, DIMENSION(dimsize) :: int_member 92 INTEGER, DIMENSION(dimsize) :: int_member_out 93 REAL(KIND=Fortran_DOUBLE), DIMENSION(dimsize) :: double_member 94 REAL(KIND=Fortran_DOUBLE), DIMENSION(dimsize) :: double_member_out 95 REAL, DIMENSION(dimsize) :: real_member 96 REAL, DIMENSION(dimsize) :: real_member_out 97 INTEGER :: i 98 INTEGER :: class ! Datatype class 99 INTEGER :: num_members ! Number of members in the compound datatype 100 CHARACTER(LEN=256) :: member_name 101 INTEGER :: len ! Lenght of the name of the compound datatype member 102 INTEGER :: member_index ! index of the field 103 INTEGER(HSIZE_T), DIMENSION(3) :: array_dims=(/2,3,4/) 104 INTEGER :: array_dims_range = 3 105 INTEGER :: elements = 24 ! number of elements in the array_dims array. 106 INTEGER(SIZE_T) :: sizechar 107 INTEGER(HSIZE_T), DIMENSION(1) :: data_dims 108 LOGICAL :: flag = .TRUE. 109 110 CHARACTER(LEN=1024) :: cmpd_buf 111 INTEGER(SIZE_T) :: cmpd_buf_size=0 112 INTEGER(HID_T) :: decoded_tid1 113 114 INTEGER(HID_T) :: fixed_str1, fixed_str2 115 LOGICAL :: are_equal 116 INTEGER(SIZE_T), PARAMETER :: str_size = 10 117 INTEGER(SIZE_T) :: query_size 118 119 ! Test h5tcreate_f with H5T_STRING_F option: 120 ! Create fixed-length string in two ways and make sure they are the same 121 122 CALL h5tcopy_f(H5T_FORTRAN_S1, fixed_str1, error) 123 CALL check("h5tcopy_f", error, total_error) 124 CALL h5tset_size_f(fixed_str1, str_size, error) 125 CALL check("h5tset_size_f", error, total_error) 126 CALL h5tset_strpad_f(fixed_str1, H5T_STR_NULLTERM_F, error) 127 CALL check("h5tset_strpad_f", error, total_error) 128 129 CALL h5tcreate_f(H5T_STRING_F, str_size, fixed_str2, error) 130 CALL check("h5tcreate_f", error, total_error) 131 CALL h5tset_strpad_f(fixed_str2, H5T_STR_NULLTERM_F, error) 132 CALL check("h5tset_strpad_f", error, total_error) 133 134 CALL h5tequal_f(fixed_str1, fixed_str2, are_equal, error) 135 IF(.NOT.are_equal)THEN 136 CALL check("h5tcreate_f", -1, total_error) 137 ENDIF 138 139 CALL h5tget_size_f(fixed_str1, query_size, error) 140 CALL check("h5tget_size_f", error, total_error) 141 142 IF(query_size.NE.str_size)THEN 143 CALL check("h5tget_size_f", -1, total_error) 144 ENDIF 145 146 CALL h5tget_size_f(fixed_str2, query_size, error) 147 CALL check("h5tget_size_f", error, total_error) 148 149 IF(query_size.NE.str_size)THEN 150 CALL check("h5tget_size_f", -1, total_error) 151 ENDIF 152 153 CALL h5tclose_f(fixed_str1,error) 154 CALL check("h5tclose_f", error, total_error) 155 156 CALL h5tclose_f(fixed_str2,error) 157 CALL check("h5tclose_f", error, total_error) 158 data_dims(1) = dimsize 159 ! 160 ! Initialize data buffer. 161 ! 162 do i = 1, dimsize 163 char_member(i)(1:1) = char(65+i) 164 char_member(i)(2:2) = char(65+i) 165 char_member_out(i)(1:1) = char(65) 166 char_member_out(i)(2:2) = char(65) 167 int_member(i) = i 168 int_member_out(i) = 0 169 double_member(i) = 2.* i 170 double_member_out(i) = 0. 171 real_member(i) = 3. * i 172 real_member_out(i) = 0. 173 enddo 174 175 ! 176 ! Set dataset transfer property to preserve partially initialized fields 177 ! during write/read to/from dataset with compound datatype. 178 ! 179 CALL h5pcreate_f(H5P_DATASET_XFER_F, plist_id, error) 180 CALL check("h5pcreate_f", error, total_error) 181 CALL h5pset_preserve_f(plist_id, flag, error) 182 CALL check("h5pset_preserve_f", error, total_error) 183 ! 184 ! Create a new file using default properties. 185 ! 186 CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) 187 if (error .ne. 0) then 188 write(*,*) "Cannot modify filename" 189 stop 190 endif 191 CALL h5fcreate_f(fix_filename, H5F_ACC_TRUNC_F, file_id, error) 192 CALL check("h5fcreate_f", error, total_error) 193 194 ! 195 ! Create the dataspace. 196 ! 197 CALL h5screate_simple_f(rank, dims, dspace_id, error) 198 CALL check("h5screate_simple_f", error, total_error) 199 ! 200 ! Create compound datatype. 201 ! 202 ! First calculate total size by calculating sizes of each member 203 ! 204 CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, error) 205 CALL check("h5tcopy_f", error, total_error) 206 sizechar = 2 207 CALL h5tset_size_f(dt5_id, sizechar, error) 208 CALL check("h5tset_size_f", error, total_error) 209 CALL h5tget_size_f(dt5_id, type_sizec, error) 210 CALL check("h5tget_size_f", error, total_error) 211 CALL h5tget_size_f(H5T_NATIVE_INTEGER, type_sizei, error) 212 CALL check("h5tget_size_f", error, total_error) 213 CALL h5tget_size_f(H5T_NATIVE_DOUBLE, type_sized, error) 214 CALL check("h5tget_size_f", error, total_error) 215 CALL h5tget_size_f(H5T_NATIVE_REAL, type_sizer, error) 216 CALL check("h5tget_size_f", error, total_error) 217 !write(*,*) "get sizes", type_sizec, type_sizei, type_sizer, type_sized 218 type_size = type_sizec + type_sizei + type_sized + type_sizer 219 CALL h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, error) 220 CALL check("h5tcreate_f", error, total_error) 221 ! 222 ! Insert memebers 223 ! 224 ! CHARACTER*2 memeber 225 ! 226 offset = 0 227 CALL h5tinsert_f(dtype_id, "char_field", offset, dt5_id, error) 228 CALL check("h5tinsert_f", error, total_error) 229 ! 230 ! INTEGER member 231 ! 232 offset = offset + type_sizec ! Offset of the second memeber is 2 233 CALL h5tinsert_f(dtype_id, "integer_field", offset, H5T_NATIVE_INTEGER, error) 234 CALL check("h5tinsert_f", error, total_error) 235 ! 236 ! DOUBLE PRECISION member 237 ! 238 offset = offset + type_sizei ! Offset of the third memeber is 6 239 CALL h5tinsert_f(dtype_id, "double_field", offset, H5T_NATIVE_DOUBLE, error) 240 CALL check("h5tinsert_f", error, total_error) 241 ! 242 ! REAL member 243 ! 244 offset = offset + type_sized ! Offset of the last member is 14 245 CALL h5tinsert_f(dtype_id, "real_field", offset, H5T_NATIVE_REAL, error) 246 CALL check("h5tinsert_f", error, total_error) 247 ! 248 ! Create the dataset with compound datatype. 249 ! 250 CALL h5dcreate_f(file_id, dsetname, dtype_id, dspace_id, & 251 dset_id, error) 252 CALL check("h5dcreate_f", error, total_error) 253 ! 254 ! Create memory types. We have to create a compound datatype 255 ! for each member we want to write. 256 ! 257 CALL h5tcreate_f(H5T_COMPOUND_F, type_sizec, dt1_id, error) 258 CALL check("h5tcreate_f", error, total_error) 259 offset = 0 260 CALL h5tinsert_f(dt1_id, "char_field", offset, dt5_id, error) 261 CALL check("h5tinsert_f", error, total_error) 262 ! 263 CALL h5tcreate_f(H5T_COMPOUND_F, type_sizei, dt2_id, error) 264 CALL check("h5tcreate_f", error, total_error) 265 offset = 0 266 CALL h5tinsert_f(dt2_id, "integer_field", offset, H5T_NATIVE_INTEGER, error) 267 CALL check("h5tinsert_f", error, total_error) 268 ! 269 CALL h5tcreate_f(H5T_COMPOUND_F, type_sized, dt3_id, error) 270 CALL check("h5tcreate_f", error, total_error) 271 offset = 0 272 CALL h5tinsert_f(dt3_id, "double_field", offset, H5T_NATIVE_DOUBLE, error) 273 CALL check("h5tinsert_f", error, total_error) 274 ! 275 CALL h5tcreate_f(H5T_COMPOUND_F, type_sizer, dt4_id, error) 276 CALL check("h5tcreate_f", error, total_error) 277 offset = 0 278 CALL h5tinsert_f(dt4_id, "real_field", offset, H5T_NATIVE_REAL, error) 279 CALL check("h5tinsert_f", error, total_error) 280 ! 281 ! Write data by fields in the datatype. Fields order is not important. 282 ! 283 CALL h5dwrite_f(dset_id, dt4_id, real_member, data_dims, error, xfer_prp = plist_id) 284 CALL check("h5dwrite_f", error, total_error) 285 CALL h5dwrite_f(dset_id, dt1_id, char_member, data_dims, error, xfer_prp = plist_id) 286 CALL check("h5dwrite_f", error, total_error) 287 CALL h5dwrite_f(dset_id, dt3_id, double_member, data_dims, error, xfer_prp = plist_id) 288 CALL check("h5dwrite_f", error, total_error) 289 CALL h5dwrite_f(dset_id, dt2_id, int_member, data_dims, error, xfer_prp = plist_id) 290 CALL check("h5dwrite_f", error, total_error) 291 292 ! 293 ! End access to the dataset and release resources used by it. 294 ! 295 CALL h5dclose_f(dset_id, error) 296 CALL check("h5dclose_f", error, total_error) 297 298 ! 299 ! Terminate access to the data space. 300 ! 301 CALL h5sclose_f(dspace_id, error) 302 CALL check("h5sclose_f", error, total_error) 303 ! 304 ! Terminate access to the datatype 305 ! 306 CALL h5tclose_f(dtype_id, error) 307 CALL check("h5tclose_f", error, total_error) 308 CALL h5tclose_f(dt1_id, error) 309 CALL check("h5tclose_f", error, total_error) 310 CALL h5tclose_f(dt2_id, error) 311 CALL check("h5tclose_f", error, total_error) 312 CALL h5tclose_f(dt3_id, error) 313 CALL check("h5tclose_f", error, total_error) 314 CALL h5tclose_f(dt4_id, error) 315 CALL check("h5tclose_f", error, total_error) 316 ! 317 ! Create and store compound datatype with the character and 318 ! array members. 319 ! 320 type_size = type_sizec + elements*type_sizer ! Size of compound datatype 321 CALL h5tcreate_f(H5T_COMPOUND_F, type_size, dtarray_id, error) 322 CALL check("h5tcreate_f", error, total_error) 323 offset = 0 324 CALL h5tinsert_f(dtarray_id, "char_field", offset, H5T_NATIVE_CHARACTER, error) 325 CALL check("h5tinsert_f", error, total_error) 326 offset = type_sizec 327 CALL h5tarray_create_f(H5T_NATIVE_REAL, array_dims_range, array_dims, arrayt_id, error) 328 CALL check("h5tarray_create_f", error, total_error) 329 CALL h5tinsert_f(dtarray_id,"array_field", offset, arrayt_id, error) 330 CALL check("h5tinsert_f", error, total_error) 331 CALL h5tcommit_f(file_id, "Compound_with_array_member", dtarray_id, error) 332 CALL check("h5tcommit_f", error, total_error) 333 CALL h5tclose_f(arrayt_id, error) 334 CALL check("h5tclose_f", error, total_error) 335 CALL h5tclose_f(dtarray_id, error) 336 CALL check("h5tclose_f", error, total_error) 337 338 ! 339 ! Close the file. 340 ! 341 CALL h5fclose_f(file_id, error) 342 CALL check("h5fclose_f", error, total_error) 343 344 ! 345 ! Open the file. 346 ! 347 CALL h5fopen_f (fix_filename, H5F_ACC_RDWR_F, file_id, error) 348 CALL check("h5fopen_f", error, total_error) 349 ! 350 ! Open the dataset. 351 ! 352 CALL h5dopen_f(file_id, dsetname, dset_id, error) 353 CALL check("h5dopen_f", error, total_error) 354 ! 355 ! Get datatype of the open dataset. 356 ! Check it class, number of members, and member's names. 357 ! 358 CALL h5dget_type_f(dset_id, dtype_id, error) 359 CALL check("h5dget_type_f", error, total_error) 360 CALL h5tget_class_f(dtype_id, class, error) 361 CALL check("h5dget_class_f", error, total_error) 362 if (class .ne. H5T_COMPOUND_F) then 363 write(*,*) " Wrong class type returned" 364 total_error = total_error + 1 365 endif 366 CALL h5tget_nmembers_f(dtype_id, num_members, error) 367 CALL check("h5dget_nmembers_f", error, total_error) 368 if (num_members .ne. COMP_NUM_MEMBERS ) then 369 write(*,*) " Wrong number of members returned" 370 total_error = total_error + 1 371 endif 372 ! 373 ! Go through the members and find out their names and offsets. 374 ! Also see if name corresponds to the index 375 ! 376 do i = 1, num_members 377 CALL h5tget_member_name_f(dtype_id, i-1, member_name, len, error) 378 CALL check("h5tget_member_name_f", error, total_error) 379 CALL h5tget_member_offset_f(dtype_id, i-1, offset_out, error) 380 CALL check("h5tget_member_offset_f", error, total_error) 381 CALL h5tget_member_index_f(dtype_id, member_name(1:len), member_index, error) 382 CALL check("h5tget_member_index_f", error, total_error) 383 if(member_index .ne. i-1) then 384 write(*,*) "Index returned is incorrect" 385 write(*,*) member_index, i-1 386 total_error = total_error + 1 387 endif 388 389 CHECK_NAME: SELECT CASE (member_name(1:len)) 390 CASE("char_field") 391 if(offset_out .ne. 0) then 392 write(*,*) "Offset of the char member is incorrect" 393 total_error = total_error + 1 394 endif 395 CALL h5tget_member_type_f(dtype_id, i-1, membtype_id, error) 396 CALL check("h5tget_member_type_f", error, total_error) 397 CALL h5tequal_f(membtype_id, dt5_id, flag, error) 398 CALL check("h5tequal_f", error, total_error) 399 if(.not. flag) then 400 write(*,*) "Wrong member type returned for character member" 401 total_error = total_error + 1 402 endif 403 CALL h5tget_member_class_f(dtype_id, i-1, class, error) 404 CALL check("h5tget_member_class_f",error, total_error) 405 if (class .ne. H5T_STRING_F) then 406 write(*,*) "Wrong class returned for character member" 407 total_error = total_error + 1 408 endif 409 CASE("integer_field") 410 if(offset_out .ne. type_sizec) then 411 write(*,*) "Offset of the integer member is incorrect" 412 total_error = total_error + 1 413 endif 414 CALL h5tget_member_type_f(dtype_id, i-1, membtype_id, error) 415 CALL check("h5tget_member_type_f", error, total_error) 416 CALL h5tequal_f(membtype_id, H5T_NATIVE_INTEGER, flag, error) 417 CALL check("h5tequal_f", error, total_error) 418 if(.not. flag) then 419 write(*,*) "Wrong member type returned for integer memebr" 420 total_error = total_error + 1 421 endif 422 CALL h5tget_member_class_f(dtype_id, i-1, class, error) 423 CALL check("h5tget_member_class_f",error, total_error) 424 if (class .ne. H5T_INTEGER_F) then 425 write(*,*) "Wrong class returned for INTEGER member" 426 total_error = total_error + 1 427 endif 428 CASE("double_field") 429 if(offset_out .ne. (type_sizec+type_sizei)) then 430 write(*,*) "Offset of the double precision member is incorrect" 431 total_error = total_error + 1 432 endif 433 CALL h5tget_member_type_f(dtype_id, i-1, membtype_id, error) 434 CALL check("h5tget_member_type_f", error, total_error) 435 CALL h5tequal_f(membtype_id, H5T_NATIVE_DOUBLE, flag, error) 436 CALL check("h5tequal_f", error, total_error) 437 if(.not. flag) then 438 write(*,*) "Wrong member type returned for double precision memebr" 439 total_error = total_error + 1 440 endif 441 CALL h5tget_member_class_f(dtype_id, i-1, class, error) 442 CALL check("h5tget_member_class_f",error, total_error) 443 if (class .ne. H5T_FLOAT_F) then 444 write(*,*) "Wrong class returned for double precision member" 445 total_error = total_error + 1 446 endif 447 CASE("real_field") 448 if(offset_out .ne. (type_sizec+type_sizei+type_sized)) then 449 write(*,*) "Offset of the real member is incorrect" 450 total_error = total_error + 1 451 endif 452 CALL h5tget_member_type_f(dtype_id, i-1, membtype_id, error) 453 CALL check("h5tget_member_type_f", error, total_error) 454 CALL h5tequal_f(membtype_id, H5T_NATIVE_REAL, flag, error) 455 CALL check("h5tequal_f", error, total_error) 456 if(.not. flag) then 457 write(*,*) "Wrong member type returned for real memebr" 458 total_error = total_error + 1 459 endif 460 CALL h5tget_member_class_f(dtype_id, i-1, class, error) 461 CALL check("h5tget_member_class_f",error, total_error) 462 if (class .ne. H5T_FLOAT_F) then 463 write(*,*) "Wrong class returned for real member" 464 total_error = total_error + 1 465 endif 466 CASE DEFAULT 467 write(*,*) "Wrong member's name" 468 total_error = total_error + 1 469 470 END SELECT CHECK_NAME 471 472 enddo 473 ! 474 ! Create memory datatype to read character member of the compound datatype. 475 ! 476 CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt2_id, error) 477 CALL check("h5tcopy_f", error, total_error) 478 sizechar = 2 479 CALL h5tset_size_f(dt2_id, sizechar, error) 480 CALL check("h5tset_size_f", error, total_error) 481 CALL h5tget_size_f(dt2_id, type_size, error) 482 CALL check("h5tget_size_f", error, total_error) 483 CALL h5tcreate_f(H5T_COMPOUND_F, type_size, dt1_id, error) 484 CALL check("h5tcreate_f", error, total_error) 485 offset = 0 486 CALL h5tinsert_f(dt1_id, "char_field", offset, dt2_id, error) 487 CALL check("h5tinsert_f", error, total_error) 488 ! 489 ! Read part of the dataset 490 ! 491 CALL h5dread_f(dset_id, dt1_id, char_member_out, data_dims, error, H5S_ALL_F, H5S_ALL_F, H5P_DEFAULT_F) 492 CALL check("h5dread_f", error, total_error) 493 do i = 1, dimsize 494 if (char_member_out(i) .ne. char_member(i)) then 495 write(*,*) " Wrong character data is read back " 496 total_error = total_error + 1 497 endif 498 enddo 499 ! 500 CALL h5tcreate_f(H5T_COMPOUND_F, type_sizei, dt5_id, error) 501 CALL check("h5tcreate_f", error, total_error) 502 offset = 0 503 CALL h5tinsert_f(dt5_id, "integer_field", offset, H5T_NATIVE_INTEGER, error) 504 CALL check("h5tinsert_f", error, total_error) 505 ! 506 ! Read part of the dataset 507 ! 508 CALL h5dread_f(dset_id, dt5_id, int_member_out, data_dims, error) 509 CALL check("h5dread_f", error, total_error) 510 do i = 1, dimsize 511 if (int_member_out(i) .ne. int_member(i)) then 512 write(*,*) " Wrong integer data is read back " 513 total_error = total_error + 1 514 endif 515 enddo 516 ! 517 ! 518 CALL h5tcreate_f(H5T_COMPOUND_F, type_sized, dt3_id, error) 519 CALL check("h5tcreate_f", error, total_error) 520 offset = 0 521 CALL h5tinsert_f(dt3_id, "double_field", offset, H5T_NATIVE_DOUBLE, error) 522 CALL check("h5tinsert_f", error, total_error) 523 ! 524 ! Read part of the dataset 525 ! 526 CALL h5dread_f(dset_id, dt3_id, double_member_out, data_dims, error) 527 CALL check("h5dread_f", error, total_error) 528 DO i = 1, dimsize 529 CALL VERIFY("h5dread_f:Wrong double precision data is read back", double_member_out(i), double_member(i), total_error) 530 ENDDO 531 ! 532 ! 533 CALL h5tcreate_f(H5T_COMPOUND_F, type_sizer, dt4_id, error) 534 CALL check("h5tcreate_f", error, total_error) 535 offset = 0 536 CALL h5tinsert_f(dt4_id, "real_field", offset, H5T_NATIVE_REAL, error) 537 CALL check("h5tinsert_f", error, total_error) 538 ! 539 ! Read part of the dataset 540 ! 541 CALL h5dread_f(dset_id, dt4_id, real_member_out, data_dims, error) 542 CALL check("h5dread_f", error, total_error) 543 DO i = 1, dimsize 544 CALL VERIFY("h5dread_f:Wrong double precision data is read back", real_member_out(i), real_member(i), total_error) 545 ENDDO 546 ! 547 ! *----------------------------------------------------------------------- 548 ! * Test encoding and decoding compound datatypes 549 ! *----------------------------------------------------------------------- 550 ! 551 ! Encode compound type in a buffer 552 ! -- First find the buffer size 553 554 CALL H5Tencode_f(dtype_id, cmpd_buf, cmpd_buf_size, error) 555 CALL check("H5Tencode_f", error, total_error) 556 557 ! Try decoding bogus buffer 558 559 CALL H5Tdecode_f(cmpd_buf, decoded_tid1, error) 560 CALL verify("H5Tdecode_f", error, -1, total_error) 561 562 CALL H5Tencode_f(dtype_id, cmpd_buf, cmpd_buf_size, error) 563 CALL check("H5Tencode_f", error, total_error) 564 565 ! Decode from the compound buffer and return an object handle 566 CALL H5Tdecode_f(cmpd_buf, decoded_tid1, error) 567 CALL check("H5Tdecode_f", error, total_error) 568 569 ! Verify that the datatype was copied exactly 570 571 CALL H5Tequal_f(decoded_tid1, dtype_id, flag, error) 572 CALL check("H5Tequal_f", error, total_error) 573 CALL verify("H5Tequal_f", flag, .TRUE., total_error) 574 ! 575 ! Close all open objects. 576 ! 577 CALL h5dclose_f(dset_id, error) 578 CALL check("h5dclose_f", error, total_error) 579 CALL h5tclose_f(dt1_id, error) 580 CALL check("h5tclose_f", error, total_error) 581 CALL h5tclose_f(dt2_id, error) 582 CALL check("h5tclose_f", error, total_error) 583 CALL h5tclose_f(dt3_id, error) 584 CALL check("h5tclose_f", error, total_error) 585 CALL h5tclose_f(dt4_id, error) 586 CALL check("h5tclose_f", error, total_error) 587 CALL h5tclose_f(dt5_id, error) 588 CALL check("h5tclose_f", error, total_error) 589 CALL h5fclose_f(file_id, error) 590 CALL check("h5fclose_f", error, total_error) 591 592 IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) 593 CALL check("h5_cleanup_f", error, total_error) 594 RETURN 595 END SUBROUTINE compoundtest 596 597 598 599 600 SUBROUTINE basic_data_type_test(total_error) 601 602! This subroutine tests following functionalities: 603! H5tget_precision_f, H5tset_precision_f, H5tget_offset_f 604! H5tset_offset_f, H5tget_pad_f, H5tset_pad_f, H5tget_sign_f, 605! H5tset_sign_f, H5tget_ebias_f,H5tset_ebias_f, H5tget_norm_f, 606! H5tset_norm_f, H5tget_inpad_f, H5tset_inpad_f, H5tget_cset_f, 607! H5tset_cset_f, H5tget_strpad_f, H5tset_strpad_f 608 609 IMPLICIT NONE 610 INTEGER, INTENT(OUT) :: total_error 611 612 INTEGER(HID_T) :: dtype1_id, dtype2_id, dtype3_id, dtype4_id, dtype5_id 613 ! datatype identifiers 614 INTEGER(SIZE_T) :: precision ! Datatype precision 615 INTEGER(SIZE_T) :: setprecision ! Datatype precision 616 INTEGER(SIZE_T) :: offset ! Datatype offset 617 INTEGER(SIZE_T) :: setoffset ! Datatype offset 618 INTEGER :: lsbpad !padding type of the least significant bit 619 INTEGER :: msbpad !padding type of the most significant bit 620 INTEGER :: sign !sign type for an integer type 621 INTEGER(SIZE_T) :: ebias1 !Datatype exponent bias of a floating-point type 622 INTEGER(SIZE_T) :: ebias2 !Datatype exponent bias of a floating-point type 623 INTEGER(SIZE_T) :: setebias 624 INTEGER :: norm !mantissa normalization of a floating-point datatype 625 INTEGER :: inpad !padding type for unused bits in floating-point datatypes. 626 INTEGER :: cset !character set type of a string datatype 627 INTEGER :: strpad !string padding method for a string datatype 628 INTEGER :: error !error flag 629 630 631 ! 632 ! Create a datatype 633 ! 634 CALL h5tcopy_f(H5T_STD_U16BE, dtype1_id, error) 635 CALL check("h5tcopy_f",error,total_error) 636 ! 637 !datatype type_id should be modifiable after h5tcopy_f 638 ! 639 setprecision = 12 640 CALL h5tset_precision_f(dtype1_id, setprecision, error) 641 CALL check("h5set_precision_f",error,total_error) 642 CALL h5tget_precision_f(dtype1_id,precision, error) 643 CALL check("h5get_precision_f",error,total_error) 644 if(precision .ne. 12) then 645 write (*,*) "got precision is not correct" 646 total_error = total_error + 1 647 end if 648 649 CALL h5tcopy_f(H5T_STD_I32LE, dtype2_id, error) 650 CALL check("h5tcopy_f",error,total_error) 651 setprecision = 12 652 CALL h5tset_precision_f(dtype2_id, setprecision, error) 653 CALL check("h5set_precision_f",error,total_error) 654 655 setoffset = 2 656 CALL h5tset_offset_f(dtype1_id, setoffset, error) 657 CALL check("h5set_offset_f",error,total_error) 658 setoffset = 10 659 CALL h5tset_offset_f(dtype2_id, setoffset, error) 660 CALL check("h5set_offset_f",error,total_error) 661 CALL h5tget_offset_f(dtype2_id,offset, error) 662 CALL check("h5get_offset_f",error,total_error) 663 if(offset .ne. 10) then 664 write (*,*) "got offset is not correct" 665 total_error = total_error + 1 666 end if 667 668 CALL h5tset_pad_f(dtype2_id,H5T_PAD_ONE_F, H5T_PAD_ONE_F, error) 669 CALL check("h5set_pad_f",error,total_error) 670 CALL h5tget_pad_f(dtype2_id,lsbpad,msbpad, error) 671 CALL check("h5get_pad_f",error,total_error) 672 if((lsbpad .ne. H5T_PAD_ONE_F) .and. (msbpad .ne. H5T_PAD_ONE_F)) then 673 write (*,*) "got pad is not correct" 674 total_error = total_error + 1 675 end if 676 677! CALL h5tset_sign_f(dtype2_id,H5T_SGN_2_F, error) 678! CALL check("h5set_sign_f",error,total_error) 679! CALL h5tget_sign_f(dtype2_id,sign, error) 680 CALL h5tget_sign_f(H5T_NATIVE_INTEGER, sign, error) 681 CALL check("h5tget_sign_f",error,total_error) 682 if(sign .ne. H5T_SGN_2_F ) then 683 write (*,*) "got sign is not correct" 684 total_error = total_error + 1 685 end if 686 687 CALL h5tcopy_f(H5T_IEEE_F64BE, dtype3_id, error) 688 CALL check("h5tcopy_f",error,total_error) 689 CALL h5tcopy_f(H5T_IEEE_F32LE, dtype4_id, error) 690 CALL check("h5tcopy_f",error,total_error) 691 692 setebias = 257 693 CALL h5tset_ebias_f(dtype3_id, setebias, error) 694 CALL check("h5tset_ebias_f",error,total_error) 695 setebias = 1 696 CALL h5tset_ebias_f(dtype4_id, setebias, error) 697 CALL check("h5tset_ebias_f",error,total_error) 698 CALL h5tget_ebias_f(dtype3_id, ebias1, error) 699 CALL check("h5tget_ebias_f",error,total_error) 700 if(ebias1 .ne. 257 ) then 701 write (*,*) "got ebias is not correct" 702 total_error = total_error + 1 703 end if 704 CALL h5tget_ebias_f(dtype4_id, ebias2, error) 705 CALL check("h5tget_ebias_f",error,total_error) 706 if(ebias2 .ne. 1 ) then 707 write (*,*) "got ebias is not correct" 708 total_error = total_error + 1 709 end if 710 711 !attention: 712 !It seems that I can't use H5T_NORM_IMPLIED_F to set the norm value 713 !because I got error for the get_norm function 714! CALL h5tset_norm_f(dtype3_id,H5T_NORM_IMPLIED_F , error) 715! CALL check("h5tset_norm_f",error,total_error) 716! CALL h5tget_norm_f(dtype3_id, norm, error) 717! CALL check("h5tget_norm_f",error,total_error) 718! if(norm .ne. H5T_NORM_IMPLIED_F ) then 719! write (*,*) "got norm is not correct" 720! total_error = total_error + 1 721! end if 722 CALL h5tset_norm_f(dtype3_id, H5T_NORM_MSBSET_F , error) 723 CALL check("h5tset_norm_f",error,total_error) 724 CALL h5tget_norm_f(dtype3_id, norm, error) 725 CALL check("h5tget_norm_f",error,total_error) 726 if(norm .ne. H5T_NORM_MSBSET_F ) then 727 write (*,*) "got norm is not correct" 728 total_error = total_error + 1 729 end if 730 731 CALL h5tset_norm_f(dtype3_id, H5T_NORM_NONE_F , error) 732 CALL check("h5tset_norm_f",error,total_error) 733 CALL h5tget_norm_f(dtype3_id, norm, error) 734 CALL check("h5tget_norm_f",error,total_error) 735 if(norm .ne. H5T_NORM_NONE_F ) then 736 write (*,*) "got norm is not correct" 737 total_error = total_error + 1 738 end if 739 740 CALL h5tset_inpad_f(dtype3_id, H5T_PAD_ZERO_F , error) 741 CALL check("h5tset_inpad_f",error,total_error) 742 CALL h5tget_inpad_f(dtype3_id, inpad , error) 743 CALL check("h5tget_inpad_f",error,total_error) 744 if(inpad .ne. H5T_PAD_ZERO_F ) then 745 write (*,*) "got inpad is not correct" 746 total_error = total_error + 1 747 end if 748 749 CALL h5tset_inpad_f(dtype3_id,H5T_PAD_ONE_F , error) 750 CALL check("h5tset_inpad_f",error,total_error) 751 CALL h5tget_inpad_f(dtype3_id, inpad , error) 752 CALL check("h5tget_inpad_f",error,total_error) 753 if(inpad .ne. H5T_PAD_ONE_F ) then 754 write (*,*) "got inpad is not correct" 755 total_error = total_error + 1 756 end if 757 758 CALL h5tset_inpad_f(dtype3_id,H5T_PAD_BACKGROUND_F , error) 759 CALL check("h5tset_inpad_f",error,total_error) 760 CALL h5tget_inpad_f(dtype3_id, inpad , error) 761 CALL check("h5tget_inpad_f",error,total_error) 762 if(inpad .ne. H5T_PAD_BACKGROUND_F ) then 763 write (*,*) "got inpad is not correct" 764 total_error = total_error + 1 765 end if 766 767! we should not apply h5tset_cset_f to non_character data typemake 768 769! CALL h5tset_cset_f(dtype4_id, H5T_CSET_ASCII_F, error) 770! CALL check("h5tset_cset_f",error,total_error) 771! CALL h5tget_cset_f(dtype4_id, cset, error) 772! CALL check("h5tget_cset_f",error,total_error) 773! if(cset .ne. H5T_CSET_ASCII_F ) then 774! write (*,*) "got cset is not correct" 775! total_error = total_error + 1 776! end if 777 778 CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dtype5_id, error) 779 CALL check("h5tcopy_f",error,total_error) 780 CALL h5tset_cset_f(dtype5_id, H5T_CSET_ASCII_F, error) 781 CALL check("h5tset_cset_f",error,total_error) 782 CALL h5tget_cset_f(dtype5_id, cset, error) 783 CALL check("h5tget_cset_f",error,total_error) 784 if(cset .ne. H5T_CSET_ASCII_F ) then 785 write (*,*) "got cset is not correct" 786 total_error = total_error + 1 787 end if 788 CALL h5tset_strpad_f(dtype5_id, H5T_STR_NULLPAD_F, error) 789 CALL check("h5tset_strpad_f",error,total_error) 790 CALL h5tget_strpad_f(dtype5_id, strpad, error) 791 CALL check("h5tget_strpad_f",error,total_error) 792 if(strpad .ne. H5T_STR_NULLPAD_F ) then 793 write (*,*) "got strpad is not correct" 794 total_error = total_error + 1 795 end if 796 797 CALL h5tset_strpad_f(dtype5_id, H5T_STR_SPACEPAD_F, error) 798 CALL check("h5tset_strpad_f",error,total_error) 799 CALL h5tget_strpad_f(dtype5_id, strpad, error) 800 CALL check("h5tget_strpad_f",error,total_error) 801 if(strpad .ne. H5T_STR_SPACEPAD_F ) then 802 write (*,*) "got strpad is not correct" 803 total_error = total_error + 1 804 end if 805 806 CALL h5tclose_f(dtype1_id, error) 807 CALL check("h5tclose_f", error, total_error) 808 CALL h5tclose_f(dtype2_id, error) 809 CALL check("h5tclose_f", error, total_error) 810 CALL h5tclose_f(dtype3_id, error) 811 CALL check("h5tclose_f", error, total_error) 812 CALL h5tclose_f(dtype4_id, error) 813 CALL check("h5tclose_f", error, total_error) 814 CALL h5tclose_f(dtype5_id, error) 815 CALL check("h5tclose_f", error, total_error) 816 817 818 RETURN 819 END SUBROUTINE basic_data_type_test 820 821 SUBROUTINE enumtest(cleanup, total_error) 822 823 USE HDF5 824 USE TH5_MISC 825 IMPLICIT NONE 826 827 LOGICAL, INTENT(IN) :: cleanup 828 INTEGER, INTENT(OUT) :: total_error 829 CHARACTER(LEN=4), PARAMETER :: filename="enum" 830 CHARACTER(LEN=80) :: fix_filename 831 CHARACTER(LEN=8), PARAMETER :: dsetname="enumdset" 832 CHARACTER(LEN=4) :: true ="TRUE" 833 CHARACTER(LEN=5) :: false="FALSE" 834 CHARACTER(LEN=5) :: mem_name 835 836 INTEGER(HID_T) :: file_id 837 INTEGER(HID_T) :: dset_id 838 INTEGER(HID_T) :: dspace_id 839 INTEGER(HID_T) :: dtype_id, dtype, native_type 840 INTEGER :: error 841 INTEGER :: value 842 INTEGER(HSIZE_T), DIMENSION(1) :: dsize 843 INTEGER(SIZE_T) :: buf_size 844 INTEGER, DIMENSION(2) :: data 845 INTEGER(HSIZE_T), DIMENSION(7) :: dims 846 INTEGER :: order1, order2 847! INTEGER(SIZE_T) :: type_size1, type_size2 848 INTEGER :: class 849 850 dims(1) = 2 851 dsize(1) = 2 852 data(1) = 1 853 data(2) = 0 854 ! 855 ! Create a new file using default properties. 856 ! 857 CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) 858 IF (error .NE. 0) THEN 859 WRITE(*,*) "Cannot modify filename" 860 STOP 861 ENDIF 862 CALL h5fcreate_f(fix_filename,H5F_ACC_TRUNC_F,file_id,error) 863 CALL check("h5fcreate_f", error, total_error) 864 ! 865 ! Create enumeration datatype with tow values 866 ! 867 CALL h5tenum_create_f(H5T_NATIVE_INTEGER,dtype_id,error) 868 CALL check("h5tenum_create_f", error, total_error) 869 CALL h5tenum_insert_f(dtype_id,true,DATA(1),error) 870 CALL check("h5tenum_insert_f", error, total_error) 871 CALL h5tenum_insert_f(dtype_id,false,DATA(2),error) 872 CALL check("h5tenum_insert_f", error, total_error) 873 ! 874 ! Create write and close a dataset with enum datatype 875 ! 876 CALL h5screate_simple_f(1,dsize,dspace_id,error) 877 CALL check("h5screate_simple_f", error, total_error) 878 CALL h5dcreate_f(file_id,dsetname,dtype_id,dspace_id,dset_id,error) 879 CALL check("h5dcreate_f", error, total_error) 880 CALL h5dwrite_f(dset_id,dtype_id,DATA,dims,error) 881 CALL check("h5dwrite_f", error, total_error) 882 883 CALL H5Dget_type_f(dset_id, dtype, error) 884 CALL check("H5Dget_type_f", error, total_error) 885 886 CALL H5Tget_native_type_f(dtype, H5T_DIR_ASCEND_F, native_type, error) 887 CALL check("H5Tget_native_type_f",error, total_error) 888 889 ! Verify the datatype retrieved and converted 890 CALL H5Tget_order_f(native_type, order1, error) 891 CALL check("H5Tget_order_f",error, total_error) 892 CALL H5Tget_order_f(H5T_NATIVE_INTEGER, order2, error) 893 CALL check("H5Tget_order_f",error, total_error) 894 CALL verify("H5Tget_native_type_f",order1, order2, total_error) 895 896 ! this test depends on whether -i8 was specified 897 898!!$ CALL H5Tget_size_f(native_type, type_size1, error) 899!!$ CALL check("H5Tget_size_f",error, total_error) 900!!$ CALL H5Tget_size_f(H5T_STD_I32BE, type_size2, error) 901!!$ CALL check("H5Tget_size_f",error, total_error) 902!!$ CALL verify("H5Tget_native_type_f", INT(type_size1), INT(type_size2), total_error) 903 904 CALL H5Tget_class_f(native_type, class, error) 905 CALL check("H5Tget_class_f",error, total_error) 906 CALL verify("H5Tget_native_type_f", INT(class), INT(H5T_ENUM_F), total_error) 907 908 CALL h5dclose_f(dset_id,error) 909 CALL check("h5dclose_f", error, total_error) 910 CALL h5sclose_f(dspace_id,error) 911 CALL check("h5sclose_f", error, total_error) 912 ! 913 ! Get value of "TRUE" 914 ! 915 CALL h5tenum_valueof_f(dtype_id, "TRUE", value, error) 916 CALL check("h5tenum_valueof_f", error, total_error) 917 IF (value .NE. 1) THEN 918 WRITE(*,*) " Value of TRUE is not 1, error" 919 total_error = total_error + 1 920 ENDIF 921 ! 922 ! Get name of 0 923 ! 924 value = 0 925 buf_size = 5 926 CALL h5tenum_nameof_f(dtype_id, value, buf_size, mem_name, error) 927 CALL check("h5tenum_nameof_f", error, total_error) 928 IF (mem_name .NE. "FALSE") THEN 929 WRITE(*,*) " Wrong name for 0 value" 930 total_error = total_error + 1 931 ENDIF 932 933 CALL h5tclose_f(dtype_id,error) 934 CALL check("h5tclose_f", error, total_error) 935 CALL h5fclose_f(file_id,error) 936 CALL check("h5fclose_f", error, total_error) 937 938 IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) 939 CALL check("h5_cleanup_f", error, total_error) 940 941 RETURN 942 END SUBROUTINE enumtest 943 944!------------------------------------------------------------------------- 945! * Function: test_derived_flt 946! * 947! * Purpose: Tests user-define and query functions of floating-point types. 948! * test h5tget/set_fields_f. 949! * 950! * Return: Success: 0 951! * 952! * Failure: number of errors 953! * 954! * Fortran Programmer: M.S. Breitenfeld 955! * September 9, 2008 956! * 957! * Modifications: 958! * 959! *------------------------------------------------------------------------- 960! 961 962SUBROUTINE test_derived_flt(cleanup, total_error) 963 964 965 IMPLICIT NONE 966 LOGICAL, INTENT(IN) :: cleanup 967 INTEGER, INTENT(OUT) :: total_error 968 INTEGER(hid_t) :: file=-1, tid1=-1, tid2=-1 969 INTEGER(hid_t) :: dxpl_id=-1 970 INTEGER(size_t) :: spos, epos, esize, mpos, msize 971 972 CHARACTER(LEN=15), PARAMETER :: filename="h5t_derived_flt" 973 CHARACTER(LEN=80) :: fix_filename 974 975 INTEGER(SIZE_T) :: precision1, offset1, ebias1, size1 976 INTEGER(SIZE_T) :: precision2, offset2, ebias2, size2 977 978 INTEGER :: error 979 980 ! Create File 981 CALL h5_fixname_f(filename, fix_filename, H5P_DEFAULT_F, error) 982 IF (error .NE. 0) THEN 983 WRITE(*,*) "Cannot modify filename" 984 STOP 985 ENDIF 986 987 CALL h5fcreate_f(fix_filename,H5F_ACC_TRUNC_F,file,error) 988 CALL check("h5fcreate_f", error, total_error) 989 990 CALL h5pcreate_f(H5P_DATASET_XFER_F, dxpl_id, error) 991 CALL check("h5pcreate_f", error, total_error) 992 993 CALL h5tcopy_f(H5T_IEEE_F64LE, tid1, error) 994 CALL check("h5tcopy_f",error,total_error) 995 996 CALL h5tcopy_f(H5T_IEEE_F32LE, tid2, error) 997 CALL check("h5tcopy_f",error,total_error) 998 999 !------------------------------------------------------------------------ 1000 ! * 1st floating-point type 1001 ! * size=7 byte, precision=42 bits, offset=3 bits, mantissa size=31 bits, 1002 ! * mantissa position=3, exponent size=10 bits, exponent position=34, 1003 ! * exponent bias=511. It can be illustrated in little-endian order as 1004 ! * 1005 ! * 6 5 4 3 2 1 0 1006 ! * ???????? ???SEEEE EEEEEEMM MMMMMMMM MMMMMMMM MMMMMMMM MMMMM??? 1007 ! * 1008 ! * To create a new floating-point type, the following properties must be 1009 ! * set in the order of 1010 ! * set fields -> set offset -> set precision -> set size. 1011 ! * All these properties must be set before the type can function. Other 1012 ! * properties can be set anytime. Derived type size cannot be expanded 1013 ! * bigger than original size but can be decreased. There should be no 1014 ! * holes among the significant bits. Exponent bias usually is set 1015 ! * 2^(n-1)-1, where n is the exponent size. 1016 ! *----------------------------------------------------------------------- 1017 1018 CALL H5Tset_fields_f(tid1, INT(44,size_t), INT(34,size_t), INT(10,size_t), & 1019 INT(3,size_t), INT(31,size_t), error) 1020 CALL check("H5Tset_fields_f",error,total_error) 1021 1022 CALL H5Tset_offset_f(tid1, INT(3,size_t), error) 1023 CALL check("H5Tset_offset_f",error,total_error) 1024 1025 CALL H5Tset_precision_f(tid1, INT(42,size_t), error) 1026 CALL check("H5Tset_precision_f",error,total_error) 1027 1028 CALL H5Tset_size_f(tid1, INT(7,size_t), error) 1029 CALL check("H5Tset_size_f",error,total_error) 1030 1031 CALL H5Tset_ebias_f(tid1, INT(511,size_t), error) 1032 CALL check("H5Tset_ebias_f",error,total_error) 1033 1034 CALL H5Tset_pad_f(tid1, H5T_PAD_ZERO_F, H5T_PAD_ZERO_F, error) 1035 CALL check("H5Tset_pad_f",error,total_error) 1036 1037 CALL h5tcommit_f(file, "new float type 1", tid1, error) 1038 CALL check("h5tcommit_f", error, total_error) 1039 1040 CALL h5tclose_f(tid1, error) 1041 CALL check("h5tclose_f", error, total_error) 1042 1043 CALL H5Topen_f(file, "new float type 1", tid1, error) 1044 CALL check("H5Topen_f", error, total_error) 1045 1046 CALL H5Tget_fields_f(tid1, spos, epos, esize, mpos, msize, error) 1047 CALL check("H5Tget_fields_f", error, total_error) 1048 1049 IF(spos.NE.44 .OR. epos.NE.34 .OR. esize.NE.10 .OR. mpos.NE.3 .OR. msize.NE.31)THEN 1050 CALL verify("H5Tget_fields_f", -1, 0, total_error) 1051 ENDIF 1052 1053 CALL H5Tget_precision_f(tid1, precision1, error) 1054 CALL check("H5Tget_precision_f", error, total_error) 1055 CALL verify("H5Tget_precision_f", INT(precision1), 42, total_error) 1056 1057 CALL H5Tget_offset_f(tid1, offset1, error) 1058 CALL check("H5Tget_offset_f", error, total_error) 1059 CALL verify("H5Tget_offset_f", INT(offset1), 3, total_error) 1060 1061 CALL H5Tget_size_f(tid1, size1, error) 1062 CALL check("H5Tget_size_f", error, total_error) 1063 CALL verify("H5Tget_size_f", INT(size1), 7, total_error) 1064 1065 CALL H5Tget_ebias_f(tid1, ebias1, error) 1066 CALL check("H5Tget_ebias_f", error, total_error) 1067 CALL verify("H5Tget_ebias_f", INT(ebias1), 511, total_error) 1068 1069 !-------------------------------------------------------------------------- 1070 ! * 2nd floating-point type 1071 ! * size=3 byte, precision=24 bits, offset=0 bits, mantissa size=16 bits, 1072 ! * mantissa position=0, exponent size=7 bits, exponent position=16, exponent 1073 ! * bias=63. It can be illustrated in little-endian order as 1074 ! * 1075 ! * 2 1 0 1076 ! * SEEEEEEE MMMMMMMM MMMMMMMM 1077 ! *-------------------------------------------------------------------------- 1078 1079 CALL H5Tset_fields_f(tid2, INT(23,size_t), INT(16,size_t), INT(7,size_t), & 1080 INT(0,size_t), INT(16,size_t), error) 1081 CALL check("H5Tset_fields_f",error,total_error) 1082 1083 CALL H5Tset_offset_f(tid2, INT(0,size_t), error) 1084 CALL check("H5Tset_offset_f",error,total_error) 1085 1086 CALL H5Tset_precision_f(tid2, INT(24,size_t), error) 1087 CALL check("H5Tset_precision_f",error,total_error) 1088 1089 CALL H5Tset_size_f(tid2, INT(3,size_t), error) 1090 CALL check("H5Tset_size_f",error,total_error) 1091 1092 CALL H5Tset_ebias_f(tid2, INT(63,size_t), error) 1093 CALL check("H5Tset_ebias_f",error,total_error) 1094 1095 CALL H5Tset_pad_f(tid2, H5T_PAD_ZERO_F, H5T_PAD_ZERO_F, error) 1096 CALL check("H5Tset_pad_f",error,total_error) 1097 1098 CALL h5tcommit_f(file, "new float type 2", tid2, error) 1099 CALL check("h5tcommit_f", error, total_error) 1100 1101 CALL h5tclose_f(tid2, error) 1102 CALL check("h5tclose_f", error, total_error) 1103 1104 CALL H5Topen_f(file, "new float type 2", tid2, error) 1105 CALL check("H5Topen_f", error, total_error) 1106 1107 CALL H5Tget_fields_f(tid2, spos, epos, esize, mpos, msize, error) 1108 CALL check("H5Tget_fields_f", error, total_error) 1109 1110 IF(spos.NE.23 .OR. epos.NE.16 .OR. esize.NE.7 .OR. mpos.NE.0 .OR. msize.NE.16)THEN 1111 CALL verify("H5Tget_fields_f", -1, 0, total_error) 1112 ENDIF 1113 1114 CALL H5Tget_precision_f(tid2, precision2, error) 1115 CALL check("H5Tget_precision_f", error, total_error) 1116 CALL verify("H5Tget_precision_f", INT(precision2), 24, total_error) 1117 1118 CALL H5Tget_offset_f(tid2, offset2, error) 1119 CALL check("H5Tget_offset_f", error, total_error) 1120 CALL verify("H5Tget_offset_f", INT(offset2), 0, total_error) 1121 1122 CALL H5Tget_size_f(tid2, size2, error) 1123 CALL check("H5Tget_size_f", error, total_error) 1124 CALL verify("H5Tget_size_f", INT(size2), 3, total_error) 1125 1126 CALL H5Tget_ebias_f(tid2, ebias2, error) 1127 CALL check("H5Tget_ebias_f", error, total_error) 1128 CALL verify("H5Tget_ebias_f", INT(ebias2), 63, total_error) 1129 1130 CALL h5tclose_f(tid1, error) 1131 CALL check("h5tclose_f", error, total_error) 1132 1133 CALL h5tclose_f(tid2, error) 1134 CALL check("h5tclose_f", error, total_error) 1135 1136 CALL H5Pclose_f(dxpl_id, error) 1137 CALL check("H5Pclose_f", error, total_error) 1138 1139 CALL h5fclose_f(file,error) 1140 CALL check("h5fclose_f", error, total_error) 1141 1142 IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error) 1143 CALL check("h5_cleanup_f", error, total_error) 1144 1145END SUBROUTINE test_derived_flt 1146 1147END MODULE TH5T 1148