1!****h* root/fortran/test/tH5G_1_8.f90 2! 3! NAME 4! tH5G_1_8.f90 5! 6! FUNCTION 7! Basic testing of Fortran H5G APIs introduced in 1.8. 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! group_test, group_info, timestamps, mklinks, test_move_preserves, lifecycle 25! cklinks, delete_by_idx, link_info_by_idx_check, test_lcpl, objcopy, 26! lapl_nlinks 27! 28!***** 29 30MODULE TH5G_1_8 31 32CONTAINS 33 34SUBROUTINE group_test(cleanup, total_error) 35 USE HDF5 ! This module contains all necessary modules 36 USE TH5_MISC 37 38 IMPLICIT NONE 39 LOGICAL, INTENT(IN) :: cleanup 40 INTEGER, INTENT(INOUT) :: total_error 41 42 INTEGER(HID_T) :: fapl, fapl2, my_fapl ! File access property lists 43 44 INTEGER :: error, ret_total_error 45 46! WRITE(*,*) "TESTING GROUPS" 47 CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl, error) 48 CALL check("H5Pcreate_f",error, total_error) 49 50 ! Copy the file access property list 51 CALL H5Pcopy_f(fapl, fapl2, error) 52 CALL check("H5Pcopy_f",error, total_error) 53 54 ! Set the "use the latest version of the format" bounds for creating objects in the file 55 CALL H5Pset_libver_bounds_f(fapl2, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error) 56 CALL check("H5Pset_libver_bounds_f",error, total_error) 57 58 ! Check for FAPL to USE 59 my_fapl = fapl2 60 61 ret_total_error = 0 62 CALL mklinks(fapl2, ret_total_error) 63 CALL write_test_status(ret_total_error, & 64 ' Testing building a file with assorted links', & 65 total_error) 66 67 ret_total_error = 0 68 CALL cklinks(fapl2, ret_total_error) 69 CALL write_test_status(ret_total_error, & 70 ' Testing links are correct and building assorted links', & 71 total_error) 72 73 ret_total_error = 0 74 CALL group_info(cleanup, fapl2, ret_total_error) 75 CALL write_test_status(ret_total_error, & 76 ' Testing create group with creation order indices, test querying group info', & 77 total_error) 78 79! CALL ud_hard_links(fapl2,total_error) 80 ret_total_error = 0 81 CALL timestamps(cleanup, fapl2, ret_total_error) 82 CALL write_test_status(ret_total_error, & 83 ' Testing disabling tracking timestamps for an object', & 84 total_error) 85 86 ret_total_error = 0 87 CALL test_move_preserves(fapl2, ret_total_error) 88 CALL write_test_status(ret_total_error, & 89 ' Testing moving and renaming links preserves their properties', & 90 total_error) 91 92 ret_total_error = 0 93 CALL delete_by_idx(cleanup,fapl2,ret_total_error) 94 CALL write_test_status(ret_total_error, & 95 ' Testing deleting links by index', & 96 total_error) 97 98 ret_total_error = 0 99 CALL test_lcpl(cleanup, fapl, ret_total_error) 100 CALL write_test_status(ret_total_error, & 101 ' Testing link creation property lists', & 102 total_error) 103 104 ret_total_error = 0 105 CALL objcopy(fapl, ret_total_error) 106 CALL write_test_status(ret_total_error, & 107 ' Testing object copy', & 108 total_error) 109 110 ret_total_error = 0 111 CALL lifecycle(cleanup, fapl2, ret_total_error) 112 CALL write_test_status(ret_total_error, & 113 ' Testing adding links to a group follow proper "lifecycle"', & 114 total_error) 115 116 IF(cleanup) CALL h5_cleanup_f("TestLinks", H5P_DEFAULT_F, error) 117 CALL check("h5_cleanup_f", error, total_error) 118 119 120END SUBROUTINE group_test 121 122!------------------------------------------------------------------------- 123! * Function: group_info 124! * 125! * Purpose: Create a group with creation order indices and test querying 126! * group info. 127! * 128! * Return: Success: 0 129! * Failure: -1 130! * 131! * Programmer: Adapted from C test routines by 132! * M.S. Breitenfeld 133! * February 18, 2008 134! * 135! *------------------------------------------------------------------------- 136! 137 138SUBROUTINE group_info(cleanup, fapl, total_error) 139 140 USE HDF5 ! This module contains all necessary modules 141 USE TH5_MISC 142 143 IMPLICIT NONE 144 INTEGER, INTENT(INOUT) :: total_error 145 INTEGER(HID_T), INTENT(IN) :: fapl 146 147 INTEGER(HID_T) :: gcpl_id ! Group creation property list ID 148 149 INTEGER :: max_compact ! Maximum # of links to store in group compactly 150 INTEGER :: min_dense ! Minimum # of links to store in group "densely" 151 152 INTEGER :: idx_type ! Type of index to operate on 153 INTEGER :: order, iorder ! Order within in the index 154 LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) ! Use index on creation order values 155 CHARACTER(LEN=6), PARAMETER :: prefix = 'links0' 156 CHARACTER(LEN=9), PARAMETER :: filename = prefix//'.h5' ! File name 157 INTEGER :: Input1 158 INTEGER(HID_T) :: group_id ! Group ID 159 INTEGER(HID_T) :: soft_group_id ! Group ID for soft links 160 161 INTEGER :: i ! Local index variables 162 INTEGER :: storage_type ! Type of storage for links in group: 163 ! H5G_STORAGE_TYPE_COMPACT: Compact storage 164 ! H5G_STORAGE_TYPE_DENSE: Indexed storage 165 ! H5G_STORAGE_TYPE_SYMBOL_TABLE: Symbol tables, the original HDF5 structure 166 INTEGER :: nlinks ! Number of links in group 167 INTEGER :: max_corder ! Current maximum creation order value for group 168 169 INTEGER :: u,v ! Local index variables 170 CHARACTER(LEN=2) :: chr2 171 INTEGER(HID_T) :: group_id2, group_id3 ! Group IDs 172 CHARACTER(LEN=7) :: objname ! Object name 173 CHARACTER(LEN=7) :: objname2 ! Object name 174 CHARACTER(LEN=19) :: valname ! Link value 175 CHARACTER(LEN=12), PARAMETER :: CORDER_GROUP_NAME = "corder_group" 176 CHARACTER(LEN=17), PARAMETER :: CORDER_SOFT_GROUP_NAME = "corder_soft_group" 177 INTEGER(HID_T) :: file_id ! File ID 178 INTEGER :: error ! Generic return value 179 LOGICAL :: mounted 180 LOGICAL :: cleanup 181 182 ! Create group creation property list 183 CALL H5Pcreate_f(H5P_GROUP_CREATE_F, gcpl_id, error ) 184 CALL check("H5Pcreate_f", error, total_error) 185 186 ! Query the group creation properties 187 CALL H5Pget_link_phase_change_f(gcpl_id, max_compact, min_dense, error) 188 CALL check("H5Pget_link_phase_change_f", error, total_error) 189 190 ! Loop over operating on different indices on link fields 191 DO idx_type = H5_INDEX_NAME_F, H5_INDEX_CRT_ORDER_F 192 ! Loop over operating in different orders 193 DO iorder = H5_ITER_INC_F, H5_ITER_NATIVE_F 194 ! Loop over using index for creation order value 195 DO i = 1, 2 196 ! Print appropriate test message 197 IF(idx_type == H5_INDEX_CRT_ORDER_F)THEN 198 IF(iorder == H5_ITER_INC_F)THEN 199 order = H5_ITER_INC_F 200!!$ IF(use_index(i))THEN 201!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/creation order index" 202!!$ ELSE 203!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/o creation order index" 204!!$ ENDIF 205 ELSE IF (iorder == H5_ITER_DEC_F) THEN 206 order = H5_ITER_DEC_F 207!!$ IF(use_index(i))THEN 208!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/creation order index" 209!!$ ELSE 210!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/o creation order index" 211!!$ ENDIF 212 ELSE 213 order = H5_ITER_NATIVE_F 214!!$ IF(use_index(i))THEN 215!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/creation order index" 216!!$ ELSE 217!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/o creation order index" 218!!$ ENDIF 219 ENDIF 220 ELSE 221 IF(iorder == H5_ITER_INC_F)THEN 222 order = H5_ITER_INC_F 223!!$ IF(use_index(i))THEN 224!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/creation order index" 225!!$ ELSE 226!!$ WRITE(*,'(5x,A)')"query group info by creation order index in increasing order w/o creation order index" 227!!$ ENDIF 228 ELSE IF (iorder == H5_ITER_DEC_F) THEN 229 order = H5_ITER_DEC_F 230!!$ IF(use_index(i))THEN 231!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/creation order index" 232!!$ ELSE 233!!$ WRITE(*,'(5x,A)')"query group info by creation order index in decreasing order w/o creation order index" 234!!$ ENDIF 235 ELSE 236 order = H5_ITER_NATIVE_F 237!!$ IF(use_index(i))THEN 238!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/creation order index" 239!!$ ELSE 240!!$ WRITE(*,'(5x,A)')"query group info by creation order index in native order w/o creation order index" 241!!$ ENDIF 242 ENDIF 243 END IF 244 245 ! Create file 246 CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl) 247 CALL check("H5Fcreate_f", error, total_error) 248 249 ! Set creation order tracking & indexing on group 250 IF(use_index(i))THEN 251 Input1 = H5P_CRT_ORDER_INDEXED_F 252 ELSE 253 Input1 = 0 254 ENDIF 255 CALL H5Pset_link_creation_order_f(gcpl_id, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) 256 CALL check("H5Pset_link_creation_order_f", error, total_error) 257 258 ! Create group with creation order tracking on 259 CALL H5Gcreate_f(file_id, CORDER_GROUP_NAME, group_id, error, gcpl_id=gcpl_id) 260 CALL check("H5Gcreate_f", error, total_error) 261 262 ! Create group with creation order tracking on for soft links 263 CALL H5Gcreate_f(file_id, CORDER_SOFT_GROUP_NAME, soft_group_id, error, & 264 OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, gcpl_id) 265 CALL check("H5Gcreate_f", error, total_error) 266 267 ! Check for out of bound query by index on empty group, should fail 268 CALL H5Gget_info_by_idx_f(group_id, ".", H5_INDEX_NAME_F, order, INT(0,HSIZE_T), & 269 storage_type, nlinks, max_corder, error) 270 CALL VERIFY("H5Gget_info_by_idx_f", error, -1, total_error) 271 272 ! Create several links, up to limit of compact form 273 DO u = 0, max_compact-1 274 275 ! Make name for link 276 WRITE(chr2,'(I2.2)') u 277 objname = 'fill '//chr2 278 279 ! Create hard link, with group object 280 CALL H5Gcreate_f(group_id, objname, group_id2, error, OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, gcpl_id) 281 CALL check("H5Gcreate_f", error, total_error) 282 283 ! Retrieve group's information 284 CALL H5Gget_info_f(group_id2, storage_type, nlinks, max_corder, error, mounted) 285 CALL check("H5Gget_info_f", error, total_error) 286 287 ! Check (new/empty) group's information 288 CALL VERIFY("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) 289 CALL VERIFY("H5Gget_info_f", max_corder, 0, total_error) 290 CALL VERIFY("H5Gget_info_f", nlinks, 0, total_error) 291 CALL verifyLogical("H5Gget_info_f.mounted", mounted,.FALSE.,total_error) 292 293 ! Retrieve group's information 294 CALL H5Gget_info_by_name_f(group_id, objname, storage_type, nlinks, max_corder, error, mounted=mounted) 295 CALL check("H5Gget_info_by_name_f", error, total_error) 296 297 ! Check (new/empty) group's information 298 CALL VERIFY("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) 299 CALL VERIFY("H5Gget_info_by_name_f", max_corder, 0, total_error) 300 CALL VERIFY("H5Gget_info_by_name_f", nlinks, 0, total_error) 301 CALL verifyLogical("H5Gget_info_by_name_f.mounted", mounted,.FALSE.,total_error) 302 303 ! Retrieve group's information 304 CALL H5Gget_info_by_name_f(group_id2, ".", storage_type, nlinks, max_corder, error) 305 CALL check("H5Gget_info_by_name", error, total_error) 306 307 ! Check (new/empty) group's information 308 CALL VERIFY("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) 309 CALL VERIFY("H5Gget_info_by_name_f", max_corder, 0, total_error) 310 CALL VERIFY("H5Gget_info_by_name_f", nlinks, 0, total_error) 311 312 ! Create objects in new group created 313 DO v = 0, u 314 ! Make name for link 315 WRITE(chr2,'(I2.2)') v 316 objname2 = 'fill '//chr2 317 318 ! Create hard link, with group object 319 CALL H5Gcreate_f(group_id2, objname2, group_id3, error ) 320 CALL check("H5Gcreate_f", error, total_error) 321 322 ! Close group created 323 CALL H5Gclose_f(group_id3, error) 324 CALL check("H5Gclose_f", error, total_error) 325 ENDDO 326 327 ! Retrieve group's information 328 CALL H5Gget_info_f(group_id2, storage_type, nlinks, max_corder, error) 329 CALL check("H5Gget_info_f", error, total_error) 330 331 ! Check (new) group's information 332 CALL VERIFY("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) 333 CALL VERIFY("H5Gget_info_f", max_corder, u+1, total_error) 334 CALL VERIFY("H5Gget_info_f", nlinks, u+1, total_error) 335 336 ! Retrieve group's information 337 CALL H5Gget_info_by_name_f(group_id, objname, storage_type, nlinks, max_corder, error) 338 CALL check("H5Gget_info_by_name_f", error, total_error) 339 340 ! Check (new) group's information 341 CALL VERIFY("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) 342 CALL VERIFY("H5Gget_info_by_name_f",max_corder, u+1, total_error) 343 CALL VERIFY("H5Gget_info_by_name_f", nlinks, u+1, total_error) 344 345 ! Retrieve group's information 346 CALL H5Gget_info_by_name_f(group_id2, ".", storage_type, nlinks, max_corder, error) 347 CALL check("H5Gget_info_by_name_f", error, total_error) 348 349 ! Check (new) group's information 350 CALL VERIFY("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) 351 CALL VERIFY("H5Gget_info_by_name_f", max_corder, u+1, total_error) 352 CALL VERIFY("H5Gget_info_by_name_f", nlinks, u+1, total_error) 353 354 ! Retrieve group's information 355 IF(order.NE.H5_ITER_NATIVE_F)THEN 356 IF(order.EQ.H5_ITER_INC_F) THEN 357 CALL H5Gget_info_by_idx_f(group_id, ".", idx_type, order, INT(u,HSIZE_T), & 358 storage_type, nlinks, max_corder, error,lapl_id=H5P_DEFAULT_F, mounted=mounted) 359 CALL check("H5Gget_info_by_idx_f", error, total_error) 360 CALL verifyLogical("H5Gget_info_by_idx_f", mounted,.FALSE.,total_error) 361 ELSE 362 CALL H5Gget_info_by_idx_f(group_id, ".", idx_type, order, INT(0,HSIZE_T), & 363 storage_type, nlinks, max_corder, error, mounted=mounted) 364 CALL verifyLogical("H5Gget_info_by_idx_f", mounted,.FALSE.,total_error) 365 CALL check("H5Gget_info_by_idx_f", error, total_error) 366 ENDIF 367 ! Check (new) group's information 368 CALL VERIFY("H5Gget_info_by_idx_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) 369 CALL VERIFY("H5Gget_info_by_idx_f", max_corder, u+1, total_error) 370 CALL VERIFY("H5Gget_info_by_idx_f", nlinks, u+1, total_error) 371 ENDIF 372 ! Close group created 373 CALL H5Gclose_f(group_id2, error) 374 CALL check("H5Gclose_f", error, total_error) 375 376 ! Retrieve main group's information 377 CALL H5Gget_info_f(group_id, storage_type, nlinks, max_corder, error) 378 CALL check("H5Gget_info_f", error, total_error) 379 380 ! Check main group's information 381 CALL VERIFY("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) 382 CALL VERIFY("H5Gget_info_f", max_corder, u+1, total_error) 383 CALL VERIFY("H5Gget_info_f", nlinks, u+1, total_error) 384 385 ! Retrieve main group's information, by name 386 CALL H5Gget_info_by_name_f(file_id, CORDER_GROUP_NAME, storage_type, nlinks, max_corder, error) 387 CALL check("H5Gget_info_by_name_f", error, total_error) 388 389 ! Check main group's information 390 CALL VERIFY("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) 391 CALL VERIFY("H5Gget_info_by_name_f", max_corder, u+1, total_error) 392 CALL VERIFY("H5Gget_info_by_name_f", nlinks, u+1, total_error) 393 394 ! Retrieve main group's information, by name 395 CALL H5Gget_info_by_name_f(group_id, ".", storage_type, nlinks, max_corder, error, H5P_DEFAULT_F) 396 CALL check("H5Gget_info_by_name_f", error, total_error) 397 398 ! Check main group's information 399 CALL VERIFY("H5Gget_info_by_name_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) 400 CALL VERIFY("H5Gget_info_by_name_f", max_corder, u+1, total_error) 401 CALL VERIFY("H5Gget_info_by_name_f", nlinks, u+1, total_error) 402 403 ! Create soft link in another group, to objects in main group 404 valname = CORDER_GROUP_NAME//objname 405 406 CALL H5Lcreate_soft_f(valname, soft_group_id, objname, error, H5P_DEFAULT_F, H5P_DEFAULT_F) 407 408 ! Retrieve soft link group's information, by name 409 CALL H5Gget_info_f(soft_group_id, storage_type, nlinks, max_corder, error) 410 CALL check("H5Gget_info_f", error, total_error) 411 412 ! Check soft link group's information 413 CALL VERIFY("H5Gget_info_f", storage_type, H5G_STORAGE_TYPE_COMPACT_F, total_error) 414 CALL VERIFY("H5Gget_info_f", max_corder, u+1, total_error) 415 CALL VERIFY("H5Gget_info_f", nlinks, u+1, total_error) 416 ENDDO 417 418 ! Close the groups 419 420 CALL H5Gclose_f(group_id, error) 421 CALL check("H5Gclose_f", error, total_error) 422 CALL H5Gclose_f(soft_group_id, error) 423 CALL check("H5Gclose_f", error, total_error) 424 425 ! Close the file 426 CALL H5Fclose_f(file_id, error) 427 CALL check("H5Fclose_f", error, total_error) 428 ENDDO 429 ENDDO 430 ENDDO 431 432 ! Free resources 433 CALL H5Pclose_f(gcpl_id, error) 434 CALL check("H5Pclose_f", error, total_error) 435 436 IF(cleanup) CALL h5_cleanup_f(prefix, H5P_DEFAULT_F, error) 437 CALL check("h5_cleanup_f", error, total_error) 438 439 440 END SUBROUTINE group_info 441 442!------------------------------------------------------------------------- 443! * Function: timestamps 444! * 445! * Purpose: Verify that disabling tracking timestamps for an object 446! * works correctly 447! * 448! * 449! * Programmer: M.S. Breitenfeld 450! * February 20, 2008 451! * 452! *------------------------------------------------------------------------- 453! 454 455 SUBROUTINE timestamps(cleanup, fapl, total_error) 456 457 USE HDF5 ! This module contains all necessary modules 458 USE TH5_MISC 459 460 IMPLICIT NONE 461 INTEGER, INTENT(INOUT) :: total_error 462 INTEGER(HID_T), INTENT(IN) :: fapl 463 464 INTEGER(HID_T) :: file_id ! File ID 465 INTEGER(HID_T) :: group_id ! Group ID 466 INTEGER(HID_T) :: group_id2 ! Group ID 467 INTEGER(HID_T) :: gcpl_id ! Group creation property list ID 468 INTEGER(HID_T) :: gcpl_id2 ! Group creation property list ID 469 470 CHARACTER(LEN=6), PARAMETER :: prefix = 'links9' 471 CHARACTER(LEN=9), PARAMETER :: filename = prefix//'.h5' ! File name 472 ! Timestamp macros 473 CHARACTER(LEN=10), PARAMETER :: TIMESTAMP_GROUP_1="timestamp1" 474 CHARACTER(LEN=10), PARAMETER :: TIMESTAMP_GROUP_2="timestamp2" 475 LOGICAL :: track_times 476 LOGICAL :: cleanup 477 478 INTEGER :: error 479 480 ! Print test message 481! WRITE(*,*) "timestamps on objects" 482 483 ! Create group creation property list 484 CALL H5Pcreate_f(H5P_GROUP_CREATE_F, gcpl_id, error ) 485 CALL check("H5Pcreate_f", error, total_error) 486 487 ! Query the object timestamp setting 488 CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) 489 CALL check("H5Pget_obj_track_times_f", error, total_error) 490 491 ! Check default timestamp information 492 CALL VerifyLogical("H5Pget_obj_track_times",track_times,.TRUE.,total_error) 493 494 ! Set a non-default object timestamp setting 495 CALL H5Pset_obj_track_times_f(gcpl_id, .FALSE., error) 496 CALL check("H5Pset_obj_track_times_f", error, total_error) 497 498 ! Query the object timestamp setting 499 CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) 500 CALL check("H5Pget_obj_track_times_f", error, total_error) 501 502 ! Check default timestamp information 503 CALL VerifyLogical("H5Pget_obj_track_times",track_times,.FALSE.,total_error) 504 505 ! Create file 506 !h5_fixname(FILENAME[0], fapl, filename, sizeof filename); 507 508 CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl) 509 CALL check("h5fcreate_f",error,total_error) 510 511 ! Create group with non-default object timestamp setting 512 CALL h5gcreate_f(file_id, TIMESTAMP_GROUP_1, group_id, error, & 513 OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, gcpl_id, H5P_DEFAULT_F) 514 CALL check("h5fcreate_f",error,total_error) 515 516 ! Close the group creation property list 517 CALL H5Pclose_f(gcpl_id, error) 518 CALL check("H5Pclose_f", error, total_error) 519 520 ! Create group with default object timestamp setting 521 CALL h5gcreate_f(file_id, TIMESTAMP_GROUP_2, group_id2, error, & 522 OBJECT_NAMELEN_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F, H5P_DEFAULT_F) 523 CALL check("h5fcreate_f",error,total_error) 524 525 ! Retrieve the new groups' creation properties 526 CALL H5Gget_create_plist_f(group_id, gcpl_id, error) 527 CALL check("H5Gget_create_plist", error, total_error) 528 CALL H5Gget_create_plist_f(group_id2, gcpl_id2, error) 529 CALL check("H5Gget_create_plist", error, total_error) 530 531 ! Query & verify the object timestamp settings 532 CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) 533 CALL check("H5Pget_obj_track_times_f", error, total_error) 534 CALL VerifyLogical("H5Pget_obj_track_times1",track_times,.FALSE.,total_error) 535 CALL H5Pget_obj_track_times_f(gcpl_id2, track_times, error) 536 CALL check("H5Pget_obj_track_times_f", error, total_error) 537 CALL VerifyLogical("H5Pget_obj_track_times2",track_times,.TRUE.,total_error) 538 539! Query the object information for each group 540! if(H5Oget_info(group_id, &oinfo) < 0) TEST_ERROR 541! if(H5Oget_info(group_id2, &oinfo2) < 0) TEST_ERROR 542 543!!$ Sanity check object information for each group 544!!$ if(oinfo.atime != 0) TEST_ERROR 545!!$ if(oinfo.mtime != 0) TEST_ERROR 546!!$ if(oinfo.ctime != 0) TEST_ERROR 547!!$ if(oinfo.btime != 0) TEST_ERROR 548!!$ if(oinfo.atime == oinfo2.atime) TEST_ERROR 549!!$ if(oinfo.mtime == oinfo2.mtime) TEST_ERROR 550!!$ if(oinfo.ctime == oinfo2.ctime) TEST_ERROR 551!!$ if(oinfo.btime == oinfo2.btime) TEST_ERROR 552!!$ if((oinfo.hdr.flags & H5O_HDR_STORE_TIMES) != 0) TEST_ERROR 553!!$ if((oinfo2.hdr.flags & H5O_HDR_STORE_TIMES) == 0) TEST_ERROR 554!!$ if(oinfo.hdr.space.total >= oinfo2.hdr.space.total) TEST_ERROR 555!!$ if(oinfo.hdr.space.meta >= oinfo2.hdr.space.meta) TEST_ERROR 556 557 ! Close the property lists 558 CALL H5Pclose_f(gcpl_id, error) 559 CALL check("H5Pclose_f", error, total_error) 560 CALL H5Pclose_f(gcpl_id2, error) 561 CALL check("H5Pclose_f", error, total_error) 562 563 ! Close the groups 564 CALL H5Gclose_f(group_id, error) 565 CALL check("H5Gclose_f", error, total_error) 566 CALL H5Gclose_f(group_id2, error) 567 CALL check("H5Gclose_f", error, total_error) 568 569 ! Close the file 570 CALL H5Fclose_f(file_id, error) 571 CALL check("H5Fclose_f", error, total_error) 572 573 ! Re-open the file 574 575 CALL h5fopen_f(FileName, H5F_ACC_RDONLY_F, file_id, error, H5P_DEFAULT_F) 576 CALL check("h5fopen_f",error,total_error) 577 578 ! Open groups 579 CALL H5Gopen_f(file_id, TIMESTAMP_GROUP_1, group_id, error) ! with no optional param. 580 CALL check("H5Gopen_f", error, total_error) 581 CALL H5Gopen_f(file_id, TIMESTAMP_GROUP_2, group_id2, error, H5P_DEFAULT_F) ! with optional param. 582 CALL check("H5Gopen_f", error, total_error) 583 584 ! Retrieve the new groups' creation properties 585 CALL H5Gget_create_plist_f(group_id, gcpl_id, error) 586 CALL check("H5Gget_create_plist", error, total_error) 587 CALL H5Gget_create_plist_f(group_id2, gcpl_id2, error) 588 CALL check("H5Gget_create_plist", error, total_error) 589 590 ! Query & verify the object timestamp settings 591 592 CALL H5Pget_obj_track_times_f(gcpl_id, track_times, error) 593 CALL check("H5Pget_obj_track_times_f", error, total_error) 594 CALL VerifyLogical("H5Pget_obj_track_times1",track_times,.FALSE.,total_error) 595 CALL H5Pget_obj_track_times_f(gcpl_id2, track_times, error) 596 CALL check("H5Pget_obj_track_times_f", error, total_error) 597 CALL VerifyLogical("H5Pget_obj_track_times2",track_times,.TRUE.,total_error) 598!!$ 599!!$ Query the object information for each group 600!!$ if(H5Oget_info(group_id, &oinfo) < 0) TEST_ERROR 601!!$ if(H5Oget_info(group_id2, &oinfo2) < 0) TEST_ERROR 602!!$ 603!!$ Sanity check object information for each group 604!!$ if(oinfo.atime != 0) TEST_ERROR 605!!$ if(oinfo.mtime != 0) TEST_ERROR 606!!$ if(oinfo.ctime != 0) TEST_ERROR 607!!$ if(oinfo.btime != 0) TEST_ERROR 608!!$ if(oinfo.atime == oinfo2.atime) TEST_ERROR 609!!$ if(oinfo.mtime == oinfo2.mtime) TEST_ERROR 610!!$ if(oinfo.ctime == oinfo2.ctime) TEST_ERROR 611!!$ if(oinfo.btime == oinfo2.btime) TEST_ERROR 612!!$ if((oinfo.hdr.flags & H5O_HDR_STORE_TIMES) != 0) TEST_ERROR 613!!$ if((oinfo2.hdr.flags & H5O_HDR_STORE_TIMES) == 0) TEST_ERROR 614!!$ if(oinfo.hdr.space.total >= oinfo2.hdr.space.total) TEST_ERROR 615!!$ if(oinfo.hdr.space.meta >= oinfo2.hdr.space.meta) TEST_ERROR 616 617 ! Close the property lists 618 CALL H5Pclose_f(gcpl_id, error) 619 CALL check("H5Pclose_f", error, total_error) 620 CALL H5Pclose_f(gcpl_id2, error) 621 CALL check("H5Pclose_f", error, total_error) 622 623 ! Close the groups 624 CALL H5Gclose_f(group_id, error) 625 CALL check("H5Gclose_f", error, total_error) 626 CALL H5Gclose_f(group_id2, error) 627 CALL check("H5Gclose_f", error, total_error) 628 629 ! Close the file 630 CALL H5Fclose_f(file_id, error) 631 CALL check("H5Fclose_f", error, total_error) 632 633 IF(cleanup) CALL h5_cleanup_f(prefix, H5P_DEFAULT_F, error) 634 CALL check("h5_cleanup_f", error, total_error) 635 636 END SUBROUTINE timestamps 637 638!------------------------------------------------------------------------- 639! * Function: mklinks 640! * 641! * Purpose: Build a file with assorted links. 642! * 643! * 644! * Programmer: Adapted from C test by: 645! * M.S. Breitenfeld 646! * 647! * Modifications: 648! * 649! *------------------------------------------------------------------------- 650! 651 652 SUBROUTINE mklinks(fapl, total_error) 653 654 USE HDF5 ! This module contains all necessary modules 655 USE TH5_MISC 656 657 IMPLICIT NONE 658 INTEGER, INTENT(INOUT) :: total_error 659 INTEGER(HID_T), INTENT(IN) :: fapl 660 661 INTEGER(HID_T) :: file, scalar, grp, d1 662 CHARACTER(LEN=12), PARAMETER :: filename ='TestLinks.h5' 663 INTEGER(HSIZE_T), DIMENSION(1) :: adims2 = (/1/) ! Attribute dimension 664 INTEGER :: arank = 1 ! Attribure rank 665 INTEGER :: error 666 667 INTEGER :: cset ! Indicates the character set used for the link’s name. 668 INTEGER :: corder ! Specifies the link’s creation order position. 669 LOGICAL :: f_corder_valid ! Indicates whether the value in corder is valid. 670 INTEGER :: link_type ! Specifies the link class: 671 ! H5L_TYPE_HARD_F - Hard link 672 ! H5L_TYPE_SOFT_F - Soft link 673 ! H5L_TYPE_EXTERNAL_F - External link 674 ! H5L_TYPE_ERROR _F - Error 675 INTEGER(HADDR_T) :: address ! If the link is a hard link, address specifies the file address that the link points to 676 INTEGER(SIZE_T) :: val_size ! If the link is a symbolic link, val_size will be the length of the link value 677 678 679! WRITE(*,*) "link creation (w/new group format)" 680 681 ! Create a file 682 CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, file, error, H5P_DEFAULT_F, fapl) 683 CALL check("mklinks.h5fcreate_f",error,total_error) 684 CALL h5screate_simple_f(arank, adims2, scalar, error) 685 CALL check("mklinks.h5screate_simple_f",error,total_error) 686 687 ! Create a group 688 CALL H5Gcreate_f(file, "grp1", grp, error) 689 CALL check("H5Gcreate_f", error, total_error) 690 CALL H5Gclose_f(grp, error) 691 CALL check("h5gclose_f",error,total_error) 692 693 ! Create a dataset 694 CALL h5dcreate_f(file, "d1", H5T_NATIVE_INTEGER, scalar, d1, error) 695 CALL check("h5dcreate_f",error,total_error) 696 CALL h5dclose_f(d1, error) 697 CALL check("h5dclose_f",error,total_error) 698 699 ! Create a hard link 700 CALL H5Lcreate_hard_f(file, "d1", INT(H5L_SAME_LOC_F,HID_T), "grp1/hard", error) 701 CALL check("H5Lcreate_hard_f", error, total_error) 702 703 ! Create a symbolic link 704 CALL H5Lcreate_soft_f("/d1", file, "grp1/soft",error) 705 CALL check("H5Lcreate_soft_f", error, total_error) 706 707 CALL H5Lget_info_f(file, "grp1/soft", & 708 cset, corder, f_corder_valid, link_type, address, val_size, & 709 error, H5P_DEFAULT_F) 710 CALL check("H5Lget_info_f",error,total_error) 711 712! CALL VerifyLogical("H5Lget_info_by_idx_f11", f_corder_valid, .TRUE., total_error) 713 714 CALL VERIFY("H5Lget_info_by_idx_f", H5L_TYPE_SOFT_F, link_type, total_error) 715 CALL VERIFY("H5Lget_info_by_idx_f", cset, H5T_CSET_ASCII_F, total_error) 716 ! should be '/d1' + NULL character = 4 717 CALL VERIFY("H5Lget_info_by_idx_f", INT(val_size), 4, total_error) 718 719 ! Create a symbolic link to something that doesn't exist 720 721 CALL H5Lcreate_soft_f("foobar", file, "grp1/dangle",error) 722 723 ! Create a recursive symbolic link 724 CALL H5Lcreate_soft_f("/grp1/recursive", file, "/grp1/recursive",error) 725 726 ! Close 727 CALL h5sclose_f(scalar, error) 728 CALL check("h5sclose_f",error,total_error) 729 CALL h5fclose_f(file, error) 730 CALL check("h5fclose_f",error,total_error) 731 732 END SUBROUTINE mklinks 733 734!------------------------------------------------------------------------- 735! * Function: test_move_preserves 736! * 737! * Purpose: Tests that moving and renaming links preserves their 738! * properties. 739! * 740! * Programmer: M.S. Breitenfeld 741! * March 3, 2008 742! * 743! * Modifications: 744! * 745! *------------------------------------------------------------------------- 746! 747 748 SUBROUTINE test_move_preserves(fapl_id, total_error) 749 750 USE HDF5 ! This module contains all necessary modules 751 USE TH5_MISC 752 753 IMPLICIT NONE 754 INTEGER, INTENT(INOUT) :: total_error 755 INTEGER(HID_T), INTENT(IN) :: fapl_id 756 757 INTEGER(HID_T):: file_id 758 INTEGER(HID_T):: group_id 759 INTEGER(HID_T):: fcpl_id ! Group creation property list ID 760 INTEGER(HID_T):: lcpl_id 761 !H5O_info_t oinfo; 762 !H5L_info_t linfo; 763 INTEGER :: old_cset 764 INTEGER :: old_corder 765 !H5T_cset_t old_cset; 766 !int64_t old_corder; Creation order value of link 767 !time_t old_modification_time; 768 !time_t curr_time; 769 !unsigned crt_order_flags; Status of creation order info for GCPL 770 !char filename[1024]; 771 772 INTEGER :: crt_order_flags ! Status of creation order info for GCPL 773 CHARACTER(LEN=12), PARAMETER :: filename = 'TestLinks.h5' 774 775 INTEGER :: cset ! Indicates the character set used for the link’s name. 776 INTEGER :: corder ! Specifies the link’s creation order position. 777 LOGICAL :: f_corder_valid ! Indicates whether the value in corder is valid. 778 INTEGER :: link_type ! Specifies the link class: 779 ! H5L_TYPE_HARD_F - Hard link 780 ! H5L_TYPE_SOFT_F - Soft link 781 ! H5L_TYPE_EXTERNAL_F - External link 782 ! H5L_TYPE_ERROR _F - Error 783 INTEGER(HADDR_T) :: address ! If the link is a hard link, address specifies the file address that the link points to 784 INTEGER(SIZE_T) :: val_size ! If the link is a symbolic link, val_size will be the length of the link value 785 786 INTEGER :: error 787 788! WRITE(*,*) "moving and copying links preserves their properties (w/new group format)" 789 790 ! Create a file creation property list with creation order stored for links 791 ! * in the root group 792 ! 793 794 CALL H5Pcreate_f(H5P_FILE_CREATE_F, fcpl_id, error) 795 CALL check("H5Pcreate_f",error, total_error) 796 797 CALL H5Pget_link_creation_order_f(fcpl_id, crt_order_flags, error) 798 CALL check("H5Pget_link_creation_order_f",error, total_error) 799 CALL VERIFY("H5Pget_link_creation_order_f",crt_order_flags,0, total_error) 800 801 CALL H5Pset_link_creation_order_f(fcpl_id, H5P_CRT_ORDER_TRACKED_F, error) 802 CALL check("H5Pset_link_creation_order_f", error, total_error) 803 804 CALL H5Pget_link_creation_order_f(fcpl_id, crt_order_flags, error) 805 CALL check("H5Pget_link_creation_order_f",error, total_error) 806 CALL VERIFY("H5Pget_link_creation_order_f",crt_order_flags, H5P_CRT_ORDER_TRACKED_F, total_error) 807 808 ! Create file 809 ! (with creation order tracking for the root group) 810 811 CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, file_id, error, fcpl_id, fapl_id) 812 CALL check("h5fcreate_f",error,total_error) 813 814 ! Create a link creation property list with the UTF-8 character encoding 815 CALL H5Pcreate_f(H5P_LINK_CREATE_F, lcpl_id, error) 816 CALL check("H5Pcreate_f",error, total_error) 817 818 CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) 819 CALL check("H5Pset_char_encoding_f",error, total_error) 820 821 ! Create a group with that lcpl 822 CALL H5Gcreate_f(file_id, "group", group_id, error,lcpl_id=lcpl_id, gcpl_id=H5P_DEFAULT_F, gapl_id=H5P_DEFAULT_F) 823 CALL check("H5Gcreate_f", error, total_error) 824 CALL H5Gclose_f(group_id, error) 825 CALL check("H5Gclose_f", error, total_error) 826 827 ! Get the group's link's information 828 CALL H5Lget_info_f(file_id, "group", & 829 cset, corder, f_corder_valid, link_type, address, val_size, & 830 error, H5P_DEFAULT_F) 831 CALL check("H5Lget_info_f",error,total_error) 832 833! if(H5Oget_info_by_name(file_id, "group", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR 834 835 old_cset = cset 836 CALL VERIFY("H5Lget_info_f",old_cset,H5T_CSET_UTF8_F,total_error) 837 CALL VerifyLogical("H5Lget_info_f",f_corder_valid,.TRUE.,total_error) 838 old_corder = corder; 839 CALL VERIFY("H5Lget_info_f",old_corder,0,total_error) 840 841! old_modification_time = oinfo.mtime; 842 843! If this test happens too quickly, the times will all be the same. Make sure the time changes. 844! curr_time = HDtime(NULL); 845! while(HDtime(NULL) <= curr_time) 846! ; 847 848! Close the file and reopen it 849 CALL H5Fclose_f(file_id, error) 850 CALL check("H5Fclose_f", error, total_error) 851 852!!$ if((file_id = H5Fopen(filename, H5F_ACC_RDWR, fapl_id)) < 0) TEST_ERROR 853!!$ 854!!$ Get the link's character set & modification time . They should be unchanged 855!!$ if(H5Lget_info(file_id, "group", &linfo, H5P_DEFAULT) < 0) TEST_ERROR 856!!$ if(H5Oget_info_by_name(file_id, "group", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR 857!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR 858!!$ if(old_cset != linfo.cset) TEST_ERROR 859!!$ if(linfo.corder_valid != TRUE) TEST_ERROR 860!!$ if(old_corder != linfo.corder) TEST_ERROR 861!!$ 862!!$ Create a new link to the group. It should have a different creation order value but the same modification time 863!!$ if(H5Lcreate_hard(file_id, "group", file_id, "group2", H5P_DEFAULT, H5P_DEFAULT) < 0) TEST_ERROR 864!!$ if(H5Oget_info_by_name(file_id, "group2", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR 865!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR 866!!$ if(H5Lget_info(file_id, "group2", &linfo, H5P_DEFAULT) < 0) TEST_ERROR 867!!$ if(old_corder == linfo.corder) TEST_ERROR 868!!$ if(linfo.corder_valid != TRUE) TEST_ERROR 869!!$ if(linfo.corder != 1) TEST_ERROR 870!!$ if(linfo.cset != H5T_CSET_ASCII) TEST_ERROR 871!!$ 872!!$ Copy the first link to a UTF-8 name. 873!!$ * Its creation order value should be different, but modification time 874!!$ * should not change. 875!!$ 876!!$ if(H5Lcopy(file_id, "group", file_id, "group_copied", lcpl_id, H5P_DEFAULT) < 0) TEST_ERROR 877!!$ if(H5Oget_info_by_name(file_id, "group_copied", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR 878!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR 879!!$ if(H5Lget_info(file_id, "group_copied", &linfo, H5P_DEFAULT) < 0) TEST_ERROR 880!!$ if(linfo.corder_valid != TRUE) TEST_ERROR 881!!$ if(linfo.corder != 2) TEST_ERROR 882!!$ 883!!$ Check that its character encoding is UTF-8 884!!$ if(linfo.cset != H5T_CSET_UTF8) TEST_ERROR 885!!$ 886!!$ Move the link with the default property list. 887!!$ if(H5Lmove(file_id, "group_copied", file_id, "group_copied2", H5P_DEFAULT, H5P_DEFAULT) < 0) TEST_ERROR 888!!$ if(H5Oget_info_by_name(file_id, "group_copied2", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR 889!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR 890!!$ if(H5Lget_info(file_id, "group_copied2", &linfo, H5P_DEFAULT) < 0) TEST_ERROR 891!!$ if(linfo.corder_valid != TRUE) TEST_ERROR 892!!$ if(linfo.corder != 3) TEST_ERROR 893!!$ 894!!$ Check that its character encoding is not UTF-8 895!!$ if(linfo.cset == H5T_CSET_UTF8) TEST_ERROR 896!!$ 897!!$ Check that the original link is unchanged 898!!$ if(H5Oget_info_by_name(file_id, "group", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR 899!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR 900!!$ if(H5Lget_info(file_id, "group", &linfo, H5P_DEFAULT) < 0) TEST_ERROR 901!!$ if(linfo.corder_valid != TRUE) TEST_ERROR 902!!$ if(old_corder != linfo.corder) TEST_ERROR 903!!$ if(linfo.cset != H5T_CSET_UTF8) TEST_ERROR 904!!$ 905!!$ Move the first link to a UTF-8 name. 906!!$ * Its creation order value will change, but modification time should not 907!!$ * change. 908!!$ if(H5Lmove(file_id, "group", file_id, "group_moved", lcpl_id, H5P_DEFAULT) < 0) TEST_ERROR 909!!$ if(H5Oget_info_by_name(file_id, "group_moved", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR 910!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR 911!!$ if(H5Lget_info(file_id, "group_moved", &linfo, H5P_DEFAULT) < 0) TEST_ERROR 912!!$ if(linfo.corder_valid != TRUE) TEST_ERROR 913!!$ if(linfo.corder != 4) TEST_ERROR 914!!$ 915!!$ Check that its character encoding is UTF-8 916!!$ if(linfo.cset != H5T_CSET_UTF8) TEST_ERROR 917!!$ 918!!$ Move the link again using the default property list. 919!!$ if(H5Lmove(file_id, "group_moved", file_id, "group_moved_again", H5P_DEFAULT, H5P_DEFAULT) < 0) TEST_ERROR 920!!$ if(H5Oget_info_by_name(file_id, "group_moved_again", &oinfo, H5P_DEFAULT) < 0) TEST_ERROR 921!!$ if(old_modification_time != oinfo.mtime) TEST_ERROR 922!!$ if(H5Lget_info(file_id, "group_moved_again", &linfo, H5P_DEFAULT) < 0) TEST_ERROR 923!!$ if(linfo.corder_valid != TRUE) TEST_ERROR 924!!$ if(linfo.corder != 5) TEST_ERROR 925!!$ 926!!$ Check that its character encoding is not UTF-8 927!!$ if(linfo.cset == H5T_CSET_UTF8) TEST_ERROR 928 929 ! Close open IDs 930 CALL H5Pclose_f(fcpl_id, error) 931 CALL check("H5Pclose_f", error, total_error) 932 CALL H5Pclose_f(lcpl_id, error) 933 CALL check("H5Pclose_f", error, total_error) 934 935 ! if(H5Fclose(file_id) < 0) TEST_ERROR 936 937 END SUBROUTINE test_move_preserves 938 939!------------------------------------------------------------------------- 940! * Function: lifecycle 941! * 942! * Purpose: Test that adding links to a group follow proper "lifecycle" 943! * of empty->compact->symbol table->compact->empty. (As group 944! * is created, links are added, then links removed) 945! * 946! * Return: Success: 0 947! * 948! * Failure: -1 949! * 950! * Programmer: Quincey Koziol 951! * Monday, October 17, 2005 952! * 953! *------------------------------------------------------------------------- 954! 955SUBROUTINE lifecycle(cleanup, fapl2, total_error) 956 957 958 USE HDF5 ! This module contains all necessary modules 959 USE TH5_MISC 960 961 IMPLICIT NONE 962 INTEGER, INTENT(INOUT) :: total_error 963 INTEGER(HID_T), INTENT(IN) :: fapl2 964 INTEGER :: error 965 966 INTEGER, PARAMETER :: NAME_BUF_SIZE =7 967 968 INTEGER(HID_T) :: fid ! File ID 969 INTEGER(HID_T) :: gid ! Group ID 970 INTEGER(HID_T) :: gcpl ! Group creation property list ID 971 INTEGER(size_t) :: lheap_size_hint ! Local heap size hint 972 INTEGER :: max_compact ! Maximum # of links to store in group compactly 973 INTEGER :: min_dense ! Minimum # of links to store in group "densely" 974 INTEGER :: est_num_entries ! Estimated # of entries in group 975 INTEGER :: est_name_len ! Estimated length of entry name 976 CHARACTER(LEN=NAME_BUF_SIZE) :: filename = 'fixx.h5' 977 INTEGER(SIZE_T) :: LIFECYCLE_LOCAL_HEAP_SIZE_HINT = 256 978 INTEGER :: LIFECYCLE_MAX_COMPACT = 4 979 INTEGER :: LIFECYCLE_MIN_DENSE = 3 980 INTEGER :: LIFECYCLE_EST_NUM_ENTRIES = 4 981 INTEGER :: LIFECYCLE_EST_NAME_LEN=8 982 CHARACTER(LEN=3) :: LIFECYCLE_TOP_GROUP="top" 983! These value are taken from H5Gprivate.h 984 INTEGER :: H5G_CRT_GINFO_MAX_COMPACT = 8 985 INTEGER :: H5G_CRT_GINFO_MIN_DENSE = 6 986 INTEGER :: H5G_CRT_GINFO_EST_NUM_ENTRIES = 4 987 INTEGER :: H5G_CRT_GINFO_EST_NAME_LEN = 8 988 logical :: cleanup 989 990! WRITE(*,*) 'group lifecycle' 991 992 ! Create file 993 CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, fid, error, access_prp=fapl2) 994 CALL check("H5Fcreate_f",error,total_error) 995 996 ! Close file 997 CALL H5Fclose_f(fid,error) 998 CALL check("H5Fclose_f",error,total_error) 999 1000 ! Get size of file as empty 1001 ! if((empty_size = h5_get_file_size(filename)) < 0) TEST_ERROR 1002 1003 ! Re-open file 1004 1005 CALL H5Fopen_f(filename, H5F_ACC_RDWR_F, fid, error,access_prp=fapl2) 1006 CALL check("H5Fopen_f",error,total_error) 1007 1008 1009 ! Set up group creation property list 1010 CALL H5Pcreate_f(H5P_GROUP_CREATE_F,gcpl,error) 1011 CALL check("H5Pcreate_f",error,total_error) 1012 1013 1014 ! Query default group creation property settings 1015 CALL H5Pget_local_heap_size_hint_f(gcpl, lheap_size_hint, error) 1016 CALL check("H5Pget_local_heap_size_hint_f",error,total_error) 1017 CALL verify("H5Pget_local_heap_size_hint_f", INT(lheap_size_hint),0,total_error) 1018 1019 CALL H5Pget_link_phase_change_f(gcpl, max_compact, min_dense, error) 1020 CALL check("H5Pget_link_phase_change_f", error, total_error) 1021 CALL verify("H5Pget_link_phase_change_f", max_compact, H5G_CRT_GINFO_MAX_COMPACT,total_error) 1022 CALL verify("H5Pget_link_phase_change_f", min_dense, H5G_CRT_GINFO_MIN_DENSE,total_error) 1023 1024 1025 CALL H5Pget_est_link_info_f(gcpl, est_num_entries, est_name_len, error) 1026 CALL check("H5Pget_est_link_info_f", error, total_error) 1027 CALL verify("H5Pget_est_link_info_f", est_num_entries, H5G_CRT_GINFO_EST_NUM_ENTRIES,total_error) 1028 CALL verify("H5Pget_est_link_info_f", est_name_len, H5G_CRT_GINFO_EST_NAME_LEN,total_error) 1029 1030 1031 ! Set GCPL parameters 1032 1033 CALL H5Pset_local_heap_size_hint_f(gcpl, LIFECYCLE_LOCAL_HEAP_SIZE_HINT, error) 1034 CALL check("H5Pset_local_heap_size_hint_f", error, total_error) 1035 CALL H5Pset_link_phase_change_f(gcpl, LIFECYCLE_MAX_COMPACT, LIFECYCLE_MIN_DENSE, error) 1036 CALL check("H5Pset_link_phase_change_f", error, total_error) 1037 CALL H5Pset_est_link_info_f(gcpl, LIFECYCLE_EST_NUM_ENTRIES, LIFECYCLE_EST_NAME_LEN, error) 1038 CALL check("H5Pset_est_link_info_f", error, total_error) 1039 1040 ! Create group for testing lifecycle 1041 1042 CALL H5Gcreate_f(fid, LIFECYCLE_TOP_GROUP, gid, error, gcpl_id=gcpl) 1043 CALL check("H5Gcreate_f", error, total_error) 1044 1045 ! Query group creation property settings 1046 1047 CALL H5Pget_local_heap_size_hint_f(gcpl, lheap_size_hint, error) 1048 CALL check("H5Pget_local_heap_size_hint_f",error,total_error) 1049 CALL verify("H5Pget_local_heap_size_hint_f", INT(lheap_size_hint),INT(LIFECYCLE_LOCAL_HEAP_SIZE_HINT),total_error) 1050 1051 CALL H5Pget_link_phase_change_f(gcpl, max_compact, min_dense, error) 1052 CALL check("H5Pget_link_phase_change_f", error, total_error) 1053 CALL verify("H5Pget_link_phase_change_f", max_compact, LIFECYCLE_MAX_COMPACT,total_error) 1054 CALL verify("H5Pget_link_phase_change_f", min_dense, LIFECYCLE_MIN_DENSE,total_error) 1055 1056 CALL H5Pget_est_link_info_f(gcpl, est_num_entries, est_name_len, error) 1057 CALL check("H5Pget_est_link_info_f", error, total_error) 1058 CALL verify("H5Pget_est_link_info_f", est_num_entries, LIFECYCLE_EST_NUM_ENTRIES,total_error) 1059 CALL verify("H5Pget_est_link_info_f", est_name_len, LIFECYCLE_EST_NAME_LEN,total_error) 1060 1061 1062 1063 ! Close top group 1064 CALL H5Gclose_f(gid, error) 1065 CALL check("H5Gclose_f", error, total_error) 1066 1067 ! Unlink top group 1068 1069 CALL H5Ldelete_f(fid, LIFECYCLE_TOP_GROUP, error) 1070 CALL check("H5Ldelete_f", error, total_error) 1071 1072 ! Close GCPL 1073 CALL H5Pclose_f(gcpl, error) 1074 CALL check("H5Pclose_f", error, total_error) 1075 1076 ! Close file 1077 CALL H5Fclose_f(fid,error) 1078 CALL check("H5Fclose_f",error,total_error) 1079 1080 IF(cleanup) CALL h5_cleanup_f("fixx", H5P_DEFAULT_F, error) 1081 CALL check("h5_cleanup_f", error, total_error) 1082 1083 END SUBROUTINE lifecycle 1084 1085!------------------------------------------------------------------------- 1086! * Function: cklinks 1087! * 1088! * Purpose: Open the file created in the first step and check that the 1089! * links look correct. 1090! * 1091! * Return: Success: 0 1092! * 1093! * Failure: -1 1094! * 1095! * Programmer: M.S. Breitenfeld 1096! * April 14, 2008 1097! * 1098! * Modifications: Modified original C code 1099! * 1100! *------------------------------------------------------------------------- 1101! 1102 1103 1104 SUBROUTINE cklinks(fapl, total_error) 1105 1106! USE ISO_C_BINDING 1107 USE HDF5 ! This module contains all necessary modules 1108 USE TH5_MISC 1109 1110 IMPLICIT NONE 1111 INTEGER, INTENT(INOUT) :: total_error 1112 INTEGER(HID_T), INTENT(IN) :: fapl 1113 INTEGER :: error 1114 1115 INTEGER(HID_T) :: file 1116! H5O_info_t oinfo1, oinfo2; 1117! H5L_info_t linfo2; 1118 1119 CHARACTER(LEN=12), PARAMETER :: filename ='TestLinks.h5' 1120 1121! TYPE(C_PTR) :: linkval 1122 1123 LOGICAL :: Lexists 1124 1125 ! Open the file 1126 CALL H5Fopen_f(filename, H5F_ACC_RDONLY_F, file, error,access_prp=fapl) 1127 CALL check("H5Fopen_f",error,total_error) 1128 1129 1130 ! Hard link 1131!!$ IF(H5Oget_info_by_name(file, "d1", &oinfo1, H5P_DEFAULT) < 0) FAIL_STACK_ERROR 1132!!$ IF(H5Oget_info_by_name(file, "grp1/hard", &oinfo2, H5P_DEFAULT) < 0) FAIL_STACK_ERROR 1133!!$ IF(H5O_TYPE_DATASET != oinfo2.type) { 1134!!$ H5_FAILED(); 1135!!$ printf(" %d: Unexpected object type should have been a dataset\n", __LINE__); 1136!!$ TEST_ERROR 1137!!$ } end if 1138!!$ if(H5F_addr_ne(oinfo1.addr, oinfo2.addr)) { 1139!!$ H5_FAILED(); 1140!!$ puts(" Hard link test failed. Link seems not to point to the "); 1141!!$ puts(" expected file location."); 1142!!$ TEST_ERROR 1143!!$ } end if 1144 1145 1146 CALL H5Lexists_f(file,"d1",Lexists, error) 1147 CALL verifylogical("H5Lexists", Lexists,.TRUE.,total_error) 1148 1149 CALL H5Lexists_f(file,"grp1/hard",Lexists, error) 1150 CALL verifylogical("H5Lexists", Lexists,.TRUE.,total_error) 1151 1152 ! Cleanup 1153 CALL H5Fclose_f(file,error) 1154 CALL check("H5Fclose_f",error,total_error) 1155 1156END SUBROUTINE cklinks 1157 1158 1159!------------------------------------------------------------------------- 1160! * Function: delete_by_idx 1161! * 1162! * Purpose: Create a group with creation order indices and test deleting 1163! * links by index. 1164! * 1165! * Return: Total error 1166! * 1167! * C Programmer: Quincey Koziol 1168! * Tuesday, November 14, 2006 1169! * 1170! * Adapted to FORTRAN: M.S. Breitenfeld 1171! * March 3, 2008 1172! * 1173! *------------------------------------------------------------------------- 1174! 1175SUBROUTINE delete_by_idx(cleanup, fapl, total_error) 1176 1177 USE HDF5 ! This module contains all necessary modules 1178 USE TH5_MISC 1179 1180 IMPLICIT NONE 1181 INTEGER, INTENT(INOUT) :: total_error 1182 INTEGER(HID_T), INTENT(IN) :: fapl 1183 1184 INTEGER(HID_T) :: file_id ! File ID 1185 INTEGER(HID_T) :: group_id ! Group ID 1186 INTEGER(HID_T) :: gcpl_id ! Group creation property list ID 1187 1188 INTEGER :: idx_type ! Type of index to operate on 1189 LOGICAL, DIMENSION(1:2) :: use_index = (/.FALSE.,.TRUE./) 1190 ! Use index on creation order values 1191 INTEGER :: max_compact ! Maximum # of links to store in group compactly 1192 INTEGER :: min_dense ! Minimum # of links to store in group "densely" 1193 1194 CHARACTER(LEN=7) :: objname ! Object name 1195 CHARACTER(LEN=8) :: filename = 'file0.h5' ! File name 1196 CHARACTER(LEN=12), PARAMETER :: CORDER_GROUP_NAME = "corder_group" 1197 1198 LOGICAL :: f_corder_valid ! Indicates whether the creation order data is valid for this attribute 1199 INTEGER :: corder ! Is a positive integer containing the creation order of the attribute 1200 INTEGER :: cset ! Indicates the character set used for the attribute’s name 1201 INTEGER(SIZE_T) :: val_size 1202 INTEGER :: link_type 1203 INTEGER(HADDR_T) :: address 1204 1205 INTEGER :: u ! Local index variable 1206 INTEGER :: Input1, i 1207 INTEGER(HID_T) :: group_id2 1208 INTEGER(HID_T) :: grp 1209 INTEGER :: iorder ! Order within in the index 1210 CHARACTER(LEN=2) :: chr2 1211 INTEGER :: error 1212 INTEGER :: id_type 1213 ! 1214 ! 1215 ! 1216 CHARACTER(LEN=80) :: fix_filename1 1217 CHARACTER(LEN=80) :: fix_filename2 1218 INTEGER(HSIZE_T) :: htmp 1219 1220 LOGICAL :: cleanup 1221 1222 DO i = 1, 80 1223 fix_filename1(i:i) = " " 1224 fix_filename2(i:i) = " " 1225 ENDDO 1226 1227 ! Loop over operating on different indices on link fields 1228 DO idx_type = H5_INDEX_NAME_F, H5_INDEX_CRT_ORDER_F 1229 ! Loop over operating in different orders 1230 DO iorder = H5_ITER_INC_F, H5_ITER_DEC_F 1231 ! Loop over using index for creation order value 1232 DO i = 1, 2 1233 ! Print appropriate test message 1234!!$ IF(idx_type == H5_INDEX_CRT_ORDER_F)THEN 1235!!$ IF(iorder == H5_ITER_INC_F)THEN 1236!!$ IF(use_index(i))THEN 1237!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in increasing order w/creation order index" 1238!!$ ELSE 1239!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in increasing order w/o creation order index" 1240!!$ ENDIF 1241!!$ ELSE 1242!!$ IF(use_index(i))THEN 1243!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in decreasing order w/creation order index" 1244!!$ ELSE 1245!!$ WRITE(*,'(5x,A)')"deleting links by creation order index in decreasing order w/o creation order index" 1246!!$ ENDIF 1247!!$ ENDIF 1248!!$ ELSE 1249!!$ IF(iorder == H5_ITER_INC_F)THEN 1250!!$ IF(use_index(i))THEN 1251!!$ WRITE(*,'(5x,A)')"deleting links by name index in increasing order w/creation order index" 1252!!$ ELSE 1253!!$ WRITE(*,'(5x,A)')"deleting links by name index in increasing order w/o creation order index" 1254!!$ ENDIF 1255!!$ ELSE 1256!!$ IF(use_index(i))THEN 1257!!$ WRITE(*,'(5x,A)')"deleting links by name index in decreasing order w/creation order index" 1258!!$ ELSE 1259!!$ WRITE(*,'(5x,A)')"deleting links by name index in decreasing order w/o creation order index" 1260!!$ ENDIF 1261!!$ ENDIF 1262!!$ ENDIF 1263 1264 ! Create file 1265 CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, access_prp=fapl) 1266 CALL check("delete_by_idx.H5Fcreate_f", error, total_error) 1267 1268 ! Create group creation property list 1269 CALL H5Pcreate_f(H5P_GROUP_CREATE_F, gcpl_id, error ) 1270 CALL check("delete_by_idx.H5Pcreate_f", error, total_error) 1271 1272 ! Set creation order tracking & indexing on group 1273 IF(use_index(i))THEN 1274 Input1 = H5P_CRT_ORDER_INDEXED_F 1275 ELSE 1276 Input1 = 0 1277 ENDIF 1278 1279 CALL H5Pset_link_creation_order_f(gcpl_id, IOR(H5P_CRT_ORDER_TRACKED_F, Input1), error) 1280 CALL check("delete_by_idx.H5Pset_link_creation_order_f", error, total_error) 1281 1282 ! Create group with creation order tracking on 1283 CALL H5Gcreate_f(file_id, CORDER_GROUP_NAME, group_id, error, gcpl_id=gcpl_id) 1284 CALL check("delete_by_idx.H5Gcreate_f", error, total_error) 1285 1286 ! Query the group creation properties 1287 CALL H5Pget_link_phase_change_f(gcpl_id, max_compact, min_dense, error) 1288 CALL check("delete_by_idx.H5Pget_link_phase_change_f", error, total_error) 1289 1290 1291 ! Delete links from one end 1292 1293 ! Check for deletion on empty group 1294 CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, INT(0,HSIZE_T), error) 1295 CALL VERIFY("delete_by_idx.H5Ldelete_by_idx_f", error, -1, total_error) ! test should fail (error = -1) 1296 ! Create several links, up to limit of compact form 1297 DO u = 0, max_compact-1 1298 ! Make name for link 1299 WRITE(chr2,'(I2.2)') u 1300 objname = 'fill '//chr2 1301 1302 ! Create hard link, with group object 1303 CALL H5Gcreate_f(group_id, objname, group_id2, error) 1304 CALL check("delete_by_idx.H5Gcreate_f", error, total_error) 1305 CALL H5Gclose_f(group_id2, error) 1306 CALL check("delete_by_idx.H5Gclose_f", error, total_error) 1307 1308 ! Verify link information for new link 1309 CALL link_info_by_idx_check(group_id, objname, u, & 1310 .TRUE., use_index(i), total_error) 1311 ENDDO 1312 1313 ! Verify state of group (compact) 1314 ! IF(H5G_has_links_test(group_id, NULL) != TRUE) TEST_ERROR 1315 1316 ! Check for out of bound deletion 1317 htmp =9 1318!EP CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, INT(u,HSIZE_T), error) 1319 CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, htmp, error) 1320 CALL VERIFY("H5Ldelete_by_idx_f", error, -1, total_error) ! test should fail (error = -1) 1321 1322 1323 ! Delete links from compact group 1324 1325 DO u = 0, (max_compact - 1) -1 1326 ! Delete first link in appropriate order 1327 CALL H5Ldelete_by_idx_f(group_id, ".", idx_type, iorder, INT(0,HSIZE_T), error) 1328 CALL check("H5Ldelete_by_idx_f", error, total_error) 1329 ! Verify the link information for first link in appropriate order 1330 ! HDmemset(&linfo, 0, sizeof(linfo)); 1331 1332 CALL H5Lget_info_by_idx_f(group_id, ".", idx_type, iorder, INT(0,HSIZE_T), & 1333 link_type, f_corder_valid, corder, cset, address, val_size, error) 1334 1335 CALL H5Oopen_by_addr_f(group_id, address, grp, error) 1336 CALL check("H5Oopen_by_addr_f", error, total_error) 1337 1338 CALL H5Iget_type_f(grp, id_type, error) 1339 CALL check("H5Iget_type_f", error, total_error) 1340 1341 CALL VERIFY("H5Iget_type_f", id_type, H5I_GROUP_F, total_error) 1342 1343 CALL H5Gclose_f(grp, error) 1344 CALL check("H5Gclose_f", error, total_error) 1345 1346 CALL VerifyLogical("H5Lget_info_by_idx_f", f_corder_valid, .TRUE., total_error) 1347 1348 CALL VERIFY("H5Lget_info_by_idx_f", H5L_TYPE_HARD_F, link_type, total_error) 1349 IF(iorder.EQ.H5_ITER_INC_F)THEN 1350 CALL VERIFY("H5Lget_info_by_idx_f", corder, u+1, total_error) 1351 ELSE 1352 CALL VERIFY("H5Lget_info_by_idx_f", corder, (max_compact - (u + 2)), total_error) 1353 ENDIF 1354 1355 CALL VERIFY("H5Lget_info_by_idx_f",cset, H5T_CSET_ASCII_F, total_error) 1356 1357 1358 1359 ! Verify the name for first link in appropriate order 1360 ! HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE); 1361!!$ size_tmp = 20 1362!!$ CALL H5Lget_name_by_idx_f(group_id, ".", idx_type, order, INT(0,HSIZE_T), size_tmp, tmpname, error) 1363!!$ CALL check("delete_by_idx.H5Lget_name_by_idx_f", error, total_error) 1364!!$ 1365!!$ IF(order .EQ. H5_ITER_INC_F)THEN 1366!!$ WRITE(chr2,'(I2.2)') u + 1 1367!!$ ELSE 1368!!$ WRITE(chr2,'(I2.2)') (max_compact - (u + 2)) 1369!!$ ENDIF 1370!!$ objname = 'fill '//chr2 1371!!$ PRINT*,objname, tmpname 1372!!$ CALL verifyString("delete_by_idx.H5Lget_name_by_idx_f", objname, tmpname, total_error) 1373 ENDDO 1374 1375 ! Close the group 1376 CALL H5Gclose_f(group_id, error) 1377 CALL check("delete_by_idx.H5Gclose_f", error, total_error) 1378 1379 ! Close the group creation property list 1380 CALL H5Pclose_f(gcpl_id, error) 1381 CALL check("delete_by_idx.H5Gclose_f", error, total_error) 1382 1383 ! Close the file 1384 CALL H5Fclose_f(file_id, error) 1385 CALL check("delete_by_idx.H5Gclose_f", error, total_error) 1386 1387 IF(cleanup) CALL h5_cleanup_f("file0", H5P_DEFAULT_F, error) 1388 CALL check("h5_cleanup_f", error, total_error) 1389 1390 ENDDO 1391 ENDDO 1392 ENDDO 1393 1394 1395END SUBROUTINE delete_by_idx 1396 1397 1398 1399!------------------------------------------------------------------------- 1400! * Function: link_info_by_idx_check 1401! * 1402! * Purpose: Support routine for link_info_by_idx, to verify the link 1403! * info is correct for a link 1404! * 1405! * Note: This routine assumes that the links have been inserted in the 1406! * group in alphabetical order. 1407! * 1408! * Return: Success: 0 1409! * Failure: -1 1410! * 1411! * Programmer: Quincey Koziol 1412! * Tuesday, November 7, 2006 1413! * 1414! *------------------------------------------------------------------------- 1415! 1416SUBROUTINE link_info_by_idx_check(group_id, linkname, n, & 1417 hard_link, use_index, total_error) 1418 1419 USE HDF5 ! This module contains all necessary modules 1420 USE TH5_MISC 1421 1422 IMPLICIT NONE 1423 INTEGER, INTENT(INOUT) :: total_error 1424 INTEGER(HID_T), INTENT(IN) :: group_id 1425 CHARACTER(LEN=*), INTENT(IN) :: linkname 1426 INTEGER, INTENT(IN) :: n 1427 LOGICAL, INTENT(IN) :: hard_link 1428 LOGICAL, INTENT(IN) :: use_index 1429 1430 LOGICAL :: f_corder_valid ! Indicates whether the creation order data is valid for this attribute 1431 INTEGER :: corder ! Is a positive integer containing the creation order of the attribute 1432 INTEGER :: cset ! Indicates the character set used for the attribute’s name 1433 INTEGER :: link_type 1434 INTEGER(HADDR_T) :: address 1435 INTEGER(SIZE_T) :: val_size ! Indicates the size, in the number of characters, of the attribute 1436 1437 CHARACTER(LEN=7) :: tmpname ! Temporary link name 1438 CHARACTER(LEN=3) :: tmpname_small ! to small temporary link name 1439 CHARACTER(LEN=10) :: tmpname_big ! to big temporary link name 1440 1441 CHARACTER(LEN=7) :: valname ! Link value name 1442 CHARACTER(LEN=2) :: chr2 1443 INTEGER(SIZE_T) :: size_tmp 1444 INTEGER :: error 1445 1446 ! Make link value for increasing/native order queries 1447 1448 WRITE(chr2,'(I2.2)') n 1449 valname = 'valn.'//chr2 1450 1451 ! Verify the link information for first link, in increasing creation order 1452 ! HDmemset(&linfo, 0, sizeof(linfo)); 1453 CALL H5Lget_info_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(0,HSIZE_T), & 1454 link_type, f_corder_valid, corder, cset, address, val_size, error) 1455 CALL check("H5Lget_info_by_idx_f", error, total_error) 1456 CALL VERIFY("H5Lget_info_by_idx_f", corder, 0, total_error) 1457 1458 ! Verify the link information for new link, in increasing creation order 1459 ! HDmemset(&linfo, 0, sizeof(linfo)); 1460 CALL H5Lget_info_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), & 1461 link_type, f_corder_valid, corder, cset, address, val_size, error) 1462 CALL check("H5Lget_info_by_idx_f", error, total_error) 1463 CALL VERIFY("H5Lget_info_by_idx_f", corder, n, total_error) 1464 1465 ! Verify value for new soft link, in increasing creation order 1466!!$ IF(hard_link)THEN 1467!!$ ! HDmemset(tmpval, 0, (size_t)NAME_BUF_SIZE); 1468!!$ 1469!!$ CALL H5Lget_val_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, n, tmpval, INT(7,SIZE_T),error) 1470!!$ CALL check("H5Lget_val_by_idx",error,total_error) 1471!!$ 1472!!$! IF(HDstrcmp(valname, tmpval)) TEST_ERROR 1473!!$ ENDIF 1474 1475 ! Verify the name for new link, in increasing creation order 1476 ! HDmemset(tmpname, 0, (size_t)NAME_BUF_SIZE); 1477 1478 ! The actual size of tmpname should be 7 1479 1480 CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), tmpname_small, error, size_tmp) 1481 CALL check("link_info_by_idx_check.H5Lget_name_by_idx_f", error, total_error) 1482 CALL verifyString("link_info_by_idx_check.H5Lget_name_by_idx_f", & 1483 linkname(1:LEN(tmpname_small)), tmpname_small(1:LEN(tmpname_small)), total_error) 1484 CALL VERIFY("link_info_by_idx_check.H5Lget_name_by_idx_f", INT(size_tmp), 7, total_error) 1485 ! try it with the correct size 1486 CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), tmpname, error, size=size_tmp) 1487 CALL check("link_info_by_idx_check.H5Lget_name_by_idx_f", error, total_error) 1488 CALL verifyString("link_info_by_idx_check.H5Lget_name_by_idx_f", & 1489 linkname(1:LEN(tmpname)), tmpname(1:LEN(tmpname)), total_error) 1490 CALL VERIFY("link_info_by_idx_check.H5Lget_name_by_idx_f", INT(size_tmp), 7, total_error) 1491 1492 CALL H5Lget_name_by_idx_f(group_id, ".", H5_INDEX_CRT_ORDER_F, H5_ITER_INC_F, INT(n,HSIZE_T), tmpname_big, error, size_tmp) 1493 CALL check("link_info_by_idx_check.H5Lget_name_by_idx_f", error, total_error) 1494 CALL verifyString("link_info_by_idx_check.H5Lget_name_by_idx_f", & 1495 linkname(1:7), tmpname_big(1:7), total_error) 1496 CALL VERIFY("link_info_by_idx_check.H5Lget_name_by_idx_f", INT(size_tmp), 7, total_error) 1497 1498 ! Try with a buffer set to small 1499 1500 1501 END SUBROUTINE link_info_by_idx_check 1502 1503 1504!------------------------------------------------------------------------- 1505! * Function: test_lcpl 1506! * 1507! * Purpose: Tests Link Creation Property Lists 1508! * 1509! * Return: Success: 0 1510! * Failure: number of errors 1511! * 1512! * Programmer: M.S. Breitenfeld 1513! * Modified C routine 1514! * March 12, 2008 1515! * 1516! * Modifications: 1517! * 1518! *------------------------------------------------------------------------- 1519! 1520 1521 SUBROUTINE test_lcpl(cleanup, fapl, total_error) 1522 1523 USE HDF5 ! This module contains all necessary modules 1524 USE TH5_MISC 1525 1526 IMPLICIT NONE 1527 INTEGER, INTENT(INOUT) :: total_error 1528 INTEGER(HID_T), INTENT(IN) :: fapl 1529 LOGICAL :: cleanup 1530 1531 INTEGER(HID_T) :: file_id 1532 INTEGER(HID_T) :: group_id 1533 INTEGER(HID_T) :: space_id, data_space 1534 INTEGER(HID_T) :: dset_id 1535 INTEGER(HID_T) :: type_id 1536 INTEGER(HID_T) :: lcpl_id 1537 1538 INTEGER :: cset ! Indicates the character set used for the link’s name. 1539 INTEGER :: corder ! Specifies the link’s creation order position. 1540 LOGICAL :: f_corder_valid ! Indicates whether the value in corder is valid. 1541 INTEGER :: link_type ! Specifies the link class: 1542 ! H5L_TYPE_HARD_F - Hard link 1543 ! H5L_TYPE_SOFT_F - Soft link 1544 ! H5L_TYPE_EXTERNAL_F - External link 1545 ! H5L_TYPE_ERROR _F - Error 1546 INTEGER(HADDR_T) :: address ! If the link is a hard link, address specifies the file address that the link points to 1547 INTEGER(SIZE_T) :: val_size ! If the link is a symbolic link, val_size will be the length of the link value 1548 1549 CHARACTER(LEN=1024) :: filename = 'tempfile.h5' 1550 INTEGER, PARAMETER :: TEST6_DIM1 = 8, TEST6_DIM2 = 7 1551 INTEGER(HSIZE_T), DIMENSION(1:2), PARAMETER :: dims = (/TEST6_DIM1,TEST6_DIM2/) 1552 1553 INTEGER :: encoding 1554 INTEGER :: error 1555 LOGICAL :: Lexists 1556 INTEGER(HSIZE_T), DIMENSION(1:2), PARAMETER :: extend_dim = (/TEST6_DIM1-2,TEST6_DIM2-3/) 1557 INTEGER(HSIZE_T), DIMENSION(1:2) :: dimsout, maxdimsout ! dimensions 1558 1559 INTEGER :: i 1560 INTEGER :: tmp1, tmp2 1561 INTEGER(HID_T) :: crp_list 1562 1563! WRITE(*,*) "link creation property lists (w/new group format)" 1564 1565 1566 ! Actually, intermediate group creation is tested elsewhere (tmisc). 1567 ! * Here we only need to test the character encoding property 1568 1569 ! Create file 1570 ! h5_fixname(FILENAME[0], fapl, filename, sizeof filename); 1571 1572 CALL H5Fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error, H5P_DEFAULT_F, fapl) 1573 CALL check("H5Fcreate_f", error, total_error) 1574 1575 1576 ! Create and link a group with the default LCPL 1577 1578 CALL H5Gcreate_f(file_id, "/group", group_id, error) 1579 CALL check("H5Gcreate_f", error, total_error) 1580 1581 1582 ! Check that its character encoding is the default 1583 1584 CALL H5Lget_info_f(file_id, "group", & 1585 cset, corder, f_corder_valid, link_type, address, val_size, & 1586 error, H5P_DEFAULT_F) 1587 1588! File-wide default character encoding can not yet be set via the file 1589! * creation property list and is always ASCII. 1590!#define H5F_DEFAULT_CSET H5T_CSET_ASCII -- FROM H5Fprivate.h -- 1591 1592 CALL VERIFY("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) 1593 1594 ! Create and commit a datatype with the default LCPL 1595 CALL h5tcopy_f(H5T_NATIVE_INTEGER, type_id, error) 1596 CALL check("h5tcopy_f",error,total_error) 1597 CALL h5tcommit_f(file_id, "/type", type_id, error) 1598 CALL check("h5tcommit_f", error, total_error) 1599 CALL h5tclose_f(type_id, error) 1600 CALL check("h5tclose_f", error, total_error) 1601 1602 1603 ! Check that its character encoding is the default 1604 CALL H5Lget_info_f(file_id, "type", & 1605 cset, corder, f_corder_valid, link_type, address, val_size, & 1606 error) 1607 CALL check("h5tclose_f", error, total_error) 1608 1609! File-wide default character encoding can not yet be set via the file 1610! * creation property list and is always ASCII. 1611!#define H5F_DEFAULT_CSET H5T_CSET_ASCII -- FROM H5Fprivate.h -- 1612 1613 CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) 1614 1615 ! Create a dataspace 1616 CALL h5screate_simple_f(2, dims, space_id, error) 1617 CALL check("h5screate_simple_f",error,total_error) 1618 CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) 1619 CALL h5pset_chunk_f(crp_list, 2, dims, error) 1620 CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) 1621 CALL h5pset_chunk_f(crp_list, 2, dims, error) 1622 CALL h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, error) 1623 CALL h5pset_chunk_f(crp_list, 2, dims, error) 1624 1625 ! Create a dataset using the default LCPL 1626 CALL h5dcreate_f(file_id, "/dataset", H5T_NATIVE_INTEGER, space_id, dset_id, error, crp_list) 1627 CALL check("h5dcreate_f", error, total_error) 1628 1629 CALL h5dclose_f(dset_id, error) 1630 CALL check("h5dclose_f", error, total_error) 1631 1632 ! Reopen 1633 1634 CALL H5Dopen_f(file_id, "/dataset", dset_id, error) 1635 CALL check("h5dopen_f", error, total_error) 1636 1637 ! Extend the dataset 1638 CALL H5Dset_extent_f(dset_id, extend_dim, error) 1639 CALL check("H5Dset_extent_f", error, total_error) 1640 ! Verify the dataspaces 1641 ! 1642 !Get dataset's dataspace handle. 1643 ! 1644 CALL h5dget_space_f(dset_id, data_space, error) 1645 CALL check("h5dget_space_f",error,total_error) 1646 1647 CALL h5sget_simple_extent_dims_f(data_space, dimsout, maxdimsout, error) 1648 CALL check("h5sget_simple_extent_dims_f",error, total_error) 1649 1650 DO i = 1, 2 1651 tmp1 = INT(dimsout(i)) 1652 tmp2 = INT(extend_dim(i)) 1653 CALL VERIFY("H5Sget_simple_extent_dims", tmp1, tmp2, total_error) 1654 tmp1 = INT(maxdimsout(i)) 1655 tmp2 = INT(dims(i)) 1656 CALL VERIFY("H5Sget_simple_extent_dims", tmp1, tmp2, total_error) 1657 ENDDO 1658 1659 ! close data set 1660 1661 CALL h5dclose_f(dset_id, error) 1662 CALL check("h5dclose_f", error, total_error) 1663 1664 ! Check that its character encoding is the default 1665 CALL H5Lget_info_f(file_id, "dataset", & 1666 cset, corder, f_corder_valid, link_type, address, val_size, & 1667 error) 1668 CALL check("H5Lget_info_f", error, total_error) 1669 1670! File-wide default character encoding can not yet be set via the file 1671! * creation property list and is always ASCII. 1672!#define H5F_DEFAULT_CSET H5T_CSET_ASCII -- FROM H5Fprivate.h -- 1673 1674 CALL verify("h5tclose_f",cset, H5T_CSET_ASCII_F,total_error) 1675 1676 ! Create a link creation property list with the UTF-8 character encoding 1677 CALL H5Pcreate_f(H5P_LINK_CREATE_F,lcpl_id,error) 1678 CALL check("h5Pcreate_f",error,total_error) 1679 CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) 1680 CALL check("H5Pset_char_encoding_f",error, total_error) 1681 1682 ! Create and link a group with the new LCPL 1683 CALL H5Gcreate_f(file_id, "/group2", group_id, error,lcpl_id=lcpl_id) 1684 CALL check("H5Gcreate_f", error, total_error) 1685 CALL H5Gclose_f(group_id, error) 1686 CALL check("H5Gclose_f", error, total_error) 1687 1688 1689 ! Check that its character encoding is UTF-8 1690 CALL H5Lget_info_f(file_id, "group2", & 1691 cset, corder, f_corder_valid, link_type, address, val_size, & 1692 error) 1693 CALL check("H5Lget_info_f", error, total_error) 1694 CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) 1695 1696 1697 ! Create and commit a datatype with the new LCPL 1698 1699 CALL h5tcopy_f(H5T_NATIVE_INTEGER, type_id, error) 1700 CALL check("h5tcopy_f",error,total_error) 1701 CALL h5tcommit_f(file_id, "/type2", type_id, error, lcpl_id=lcpl_id) 1702 CALL check("h5tcommit_f", error, total_error) 1703 CALL h5tclose_f(type_id, error) 1704 CALL check("h5tclose_f", error, total_error) 1705 1706 1707 ! Check that its character encoding is UTF-8 1708 CALL H5Lget_info_f(file_id, "type2", & 1709 cset, corder, f_corder_valid, link_type, address, val_size, & 1710 error) 1711 CALL check("H5Lget_info_f", error, total_error) 1712 CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) 1713 1714 ! Create a dataset using the new LCPL 1715 CALL h5dcreate_f(file_id, "/dataset2", H5T_NATIVE_INTEGER, space_id, dset_id, error,lcpl_id=lcpl_id) 1716 CALL check("h5dcreate_f", error, total_error) 1717 1718 CALL h5dclose_f(dset_id, error) 1719 CALL check("h5dclose_f", error, total_error) 1720 1721 CALL H5Pget_char_encoding_f(lcpl_id, encoding, error) 1722 CALL check("H5Pget_char_encoding_f", error, total_error) 1723 CALL VERIFY("H5Pget_char_encoding_f", encoding, H5T_CSET_UTF8_F, total_error) 1724 1725 ! Check that its character encoding is UTF-8 1726 CALL H5Lget_info_f(file_id, "dataset2", & 1727 cset, corder, f_corder_valid, link_type, address, val_size, & 1728 error) 1729 CALL check("H5Lget_info_f", error, total_error) 1730 CALL verify("H5Lget_info_f2",cset, H5T_CSET_UTF8_F,total_error) 1731 1732 ! Create a new link to the dataset with a different character encoding. 1733 CALL H5Pclose_f(lcpl_id, error) 1734 CALL check("H5Pclose_f", error, total_error) 1735 1736 CALL H5Pcreate_f(H5P_LINK_CREATE_F,lcpl_id,error) 1737 CALL check("h5Pcreate_f",error,total_error) 1738 CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_ASCII_F, error) 1739 CALL check("H5Pset_char_encoding_f",error, total_error) 1740 CALL H5Lcreate_hard_f(file_id, "/dataset2", file_id, "/dataset2_link", error, lcpl_id) 1741 CALL check("H5Lcreate_hard_f",error, total_error) 1742 1743 CALL H5Lexists_f(file_id,"/dataset2_link",Lexists, error) 1744 CALL check("H5Lexists",error, total_error) 1745 CALL verifylogical("H5Lexists", Lexists,.TRUE.,total_error) 1746 1747 ! Check that its character encoding is ASCII 1748 CALL H5Lget_info_f(file_id, "/dataset2_link", & 1749 cset, corder, f_corder_valid, link_type, address, val_size, & 1750 error) 1751 CALL check("H5Lget_info_f", error, total_error) 1752 CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) 1753 1754 ! Check that the first link's encoding hasn't changed 1755 1756 CALL H5Lget_info_f(file_id, "/dataset2", & 1757 cset, corder, f_corder_valid, link_type, address, val_size, & 1758 error) 1759 CALL check("H5Lget_info_f", error, total_error) 1760 CALL verify("H5Lget_info_f3",cset, H5T_CSET_UTF8_F,total_error) 1761 1762 1763 ! Make sure that LCPLs work properly for other API calls: 1764 ! H5Lcreate_soft 1765 1766 CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) 1767 CALL check("H5Pset_char_encoding_f",error, total_error) 1768 CALL H5Lcreate_soft_f("dataset2", file_id, "slink_to_dset2",error,lcpl_id) 1769 CALL check("H5Lcreate_soft_f", error, total_error) 1770 1771 CALL H5Lget_info_f(file_id, "slink_to_dset2", & 1772 cset, corder, f_corder_valid, link_type, address, val_size, & 1773 error) 1774 CALL check("H5Lget_info_f", error, total_error) 1775 CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) 1776 1777 1778 ! H5Lmove 1779 CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_ASCII_F, error) 1780 CALL check("H5Pset_char_encoding_f",error, total_error) 1781 1782 CALL H5Lmove_f(file_id, "slink_to_dset2", file_id, "moved_slink", error, lcpl_id, H5P_DEFAULT_F) 1783 CALL check("H5Lmove_f",error, total_error) 1784 1785 CALL H5Lget_info_f(file_id, "moved_slink", & 1786 cset, corder, f_corder_valid, link_type, address, val_size, & 1787 error) 1788 CALL check("H5Lget_info_f", error, total_error) 1789 CALL verify("H5Lget_info_f",cset, H5T_CSET_ASCII_F,total_error) 1790 1791 1792 ! H5Lcopy 1793 1794 CALL H5Pset_char_encoding_f(lcpl_id, H5T_CSET_UTF8_F, error) 1795 CALL check("H5Pset_char_encoding_f",error, total_error) 1796 1797 CALL H5Lcopy_f(file_id, "moved_slink", file_id, "copied_slink", error, lcpl_id) 1798 1799 CALL H5Lget_info_f(file_id, "copied_slink", & 1800 cset, corder, f_corder_valid, link_type, address, val_size, & 1801 error) 1802 CALL check("H5Lget_info_f", error, total_error) 1803 CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) 1804 1805 1806 ! H5Lcreate_external 1807 1808 CALL H5Lcreate_external_f("filename", "path", file_id, "extlink", error, lcpl_id) 1809 CALL check("H5Lcreate_external_f", error, total_error) 1810 1811 CALL H5Lget_info_f(file_id, "extlink", & 1812 cset, corder, f_corder_valid, link_type, address, val_size, & 1813 error) 1814 CALL check("H5Lget_info_f", error, total_error) 1815 CALL verify("H5Lget_info_f",cset, H5T_CSET_UTF8_F,total_error) 1816 1817 1818 ! Close open IDs 1819 1820 CALL H5Pclose_f(lcpl_id, error) 1821 CALL check("H5Pclose_f", error, total_error) 1822 CALL H5Sclose_f(space_id, error) 1823 CALL check("h5Sclose_f",error,total_error) 1824 CALL H5Fclose_f(file_id, error) 1825 CALL check("H5Fclose_f", error, total_error) 1826 1827 IF(cleanup) CALL h5_cleanup_f("tempfile", H5P_DEFAULT_F, error) 1828 CALL check("h5_cleanup_f", error, total_error) 1829 1830 1831END SUBROUTINE test_lcpl 1832 1833SUBROUTINE objcopy(fapl, total_error) 1834 1835 USE HDF5 ! This module contains all necessary modules 1836 USE TH5_MISC 1837 1838 IMPLICIT NONE 1839 INTEGER, INTENT(INOUT) :: total_error 1840 INTEGER(HID_T), INTENT(IN) :: fapl 1841 1842 INTEGER(HID_T) :: fapl2, pid 1843 1844 INTEGER :: flag, cpy_flags 1845 1846 INTEGER :: error 1847 1848 flag = H5O_COPY_SHALLOW_HIERARCHY_F 1849 1850! Copy the file access property list 1851 CALL H5Pcopy_f(fapl, fapl2, error) 1852 CALL check("H5Pcopy_f", error, total_error) 1853 1854! Set the "use the latest version of the format" bounds for creating objects in the file 1855 CALL H5Pset_libver_bounds_f(fapl2, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error) 1856 1857 ! create property to pass copy options 1858 CALL h5pcreate_f(H5P_OBJECT_COPY_F, pid, error) 1859 CALL check("h5pcreate_f",error, total_error) 1860 1861 ! set options for object copy 1862 CALL H5Pset_copy_object_f(pid, flag, error) 1863 CALL check("H5Pset_copy_object_f",error, total_error) 1864 1865 ! Verify object copy flags 1866 CALL H5Pget_copy_object_f(pid, cpy_flags, error) 1867 CALL check("H5Pget_copy_object_f",error, total_error) 1868 CALL VERIFY("H5Pget_copy_object_f", cpy_flags, flag, total_error) 1869 1870!!$ 1871!!$ CALL test_copy_option(fcpl_src, fcpl_dst, my_fapl, H5O_COPY_WITHOUT_ATTR_FLAG, 1872!!$ FALSE, "H5Ocopy(): without attributes"); 1873 1874 CALL lapl_nlinks(fapl2, total_error) 1875 1876END SUBROUTINE objcopy 1877 1878 1879!------------------------------------------------------------------------- 1880! * Function: lapl_nlinks 1881! * 1882! * Purpose: Check that the maximum number of soft links can be adjusted 1883! * by the user using the Link Access Property List. 1884! * 1885! * Return: Success: 0 1886! * 1887! * Failure: -1 1888! * 1889! * Programmer: James Laird 1890! * Tuesday, June 6, 2006 1891! * 1892! * Modifications: 1893! * 1894! *------------------------------------------------------------------------- 1895! 1896 1897SUBROUTINE lapl_nlinks( fapl, total_error) 1898 1899 USE HDF5 1900 USE TH5_MISC 1901 1902 IMPLICIT NONE 1903 INTEGER(HID_T), INTENT(IN) :: fapl 1904 INTEGER, INTENT(INOUT) :: total_error 1905 1906 INTEGER :: error 1907 1908 INTEGER(HID_T) :: fid = (-1) ! File ID 1909 INTEGER(HID_T) :: gid = (-1), gid2 = (-1) ! Group IDs 1910 INTEGER(HID_T) :: plist = (-1) ! lapl ID 1911 INTEGER(HID_T) :: tid = (-1) ! Other IDs 1912 INTEGER(HID_T) :: gapl = (-1), dapl = (-1), tapl = (-1) ! Other property lists 1913 1914 CHARACTER(LEN=7) :: objname ! Object name 1915 INTEGER(size_t) :: name_len ! Length of object name 1916 CHARACTER(LEN=12) :: filename = 'TestLinks.h5' 1917 INTEGER(size_t) :: nlinks ! nlinks for H5Pset_nlinks 1918 INTEGER(size_t) :: buf_size = 7 1919 1920! WRITE(*,*) "adjusting nlinks with LAPL (w/new group format)" 1921 1922 1923 ! Create file 1924 CALL h5fcreate_f(FileName, H5F_ACC_TRUNC_F, fid, error, access_prp=fapl) 1925 CALL check(" lapl_nlinks.h5fcreate_f",error,total_error) 1926 1927 ! Create group with short name in file (used as target for links) 1928 CALL H5Gcreate_f(fid, "final", gid, error) 1929 CALL check(" lapl_nlinks.H5Gcreate_f", error, total_error) 1930 1931 ! Create chain of soft links to existing object (limited) 1932 CALL H5Lcreate_soft_f("final", fid, "soft1", error) 1933 CALL H5Lcreate_soft_f("soft1", fid, "soft2", error) 1934 CALL H5Lcreate_soft_f("soft2", fid, "soft3", error) 1935 CALL H5Lcreate_soft_f("soft3", fid, "soft4", error) 1936 CALL H5Lcreate_soft_f("soft4", fid, "soft5", error) 1937 CALL H5Lcreate_soft_f("soft5", fid, "soft6", error) 1938 CALL H5Lcreate_soft_f("soft6", fid, "soft7", error) 1939 CALL H5Lcreate_soft_f("soft7", fid, "soft8", error) 1940 CALL H5Lcreate_soft_f("soft8", fid, "soft9", error) 1941 CALL H5Lcreate_soft_f("soft9", fid, "soft10", error) 1942 CALL H5Lcreate_soft_f("soft10", fid, "soft11", error) 1943 CALL H5Lcreate_soft_f("soft11", fid, "soft12", error) 1944 CALL H5Lcreate_soft_f("soft12", fid, "soft13", error) 1945 CALL H5Lcreate_soft_f("soft13", fid, "soft14", error) 1946 CALL H5Lcreate_soft_f("soft14", fid, "soft15", error) 1947 CALL H5Lcreate_soft_f("soft15", fid, "soft16", error) 1948 CALL H5Lcreate_soft_f("soft16", fid, "soft17", error) 1949 1950 ! Close objects 1951 CALL H5Gclose_f(gid, error) 1952 CALL check("h5gclose_f",error,total_error) 1953 CALL h5fclose_f(fid, error) 1954 CALL check("h5fclose_f",error,total_error) 1955 1956 ! Open file 1957 1958 CALL h5fopen_f(FileName, H5F_ACC_RDWR_F, fid, error, fapl) 1959 CALL check("h5open_f",error,total_error) 1960 1961 ! Create LAPL with higher-than-usual nlinks value 1962 ! Create a non-default lapl with udata set to point to the first group 1963 1964 CALL H5Pcreate_f(H5P_LINK_ACCESS_F,plist,error) 1965 CALL check("h5Pcreate_f",error,total_error) 1966 nlinks = 20 1967 CALL H5Pset_nlinks_f(plist, nlinks, error) 1968 CALL check("H5Pset_nlinks_f",error,total_error) 1969 ! Ensure that nlinks was set successfully 1970 nlinks = 0 1971 CALL H5Pget_nlinks_f(plist, nlinks, error) 1972 CALL check("H5Pset_nlinks_f",error,total_error) 1973 CALL VERIFY("H5Pset_nlinks_f",INT(nlinks), 20, total_error) 1974 1975 1976 ! Open object through what is normally too many soft links using 1977 ! * new property list 1978 1979 CALL H5Oopen_f(fid,"soft17",gid,error,plist) 1980 CALL check("H5Oopen_f",error,total_error) 1981 1982 ! Check name 1983 CALL h5iget_name_f(gid, objname, buf_size, name_len, error) 1984 CALL check("h5iget_name_f",error,total_error) 1985 CALL VerifyString("h5iget_name_f", TRIM(objname),"/soft17", total_error) 1986 ! Create group using soft link 1987 CALL H5Gcreate_f(gid, "new_soft", gid2, error) 1988 CALL check("H5Gcreate_f", error, total_error) 1989 1990 ! Close groups 1991 CALL H5Gclose_f(gid2, error) 1992 CALL check("H5Gclose_f", error, total_error) 1993 CALL H5Gclose_f(gid, error) 1994 CALL check("H5Gclose_f", error, total_error) 1995 1996 1997 ! Set nlinks to a smaller number 1998 nlinks = 4 1999 CALL H5Pset_nlinks_f(plist, nlinks, error) 2000 CALL check("H5Pset_nlinks_f", error, total_error) 2001 2002 ! Ensure that nlinks was set successfully 2003 nlinks = 0 2004 2005 CALL H5Pget_nlinks_f(plist, nlinks, error) 2006 CALL check("H5Pget_nlinks_f",error,total_error) 2007 CALL VERIFY("H5Pget_nlinks_f", INT(nlinks), 4, total_error) 2008 2009 ! Try opening through what is now too many soft links 2010 2011 CALL H5Oopen_f(fid,"soft5",gid,error,plist) 2012 CALL VERIFY("H5Oopen_f", error, -1, total_error) ! should fail 2013 2014 ! Open object through lesser soft link 2015 CALL H5Oopen_f(fid,"soft4",gid,error,plist) 2016 CALL check("H5Oopen_",error,total_error) 2017 2018 ! Check name 2019 CALL h5iget_name_f(gid, objname, buf_size, name_len, error) 2020 CALL check("h5iget_name_f",error,total_error) 2021 CALL VerifyString("h5iget_name_f", TRIM(objname),"/soft4", total_error) 2022 2023 ! Test other functions that should use a LAPL 2024 nlinks = 20 2025 CALL H5Pset_nlinks_f(plist, nlinks, error) 2026 CALL check("H5Pset_nlinks_f", error, total_error) 2027 2028 ! Try copying and moving when both src and dst contain many soft links 2029 ! * using a non-default LAPL 2030 ! 2031 CALL H5Lcopy_f(fid, "soft17", fid, "soft17/newer_soft", error, H5P_DEFAULT_F, plist) 2032 CALL check("H5Lcopy_f",error,total_error) 2033 2034 CALL H5Lmove_f(fid, "soft17/newer_soft", fid, "soft17/newest_soft", error, lapl_id=plist) 2035 CALL check("H5Lmove_f",error, total_error) 2036 2037 ! H5Olink 2038 CALL H5Olink_f(gid, fid, "soft17/link_to_group", error, H5P_DEFAULT_F, plist) 2039 CALL check("H5Olink_f", error, total_error) 2040 2041 ! H5Lcreate_hard and H5Lcreate_soft 2042 CALL H5Lcreate_hard_f(fid, "soft17", fid, "soft17/link2_to_group", error, H5P_DEFAULT_F, plist) 2043 CALL check("H5Lcreate_hard_f", error, total_error) 2044 2045 2046 CALL H5Lcreate_soft_f("/soft4", fid, "soft17/soft_link",error, H5P_DEFAULT_F, plist) 2047 CALL check("H5Lcreate_soft_f", error, total_error) 2048 2049 ! H5Ldelete 2050 CALL h5ldelete_f(fid, "soft17/soft_link", error, plist) 2051 CALL check("H5Ldelete_f", error, total_error) 2052 2053!!$ H5Lget_val and H5Lget_info 2054!!$ if(H5Lget_val(fid, "soft17", NULL, (size_t)0, plist) < 0) TEST_ERROR 2055!!$ if(H5Lget_info(fid, "soft17", NULL, plist) < 0) TEST_ERROR 2056!!$ 2057 2058 ! H5Lcreate_external and H5Lcreate_ud 2059 CALL H5Lcreate_external_f("filename", "path", fid, "soft17/extlink", error, H5P_DEFAULT_F, plist) 2060 CALL check("H5Lcreate_external_f", error, total_error) 2061 2062!!$ if(H5Lregister(UD_rereg_class) < 0) TEST_ERROR 2063!!$ if(H5Lcreate_ud(fid, "soft17/udlink", UD_HARD_TYPE, NULL, (size_t)0, H5P_DEFAULT, plist) < 0) TEST_ERROR 2064!!$ 2065 ! Close plist 2066 CALL h5pclose_f(plist, error) 2067 CALL check("h5pclose_f", error, total_error) 2068 2069 ! Create a datatype and dataset as targets inside the group 2070 CALL h5tcopy_f(H5T_NATIVE_INTEGER, tid, error) 2071 CALL check("h5tcopy_f",error,total_error) 2072 CALL h5tcommit_f(gid, "datatype", tid, error) 2073 CALL check("h5tcommit_f", error, total_error) 2074 CALL h5tclose_f(tid, error) 2075 CALL check("h5tclose_f", error, total_error) 2076 2077!!$ 2078!!$ dims[0] = 2; 2079!!$ dims[1] = 2; 2080!!$ if((sid = H5Screate_simple(2, dims, NULL)) < 0) TEST_ERROR 2081!!$ if((did = H5Dcreate2(gid, "dataset", H5T_NATIVE_INT, sid, H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT)) < 0) TEST_ERROR 2082!!$ if(H5Dclose(did) < 0) TEST_ERROR 2083!!$ 2084 ! Close group 2085 CALL h5gclose_f(gid, error) 2086 CALL check("h5gclose_f",error,total_error) 2087 2088!!$ 2089!!$ Try to open the objects using too many symlinks with default *APLs 2090!!$ H5E_BEGIN_TRY { 2091!!$ if((gid = H5Gopen2(fid, "soft17", H5P_DEFAULT)) >= 0) 2092!!$ FAIL_PUTS_ERROR(" Should have failed for too many nested links.") 2093!!$ if((tid = H5Topen2(fid, "soft17/datatype", H5P_DEFAULT)) >= 0) 2094!!$ FAIL_PUTS_ERROR(" Should have failed for too many nested links.") 2095!!$ if((did = H5Dopen2(fid, "soft17/dataset", H5P_DEFAULT)) >= 0) 2096!!$ FAIL_PUTS_ERROR(" Should have failed for too many nested links.") 2097!!$ } H5E_END_TRY 2098!!$ 2099 ! Create property lists with nlinks set 2100 2101 CALL H5Pcreate_f(H5P_GROUP_ACCESS_F,gapl,error) 2102 CALL check("h5Pcreate_f",error,total_error) 2103 CALL H5Pcreate_f(H5P_DATATYPE_ACCESS_F,tapl,error) 2104 CALL check("h5Pcreate_f",error,total_error) 2105 CALL H5Pcreate_f(H5P_DATASET_ACCESS_F,dapl,error) 2106 CALL check("h5Pcreate_f",error,total_error) 2107 2108 2109 nlinks = 20 2110 CALL H5Pset_nlinks_f(gapl, nlinks, error) 2111 CALL check("H5Pset_nlinks_f", error, total_error) 2112 CALL H5Pset_nlinks_f(tapl, nlinks, error) 2113 CALL check("H5Pset_nlinks_f", error, total_error) 2114 CALL H5Pset_nlinks_f(dapl, nlinks, error) 2115 CALL check("H5Pset_nlinks_f", error, total_error) 2116 2117 ! We should now be able to use these property lists to open each kind 2118 ! * of object. 2119 ! 2120 2121 CALL H5Gopen_f(fid, "soft17", gid, error, gapl) 2122 CALL check("H5Gopen_f",error,total_error) 2123 2124 CALL H5Topen_f(fid, "soft17/datatype", tid, error, tapl) 2125 CALL check("H5Gopen_f",error,total_error) 2126 2127!!$ if((did = H5Dopen2(fid, "soft17/dataset", dapl)) < 0) TEST_ERROR 2128 2129 ! Close objects 2130 2131 CALL h5gclose_f(gid, error) 2132 CALL check("h5gclose_f",error,total_error) 2133 CALL h5tclose_f(tid, error) 2134 CALL check("h5tclose_f", error, total_error) 2135 2136!!$ if(H5Dclose(did) < 0) TEST_ERROR 2137!!$ 2138 ! Close plists 2139 2140 CALL h5pclose_f(gapl, error) 2141 CALL check("h5pclose_f", error, total_error) 2142 CALL h5pclose_f(tapl, error) 2143 CALL check("h5pclose_f", error, total_error) 2144 2145!!$ if(H5Pclose(dapl) < 0) TEST_ERROR 2146!!$ 2147!!$ Unregister UD hard link class 2148!!$ if(H5Lunregister(UD_HARD_TYPE) < 0) TEST_ERROR 2149!!$ 2150 2151 ! Close file 2152 CALL H5Fclose_f(fid, error) 2153 CALL check("H5Fclose_f", error, total_error) 2154 2155END SUBROUTINE lapl_nlinks 2156 2157END MODULE TH5G_1_8 2158