mirror of
https://github.com/HDFGroup/hdf5.git
synced 2024-12-21 07:51:46 +08:00
fd70b2afa8
Trim trailing whitespace from source code files with this command:
find . \( -name "*.[ch]" -or -name "*.cpp" -or -name "*.f90" \) -print |xargs -n 1 sed -i "" 's/[[:blank:]]*$//'
Tested on:
None - eyeballed only
426 lines
15 KiB
Fortran
426 lines
15 KiB
Fortran
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
! 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 files COPYING and Copyright.html. COPYING can be found at the root *
|
|
! of the source code distribution tree; Copyright.html can be found at the *
|
|
! root level of an installed copy of the electronic HDF5 document set and *
|
|
! is linked from the top-level documents page. It can also be found at *
|
|
! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have *
|
|
! access to either file, you may request a copy from help@hdfgroup.org. *
|
|
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
!
|
|
!
|
|
!
|
|
! Testing Fortran wrappers introduced in 1.8 release.
|
|
!
|
|
PROGRAM fortranlibtest
|
|
|
|
USE HDF5
|
|
|
|
IMPLICIT NONE
|
|
INTEGER :: total_error = 0
|
|
INTEGER :: error
|
|
INTEGER :: ret_total_error
|
|
INTEGER :: majnum, minnum, relnum
|
|
LOGICAL :: cleanup, status
|
|
|
|
CALL h5open_f(error)
|
|
|
|
cleanup = .TRUE.
|
|
CALL h5_env_nocleanup_f(status)
|
|
IF(status) cleanup=.FALSE.
|
|
|
|
WRITE(*,*) ' ========================== '
|
|
WRITE(*,*) ' FORTRAN 1.8 tests '
|
|
WRITE(*,*) ' ========================== '
|
|
CALL h5get_libversion_f(majnum, minnum, relnum, total_error)
|
|
IF(total_error .EQ. 0) THEN
|
|
WRITE(*, '(" FORTRANLIB_TEST is linked with HDF5 Library version ")', advance="NO")
|
|
WRITE(*, '(I1)', advance="NO") majnum
|
|
WRITE(*, '(".")', advance="NO")
|
|
WRITE(*, '(I1)', advance="NO") minnum
|
|
WRITE(*, '(" release ")', advance="NO")
|
|
WRITE(*, '(I3)') relnum
|
|
ELSE
|
|
total_error = total_error + 1
|
|
ENDIF
|
|
WRITE(*,*)
|
|
|
|
ret_total_error = 0
|
|
CALL file_space("file_space_1_8",cleanup, ret_total_error)
|
|
CALL write_test_status(ret_total_error, &
|
|
' Testing file free space', &
|
|
total_error)
|
|
|
|
ret_total_error = 0
|
|
CALL attribute_test_1_8(cleanup, ret_total_error)
|
|
CALL write_test_status(ret_total_error, &
|
|
' Testing attributes', &
|
|
total_error)
|
|
|
|
ret_total_error = 0
|
|
CALL group_test(cleanup, ret_total_error)
|
|
CALL write_test_status(ret_total_error, &
|
|
' Testing groups', &
|
|
total_error)
|
|
|
|
ret_total_error = 0
|
|
CALL test_h5o(cleanup, ret_total_error)
|
|
CALL write_test_status(ret_total_error, &
|
|
' Testing object interface', &
|
|
total_error)
|
|
|
|
ret_total_error = 0
|
|
CALL dtransform(cleanup, ret_total_error)
|
|
CALL write_test_status(ret_total_error, &
|
|
' Testing data transform', &
|
|
total_error)
|
|
|
|
ret_total_error = 0
|
|
CALL test_genprop_basic_class(cleanup, ret_total_error)
|
|
CALL write_test_status(ret_total_error, &
|
|
' Testing basic generic properties', &
|
|
total_error)
|
|
|
|
ret_total_error = 0
|
|
CALL test_h5s_encode(cleanup, ret_total_error)
|
|
CALL write_test_status(ret_total_error, &
|
|
' Testing dataspace encoding and decoding', &
|
|
total_error)
|
|
|
|
|
|
|
|
! CALL test_hard_query(group_total_error)
|
|
|
|
WRITE(*,*)
|
|
|
|
WRITE(*,*) ' ============================================ '
|
|
WRITE(*, fmt = '(19x, 27a)', advance='NO') ' FORTRAN tests completed with '
|
|
WRITE(*, fmt = '(i4)', advance='NO') total_error
|
|
WRITE(*, fmt = '(12a)' ) ' error(s) ! '
|
|
WRITE(*,*) ' ============================================ '
|
|
|
|
CALL h5close_f(error)
|
|
|
|
! if errors detected, exit with non-zero code.
|
|
IF (total_error .NE. 0) CALL h5_exit_f (1)
|
|
|
|
END PROGRAM fortranlibtest
|
|
|
|
SUBROUTINE dtransform(cleanup, total_error)
|
|
USE HDF5 ! This module contains all necessary modules
|
|
|
|
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 VerifyString("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 VerifyString("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 VerifyString("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(cleanup, total_error)
|
|
|
|
USE HDF5 ! This module contains all necessary modules
|
|
|
|
IMPLICIT NONE
|
|
LOGICAL, INTENT(IN) :: cleanup
|
|
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"
|
|
|
|
! /* 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 verifystring("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 verifystring("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 verifystring("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 verifylogical("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 verifylogical("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(cleanup, total_error)
|
|
|
|
!/****************************************************************
|
|
!**
|
|
!** test_h5s_encode(): Test H5S (dataspace) encoding and decoding.
|
|
!**
|
|
!****************************************************************/
|
|
|
|
USE HDF5 ! This module contains all necessary modules
|
|
|
|
IMPLICIT NONE
|
|
LOGICAL, INTENT(IN) :: cleanup
|
|
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, need variable length in fortran 2003
|
|
CHARACTER(LEN=288) :: sbuf
|
|
CHARACTER(LEN=288) :: scalar_buf
|
|
! F2003 CHARACTER(LEN=:), ALLOCATABLE :: sbuf
|
|
|
|
! unsigned char *sbuf=NULL, *null_sbuf=NULL, *scalar_buf=NULL;
|
|
! hsize_t tdims[4]; /* Dimension array to test with */
|
|
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
|
|
|
|
! H5S_sel_type sel_type;
|
|
! hssize_t nblocks;
|
|
!
|
|
!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
|
|
|
|
!/* Output message about test being performed */
|
|
!WRITE(*,*) "Testing Dataspace Encoding and Decoding"
|
|
|
|
!/*-------------------------------------------------------------------------
|
|
! * 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)
|
|
|
|
! In fortran 2003 we can allocate the needed character size here
|
|
|
|
! /* 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), SPACE1_DIM1 * SPACE1_DIM2 * SPACE1_DIM3, &
|
|
total_error)
|
|
|
|
!!$
|
|
!!$ rank = H5Sget_simple_extent_ndims(decoded_sid1);
|
|
!!$ CHECK(rank, FAIL, "H5Sget_simple_extent_ndims");
|
|
!!$ VERIFY(rank, SPACE1_RANK, "H5Sget_simple_extent_ndims");
|
|
!!$
|
|
!!$ rank = H5Sget_simple_extent_dims(decoded_sid1, tdims, NULL);
|
|
!!$ CHECK(rank, FAIL, "H5Sget_simple_extent_dims");
|
|
!!$ VERIFY(HDmemcmp(tdims, dims1, SPACE1_RANK * sizeof(hsize_t)), 0,
|
|
!!$ "H5Sget_simple_extent_dims");
|
|
!!$
|
|
!!$ /* Verify hyperslabe selection */
|
|
!!$ sel_type = H5Sget_select_type(decoded_sid1);
|
|
!!$ VERIFY(sel_type, H5S_SEL_HYPERSLABS, "H5Sget_select_type");
|
|
!!$
|
|
!!$ nblocks = H5Sget_select_hyper_nblocks(decoded_sid1);
|
|
!!$ VERIFY(nblocks, 2*2*2, "H5Sget_select_hyper_nblocks");
|
|
!!$
|
|
!
|
|
!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
|
|
|