mirror of
https://github.com/HDFGroup/hdf5.git
synced 2024-12-15 07:40:23 +08:00
89fbe00dec
* commit '54957d37f5aa73912763dbb6e308555e863c43f4': Commit copyright header change for src/H5PLpkg.c which was added after running script to make changes. Add new files in release_docs to MANIFEST. Cimmit changes to Makefile.in(s) and H5PL.c that resulted from running autogen.sh. Merge pull request #407 in HDFFV/hdf5 from ~LRKNOX/hdf5_lrk:hdf5_1_10_1 to hdf5_1_10_1 Change copyright headers to replace url referring to file to be removed and replace it with new url for COPYING file.
468 lines
16 KiB
Fortran
468 lines
16 KiB
Fortran
!****h* root/fortran/test/tH5MISC_1_8.f90
|
|
!
|
|
! NAME
|
|
! tH5MISC_1_8.f90
|
|
!
|
|
! FUNCTION
|
|
! Basic testing of Fortran API's introduced in 1.8 release.
|
|
!
|
|
! COPYRIGHT
|
|
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
! Copyright by The HDF Group. *
|
|
! Copyright by the Board of Trustees of the University of Illinois. *
|
|
! All rights reserved. *
|
|
! *
|
|
! This file is part of HDF5. The full HDF5 copyright notice, including *
|
|
! terms governing use, modification, and redistribution, is contained in *
|
|
! the COPYING file, which can be found at the root of the source code *
|
|
! distribution tree, or in https://support.hdfgroup.org/ftp/HDF5/releases. *
|
|
! If you do not have access to either file, you may request a copy from *
|
|
! help@hdfgroup.org. *
|
|
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
!
|
|
!*****
|
|
MODULE TH5MISC_1_8
|
|
|
|
USE HDF5 ! This module contains all necessary modules
|
|
USE TH5_MISC
|
|
USE TH5_MISC_GEN
|
|
|
|
CONTAINS
|
|
|
|
SUBROUTINE dtransform(cleanup, total_error)
|
|
|
|
IMPLICIT NONE
|
|
LOGICAL, INTENT(IN) :: cleanup
|
|
INTEGER, INTENT(INOUT) :: total_error
|
|
|
|
INTEGER(HID_T) :: dxpl_id_c_to_f
|
|
INTEGER(HID_T) :: file_id
|
|
|
|
CHARACTER(LEN=15), PARAMETER :: c_to_f = "(9/5.0)*x + 123"
|
|
INTEGER :: error
|
|
CHARACTER(LEN=15) :: ptrgetTest
|
|
CHARACTER(LEN=7) :: ptrgetTest_small
|
|
CHARACTER(LEN=30) :: ptrgetTest_big
|
|
|
|
INTEGER(SIZE_T) :: size
|
|
|
|
CALL H5Fcreate_f("dtransform.h5", H5F_ACC_TRUNC_F, file_id, error)
|
|
CALL check("dtransform.H5Fcreate_f", error, total_error)
|
|
|
|
CALL H5Pcreate_f(H5P_DATASET_XFER_F, dxpl_id_c_to_f, error)
|
|
CALL check("dtransform.H5Pcreate_f", error, total_error)
|
|
|
|
CALL H5Pset_data_transform_f(dxpl_id_c_to_f, c_to_f, error)
|
|
CALL check("dtransform.H5Pset_data_transform_f", error, total_error)
|
|
|
|
CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest, error, size=size)
|
|
CALL check("dtransform.H5Pget_data_transform_f", error, total_error)
|
|
CALL verify("dtransform.H5Pget_data_transform_f", c_to_f, ptrgetTest, total_error)
|
|
CALL verify("dtransform.H5Pget_data_transform_f", INT(size),15, total_error)
|
|
|
|
! check case when receiving buffer to small
|
|
|
|
CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest_small, error, size=size)
|
|
CALL check("dtransform.H5Pget_data_transform_f", error, total_error)
|
|
CALL verify("dtransform.H5Pget_data_transform_f", c_to_f(1:7), ptrgetTest_small, total_error)
|
|
CALL verify("dtransform.H5Pget_data_transform_f", INT(size),15, total_error)
|
|
|
|
! check case when receiving buffer to big
|
|
|
|
CALL H5Pget_data_transform_f(dxpl_id_c_to_f, ptrgetTest_big, error, size=size)
|
|
CALL check("dtransform.H5Pget_data_transform_f", error, total_error)
|
|
CALL verify("dtransform.H5Pget_data_transform_f", c_to_f(1:15), ptrgetTest_big(1:15), total_error)
|
|
CALL verify("dtransform.H5Pget_data_transform_f", INT(size), 15, total_error)
|
|
|
|
CALL H5Fclose_f(file_id, error)
|
|
CALL check("H5Fclose_f", error, total_error)
|
|
|
|
IF(cleanup) CALL h5_cleanup_f("dtransform", H5P_DEFAULT_F, error)
|
|
CALL check("h5_cleanup_f", error, total_error)
|
|
|
|
END SUBROUTINE dtransform
|
|
|
|
|
|
!***************************************************************
|
|
!**
|
|
!** test_genprop_basic_class(): Test basic generic property list code.
|
|
!** Tests creating new generic classes.
|
|
!**
|
|
!***************************************************************
|
|
|
|
SUBROUTINE test_genprop_basic_class(total_error)
|
|
|
|
IMPLICIT NONE
|
|
INTEGER, INTENT(INOUT) :: total_error
|
|
|
|
INTEGER(HID_T) :: cid1 ! Generic Property class ID
|
|
INTEGER(HID_T) :: cid2 ! Generic Property class ID
|
|
|
|
CHARACTER(LEN=7) :: CLASS1_NAME = "Class 1"
|
|
CHARACTER(LEN=7) :: name ! Name of class
|
|
CHARACTER(LEN=10) :: name_big ! Name of class bigger buffer
|
|
CHARACTER(LEN=4) :: name_small ! Name of class smaller buffer
|
|
INTEGER :: error
|
|
INTEGER :: size
|
|
LOGICAL :: flag
|
|
|
|
! Output message about test being performed
|
|
|
|
!WRITE(*,*) "Testing Basic Generic Property List Class Creation Functionality"
|
|
|
|
! Try some bogus value for class identifier; function should fail gracefully
|
|
|
|
cid1 = 456
|
|
CALL H5Pget_class_name_f(cid1, name, size, error)
|
|
CALL verify("H5Pget_class_name", error, -1, error)
|
|
|
|
! Create a new generic class, derived from the root of the class hierarchy
|
|
CALL H5Pcreate_class_f(H5P_ROOT_F, CLASS1_NAME, cid1, error)
|
|
CALL check("H5Pcreate_class", error, total_error)
|
|
|
|
! Check class name
|
|
CALL H5Pget_class_name_f(cid1, name, size, error)
|
|
CALL check("H5Pget_class_name", error, total_error)
|
|
CALL verify("H5Pget_class_name", size,7,error)
|
|
CALL verify("H5Pget_class_name", name, CLASS1_NAME, error)
|
|
IF(error.NE.0)THEN
|
|
WRITE(*,*) 'Class names do not match! name=',name, 'CLASS1_NAME=',CLASS1_NAME
|
|
total_error = total_error + 1
|
|
ENDIF
|
|
|
|
! Check class name smaller buffer
|
|
CALL H5Pget_class_name_f(cid1, name_small, size, error)
|
|
CALL check("H5Pget_class_name", error, total_error)
|
|
CALL verify("H5Pget_class_name", size,7,error)
|
|
CALL verify("H5Pget_class_name", name_small(1:4), CLASS1_NAME(1:4), error)
|
|
IF(error.NE.0)THEN
|
|
WRITE(*,*) 'Class names do not match! name=',name_small(1:4), 'CLASS1_NAME=',CLASS1_NAME(1:4)
|
|
total_error = total_error + 1
|
|
ENDIF
|
|
|
|
! Check class name bigger buffer
|
|
CALL H5Pget_class_name_f(cid1, name_big, size, error)
|
|
CALL check("H5Pget_class_name", error, total_error)
|
|
CALL verify("H5Pget_class_name", size,7,error)
|
|
CALL verify("H5Pget_class_name", TRIM(name_big), TRIM(CLASS1_NAME), error)
|
|
IF(error.NE.0)THEN
|
|
WRITE(*,*) 'Class names do not match! name=',TRIM(name_small), 'CLASS1_NAME=',TRIM(CLASS1_NAME)
|
|
total_error = total_error + 1
|
|
ENDIF
|
|
|
|
! Check class parent
|
|
CALL H5Pget_class_parent_f(cid1, cid2, error)
|
|
CALL check("H5Pget_class_parent_f", error, total_error)
|
|
|
|
! Verify class parent correct
|
|
CALL H5Pequal_f(cid2, H5P_ROOT_F, flag, error)
|
|
CALL check("H5Pequal_f", error, total_error)
|
|
CALL verify("H5Pequal_f", flag, .TRUE., total_error)
|
|
|
|
|
|
! Make certain false postives aren't being returned
|
|
CALL H5Pequal_f(cid2, H5P_FILE_CREATE_F, flag, error)
|
|
CALL check("H5Pequal_f", error, total_error)
|
|
CALL verify("H5Pequal_f", flag, .FALSE., total_error)
|
|
|
|
! Close parent class
|
|
CALL H5Pclose_class_f(cid2, error)
|
|
CALL check("H5Pclose_class_f", error, total_error)
|
|
|
|
|
|
! Close class
|
|
CALL H5Pclose_class_f(cid1, error)
|
|
CALL check("H5Pclose_class_f", error, total_error)
|
|
|
|
END SUBROUTINE test_genprop_basic_class
|
|
|
|
SUBROUTINE test_h5s_encode(total_error)
|
|
|
|
!***************************************************************
|
|
!**
|
|
!** test_h5s_encode(): Test H5S (dataspace) encoding and decoding.
|
|
!**
|
|
!***************************************************************
|
|
|
|
IMPLICIT NONE
|
|
INTEGER, INTENT(INOUT) :: total_error
|
|
|
|
INTEGER(hid_t) :: sid1, sid3! Dataspace ID
|
|
INTEGER(hid_t) :: decoded_sid1, decoded_sid3
|
|
INTEGER :: rank ! LOGICAL rank of dataspace
|
|
INTEGER(size_t) :: sbuf_size=0, scalar_size=0
|
|
|
|
! Make sure the size is large
|
|
CHARACTER(LEN=288) :: sbuf
|
|
CHARACTER(LEN=288) :: scalar_buf
|
|
|
|
INTEGER(hsize_t) :: n ! Number of dataspace elements
|
|
|
|
INTEGER(hsize_t), DIMENSION(1:3) :: start = (/0, 0, 0/)
|
|
INTEGER(hsize_t), DIMENSION(1:3) :: stride = (/2, 5, 3/)
|
|
INTEGER(hsize_t), DIMENSION(1:3) :: count = (/2, 2, 2/)
|
|
INTEGER(hsize_t), DIMENSION(1:3) :: BLOCK = (/1, 3, 1/)
|
|
|
|
INTEGER :: space_type
|
|
!
|
|
! Dataset dimensions
|
|
!
|
|
INTEGER, PARAMETER :: SPACE1_DIM1= 3, SPACE1_DIM2=15, SPACE1_DIM3=13
|
|
|
|
INTEGER(HSIZE_T), DIMENSION(1:3) :: dims1 = (/SPACE1_DIM1, SPACE1_DIM2, SPACE1_DIM3/)
|
|
INTEGER :: SPACE1_RANK = 3
|
|
INTEGER :: error
|
|
|
|
!-------------------------------------------------------------------------
|
|
! * Test encoding and decoding of simple dataspace and hyperslab selection.
|
|
! *-------------------------------------------------------------------------
|
|
!
|
|
|
|
CALL H5Screate_simple_f(SPACE1_RANK, dims1, sid1, error)
|
|
CALL check("H5Screate_simple", error, total_error)
|
|
|
|
CALL h5sselect_hyperslab_f(sid1, H5S_SELECT_SET_F, &
|
|
start, count, error, stride=stride, BLOCK=BLOCK)
|
|
CALL check("h5sselect_hyperslab_f", error, total_error)
|
|
|
|
|
|
! Encode simple data space in a buffer
|
|
|
|
! First find the buffer size
|
|
CALL H5Sencode_f(sid1, sbuf, sbuf_size, error)
|
|
CALL check("H5Sencode", error, total_error)
|
|
|
|
|
|
! Try decoding bogus buffer
|
|
|
|
CALL H5Sdecode_f(sbuf, decoded_sid1, error)
|
|
CALL verify("H5Sdecode", error, -1, total_error)
|
|
|
|
CALL H5Sencode_f(sid1, sbuf, sbuf_size, error)
|
|
CALL check("H5Sencode", error, total_error)
|
|
|
|
! Decode from the dataspace buffer and return an object handle
|
|
CALL H5Sdecode_f(sbuf, decoded_sid1, error)
|
|
CALL check("H5Sdecode", error, total_error)
|
|
|
|
|
|
! Verify the decoded dataspace
|
|
CALL h5sget_simple_extent_npoints_f(decoded_sid1, n, error)
|
|
CALL check("h5sget_simple_extent_npoints_f", error, total_error)
|
|
CALL verify("h5sget_simple_extent_npoints_f", INT(n), INT(SPACE1_DIM1 * SPACE1_DIM2 * SPACE1_DIM3), &
|
|
total_error)
|
|
|
|
!
|
|
!Close the dataspace for the dataset.
|
|
!
|
|
CALL h5sclose_f(sid1, error)
|
|
CALL check("h5sclose_f", error, total_error)
|
|
|
|
CALL h5sclose_f(decoded_sid1, error)
|
|
CALL check("h5sclose_f", error, total_error)
|
|
|
|
! -------------------------------------------------------------------------
|
|
! * Test encoding and decoding of scalar dataspace.
|
|
! *-------------------------------------------------------------------------
|
|
!
|
|
! Create scalar dataspace
|
|
|
|
CALL H5Screate_f(H5S_SCALAR_F, sid3, error)
|
|
CALL check("H5Screate_f",error, total_error)
|
|
|
|
! Encode scalar data space in a buffer
|
|
|
|
! First find the buffer size
|
|
CALL H5Sencode_f(sid3, scalar_buf, scalar_size, error)
|
|
CALL check("H5Sencode_f", error, total_error)
|
|
|
|
! encode
|
|
|
|
CALL H5Sencode_f(sid3, scalar_buf, scalar_size, error)
|
|
CALL check("H5Sencode_f", error, total_error)
|
|
|
|
|
|
! Decode from the dataspace buffer and return an object handle
|
|
|
|
CALL H5Sdecode_f(scalar_buf, decoded_sid3, error)
|
|
CALL check("H5Sdecode_f", error, total_error)
|
|
|
|
|
|
! Verify extent type
|
|
|
|
CALL H5Sget_simple_extent_type_f(decoded_sid3, space_type, error)
|
|
CALL check("H5Sget_simple_extent_type_f", error, total_error)
|
|
CALL verify("H5Sget_simple_extent_type_f", space_type, H5S_SCALAR_F, total_error)
|
|
|
|
! Verify decoded dataspace
|
|
CALL h5sget_simple_extent_npoints_f(decoded_sid3, n, error)
|
|
CALL check("h5sget_simple_extent_npoints_f", error, total_error)
|
|
CALL verify("h5sget_simple_extent_npoints_f", INT(n), 1, total_error)
|
|
|
|
CALL H5Sget_simple_extent_ndims_f(decoded_sid3, rank, error)
|
|
CALL CHECK("H5Sget_simple_extent_ndims_f", error, total_error)
|
|
CALL verify("H5Sget_simple_extent_ndims_f", rank, 0, total_error )
|
|
|
|
CALL h5sclose_f(sid3, error)
|
|
CALL check("h5sclose_f", error, total_error)
|
|
|
|
CALL h5sclose_f(decoded_sid3, error)
|
|
CALL check("h5sclose_f", error, total_error)
|
|
|
|
END SUBROUTINE test_h5s_encode
|
|
|
|
!-------------------------------------------------------------------------
|
|
! Function: test_scaleoffset
|
|
!
|
|
! Purpose: Tests the integer datatype for scaleoffset filter
|
|
! with fill value set
|
|
!
|
|
! Return: Success: 0
|
|
! Failure: >0
|
|
!
|
|
! Programmer: M. Scot Breitenfeld
|
|
! Decemeber 11, 2010
|
|
!
|
|
! Modifications:
|
|
!
|
|
!-------------------------------------------------------------------------
|
|
!
|
|
|
|
SUBROUTINE test_scaleoffset(cleanup, total_error )
|
|
|
|
IMPLICIT NONE
|
|
LOGICAL, INTENT(IN) :: cleanup
|
|
INTEGER, INTENT(INOUT) :: total_error
|
|
INTEGER(hid_t) :: file
|
|
|
|
INTEGER(hid_t) :: dataset, datatype, space, mspace, dc
|
|
INTEGER(hsize_t), DIMENSION(1:2) :: dims = (/2, 5/)
|
|
INTEGER(hsize_t), DIMENSION(1:2) :: chunk_dim = (/2, 5/)
|
|
INTEGER, DIMENSION(1:2,1:5) :: orig_data
|
|
INTEGER, DIMENSION(1:2,1:5) :: new_data
|
|
INTEGER(hsize_t), DIMENSION(1:2) :: start ! Start of hyperslab
|
|
INTEGER(hsize_t), DIMENSION(1:2) :: stride ! Stride of hyperslab
|
|
INTEGER(hsize_t), DIMENSION(1:2) :: count ! BLOCK count
|
|
INTEGER(hsize_t), DIMENSION(1:2) :: BLOCK ! BLOCK sizes
|
|
INTEGER :: fillval
|
|
INTEGER(size_t) :: j
|
|
REAL :: x
|
|
INTEGER :: error
|
|
LOGICAL :: status
|
|
|
|
! check to see if filter is available
|
|
CALL H5Zfilter_avail_f(H5Z_FILTER_SCALEOFFSET_F, status, error)
|
|
IF(.NOT.status)THEN ! We don't have H5Z_FILTER_SCALEOFFSET_F filter
|
|
total_error = -1 ! so return
|
|
RETURN
|
|
ENDIF
|
|
|
|
CALL H5Fcreate_f("h5scaleoffset.h5", H5F_ACC_TRUNC_F, file, error)
|
|
CALL check("H5Fcreate_f", error, total_error)
|
|
|
|
CALL H5Tcopy_f(H5T_NATIVE_INTEGER, datatype, error)
|
|
CALL CHECK(" H5Tcopy_f", error, total_error)
|
|
|
|
! Set order of dataset datatype
|
|
CALL H5Tset_order_f(datatype, H5T_ORDER_BE_F, error)
|
|
CALL CHECK(" H5Tset_order_f", error, total_error)
|
|
|
|
! Create the data space for the dataset
|
|
CALL H5Screate_simple_f(2, dims, space, error)
|
|
CALL CHECK(" H5Screate_simple_f", error, total_error)
|
|
|
|
! Create the dataset property list
|
|
CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dc, error)
|
|
CALL CHECK(" H5Pcreate_f", error, total_error)
|
|
|
|
! Set fill value
|
|
fillval = 10000
|
|
CALL H5Pset_fill_value_f(dc, H5T_NATIVE_INTEGER, fillval, error)
|
|
CALL CHECK(" H5Pset_fill_value_f", error, total_error)
|
|
|
|
! Set up to use scaleoffset filter, let library calculate minbits
|
|
CALL H5Pset_chunk_f(dc, 2, chunk_dim, error)
|
|
CALL CHECK(" H5Pset_chunk_f", error, total_error)
|
|
|
|
CALL H5Pset_scaleoffset_f(dc, H5Z_SO_INT_F, H5Z_SO_INT_MINBITS_DEFAULT_F, error)
|
|
CALL CHECK(" H5Pset_scaleoffset_f", error, total_error)
|
|
|
|
! Create the dataset
|
|
CALL H5Dcreate_f(file, "scaleoffset_int", datatype, &
|
|
space, dataset, error, dc)
|
|
CALL CHECK(" H5Dcreate_f", error, total_error)
|
|
|
|
! Create the memory data space
|
|
CALL H5Screate_simple_f(2, dims, mspace, error)
|
|
CALL CHECK(" H5Screate_simple_f", error, total_error)
|
|
|
|
! Select hyperslab for data to write, using 1x5 blocks,
|
|
! (1,1) stride and (1,1) count starting at the position (0,0)
|
|
|
|
start(1:2) = (/0,0/)
|
|
stride(1:2) = (/1,1/)
|
|
COUNT(1:2) = (/1,1/)
|
|
BLOCK(1:2) = (/1,5/)
|
|
|
|
CALL H5Sselect_hyperslab_f(mspace, H5S_SELECT_SET_F, start, &
|
|
count, error, stride, BLOCK)
|
|
CALL CHECK(" H5Sselect_hyperslab_f", error, total_error)
|
|
|
|
CALL RANDOM_SEED()
|
|
! Initialize data of hyperslab
|
|
DO j = 1, INT(dims(2))
|
|
CALL RANDOM_NUMBER(x)
|
|
orig_data(1,j) = INT(x*10000.)
|
|
IF(MOD(j,2_size_t).EQ.0)THEN
|
|
orig_data(1,j) = - orig_data(1,j)
|
|
ENDIF
|
|
ENDDO
|
|
|
|
!----------------------------------------------------------------------
|
|
! STEP 1: Test scaleoffset by setting up a chunked dataset and writing
|
|
! to it.
|
|
!----------------------------------------------------------------------
|
|
|
|
! Only data in the hyperslab will be written, other value should be fill value
|
|
CALL H5Dwrite_f(dataset, H5T_NATIVE_INTEGER, orig_data, dims, error, mspace, mspace, H5P_DEFAULT_F)
|
|
CALL CHECK(" H5Dwrite_f", error, total_error)
|
|
|
|
!----------------------------------------------------------------------
|
|
! STEP 2: Try to read the data we just wrote.
|
|
!----------------------------------------------------------------------
|
|
|
|
! Read the dataset back
|
|
|
|
CALL H5Dread_f(dataset, H5T_NATIVE_INTEGER, new_data, dims, error, mspace, mspace, H5P_DEFAULT_F)
|
|
CALL CHECK(" H5Dread_f", error, total_error)
|
|
|
|
! Check that the values read are the same as the values written
|
|
DO j = 1, INT(dims(2))
|
|
IF(new_data(1,j) .NE. orig_data(1,j))THEN
|
|
total_error = total_error + 1
|
|
WRITE(*,'(" Read different values than written.")')
|
|
WRITE(*,'(" At index ", 2(1X,I0))') 1, j
|
|
EXIT
|
|
ENDIF
|
|
ENDDO
|
|
!----------------------------------------------------------------------
|
|
! Cleanup
|
|
!----------------------------------------------------------------------
|
|
CALL H5Tclose_f(datatype, error)
|
|
CALL CHECK(" H5Tclose_f", error, total_error)
|
|
CALL H5Pclose_f(dc, error)
|
|
CALL CHECK(" H5Pclose_f", error, total_error)
|
|
CALL H5Sclose_f(space, error)
|
|
CALL CHECK(" H5Sclose_f", error, total_error)
|
|
CALL H5Dclose_f(dataset, error)
|
|
CALL CHECK(" H5Dclose_f", error, total_error)
|
|
CALL H5Fclose_f(file, error)
|
|
CALL CHECK(" H5Fclose_f", error, total_error)
|
|
|
|
IF(cleanup) CALL h5_cleanup_f("h5scaleoffset", H5P_DEFAULT_F, error)
|
|
CALL check("h5_cleanup_f", error, total_error)
|
|
|
|
END SUBROUTINE test_scaleoffset
|
|
|
|
END MODULE TH5MISC_1_8
|