mirror/hdf5
2
0
Fork 0
mirror of https://github.com/HDFGroup/hdf5.git synced 2024-12-09 07:32:32 +08:00
Code Issues Packages Projects Releases Wiki Activity
685c4e08ae
hdf5/fortran/test/tH5T_F03.F90
Larry Knox 89fbe00dec Merge pull request #426 in HDFFV/hdf5 from ~LRKNOX/hdf5_lrk:hdf5_1_10 to hdf5_1_10 
* 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.
2017-04-25 16:05:36 -05:00

3411 lines
116 KiB
Fortran
Raw Blame History

!****h* root/fortran/test/tH5T_F03.f90
!
! NAME
! tH5T_F03.f90
!
! FUNCTION
! Test FORTRAN HDF5 H5T APIs which are dependent on FORTRAN 2003
! features.
!
! 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. *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
! CONTAINS SUBROUTINES
! test_array_compound_atomic, test_array_compound_array,
! test_array_bkg, test_h5kind_to_type
!
!*****
! *****************************************
! *** H 5 T T E S T S
! *****************************************
!***************************************************************
!**
!** test_array_compound_atomic(): Test basic array datatype code.
!** Tests 1-D array of compound datatypes (with no array fields)
!**
!***************************************************************
!
#include <H5config_f.inc>
MODULE TH5T_F03
USE HDF5
USE TH5_MISC
USE TH5_MISC_GEN
USE ISO_C_BINDING
CONTAINS
SUBROUTINE test_array_compound_atomic(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
! 1-D dataset WITH fixed dimensions
INTEGER, PARAMETER :: SPACE1_RANK = 1
INTEGER, PARAMETER :: SPACE1_DIM1 = 4
! 1-D array datatype
INTEGER, PARAMETER :: ARRAY1_RANK= 1
INTEGER, PARAMETER :: ARRAY1_DIM1= 4
CHARACTER(LEN=10), PARAMETER :: FILENAME = "tarray1.h5"
TYPE s1_t
SEQUENCE
INTEGER :: i
REAL :: f
END TYPE s1_t
TYPE(s1_t), DIMENSION(:,:), ALLOCATABLE, TARGET :: wdata ! Information to write
TYPE(s1_t), DIMENSION(:,:), ALLOCATABLE, TARGET :: rdata ! Information read in
INTEGER(hid_t) :: fid1 ! HDF5 File IDs
INTEGER(hid_t) :: dataset ! Dataset ID
INTEGER(hid_t) :: sid1 ! Dataspace ID
INTEGER(hid_t) :: tid1 ! Array Datatype ID
INTEGER(hid_t) :: tid2 ! Compound Datatype ID
INTEGER(HSIZE_T), DIMENSION(1) :: sdims1 = (/SPACE1_DIM1/)
INTEGER(HSIZE_T), DIMENSION(1) :: tdims1=(/ARRAY1_DIM1/)
INTEGER :: ndims ! Array rank for reading
INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: rdims1 ! Array dimensions for reading
INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: rdims ! Array dimensions for reading
INTEGER :: nmemb ! Number of compound members
CHARACTER(LEN=20) :: mname ! Name of compound field
INTEGER(size_t) :: off ! Offset of compound field
INTEGER(hid_t) :: mtid ! Datatype ID for field
INTEGER :: i,j ! counting variables
INTEGER :: error ! Generic RETURN value
INTEGER :: namelen
LOGICAL :: flag
TYPE(C_PTR) :: f_ptr ! Needed to pass the pointer, for g95 compiler to work
ALLOCATE( wdata(1:SPACE1_DIM1,1:ARRAY1_DIM1) )
ALLOCATE( rdata(1:SPACE1_DIM1,1:ARRAY1_DIM1) )
! Initialize array data to write
DO i = 1, SPACE1_DIM1
DO j = 1, ARRAY1_DIM1
wdata(i,j)%i = i * 10 + j
wdata(i,j)%f = i * 2.5 + j
ENDDO
ENDDO
! Create file
CALL h5fcreate_f(FILENAME,H5F_ACC_TRUNC_F,fid1,error)
CALL check("h5fcreate_f", error, total_error)
! Create dataspace for datasets
CALL h5screate_simple_f(SPACE1_RANK, sdims1, sid1, error)
CALL check("h5screate_simple_f", error, total_error)
CALL h5tcreate_f(H5T_COMPOUND_F, H5OFFSETOF(C_LOC(wdata(1,1)), C_LOC(wdata(2,1))), tid2, error)
CALL check("h5tcreate_f", error, total_error)
! Insert integer field
CALL h5tinsert_f(tid2, "i", H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%i)), H5T_NATIVE_INTEGER, error)
CALL check("h5tinsert_f", error, total_error)
! Insert float field
CALL h5tinsert_f(tid2, "f", H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%f)), H5T_NATIVE_REAL, error)
CALL check("h5tinsert_f", error, total_error)
! Create an array datatype to refer to
CALL h5tarray_create_f(tid2, ARRAY1_RANK, tdims1, tid1, error)
CALL check("h5tarray_create_f", error, total_error)
! Close compound datatype
CALL h5tclose_f(tid2,error)
CALL check("h5tclose_f", error, total_error)
! Create a dataset
CALL h5dcreate_f(fid1,"Dataset1",tid1, sid1, dataset,error)
CALL check("h5dcreate_f", error, total_error)
! Write dataset to disk
ALLOCATE(rdims(1:2)) ! dummy not needed
f_ptr = C_LOC(wdata(1,1))
CALL h5dwrite_f(dataset, tid1, f_ptr, error )
CALL check("h5dwrite_f", error, total_error)
! Close Dataset
CALL h5dclose_f(dataset, error)
CALL check("h5dclose_f", error, total_error)
! Close datatype
CALL h5tclose_f(tid1,error)
CALL check("h5tclose_f", error, total_error)
! Close disk dataspace
CALL h5sclose_f(sid1,error)
CALL check("h5sclose_f", error, total_error)
! Close file
CALL h5fclose_f(fid1,error)
CALL check("h5fclose_f", error, total_error)
! Re-open file
CALL h5fopen_f (FILENAME, H5F_ACC_RDONLY_F, fid1, error)
CALL check("h5fopen_f", error, total_error)
! Open the dataset
CALL h5dopen_f(fid1, "Dataset1", dataset, error)
CALL check("h5dopen_f", error, total_error)
! Get the datatype
CALL h5dget_type_f(dataset, tid1, error)
CALL check("h5dget_type_f", error, total_error)
! Check the array rank
CALL h5tget_array_ndims_f(tid1, ndims, error)
CALL check("h5tget_array_ndims_f", error, total_error)
CALL VERIFY("h5tget_array_ndims_f",ndims, ARRAY1_RANK, total_error)
! Get the array dimensions
ALLOCATE(rdims1(1:ndims))
CALL h5tget_array_dims_f(tid1, rdims1, error)
CALL check("h5tget_array_dims_f", error, total_error)
! Check the array dimensions
DO i = 1, ndims
CALL VERIFY("h5tget_array_dims_f", INT(rdims1(i)), INT(tdims1(i)), total_error)
ENDDO
! Get the compound datatype
CALL h5tget_super_f(tid1, tid2, error)
CALL check("h5tget_super_f", error, total_error)
! Check the number of members
CALL h5tget_nmembers_f(tid2, nmemb, error)
CALL check("h5tget_nmembers_f", error, total_error)
CALL VERIFY("h5tget_nmembers_f", nmemb, 2, total_error)
! Check the 1st field's name
CALL H5Tget_member_name_f(tid2, 0, mname, namelen,error)
CALL check("H5Tget_member_name_f", error, total_error)
CALL verify("H5Tget_member_name_f",mname(1:namelen),"i", total_error)
! Check the 1st field's offset
CALL H5Tget_member_offset_f(tid2, 0, off, error)
CALL check("H5Tget_member_offset_f", error, total_error)
CALL VERIFY("H5Tget_member_offset_f",INT(off),0, total_error)
! Check the 1st field's datatype
CALL H5Tget_member_type_f(tid2, 0, mtid, error)
CALL check("H5Tget_member_type_f", error, total_error)
CALL H5Tequal_f(mtid, H5T_NATIVE_INTEGER, flag, error)
CALL check("H5Tequal_f", error, total_error)
CALL verify("H5Tequal_f", flag, .TRUE., total_error)
CALL h5tclose_f(mtid,error)
CALL check("h5tclose_f", error, total_error)
! Check the 2nd field's name
CALL H5Tget_member_name_f(tid2, 1, mname, namelen,error)
CALL check("H5Tget_member_name_f", error, total_error)
CALL verify("H5Tget_member_name_f",mname(1:namelen),"f", total_error)
! Check the 2nd field's offset
CALL H5Tget_member_offset_f(tid2, 1, off, error)
CALL check("H5Tget_member_offset_f", error, total_error)
CALL VERIFY("H5Tget_member_offset_f",INT(off),INT(H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%f))), total_error)
! Check the 2nd field's datatype
CALL H5Tget_member_type_f(tid2, 1, mtid, error)
CALL check("H5Tget_member_type_f", error, total_error)
CALL H5Tequal_f(mtid, H5T_NATIVE_REAL, flag, error)
CALL check("H5Tequal_f", error, total_error)
CALL verify("H5Tequal_f", flag, .TRUE., total_error)
CALL h5tclose_f(mtid,error)
CALL check("h5tclose_f", error, total_error)
! Close Compound Datatype
CALL h5tclose_f(tid2, error)
CALL check("h5tclose_f", error, total_error)
! Read dataset from disk
f_ptr = C_LOC(rdata(1,1))
CALL H5Dread_f(dataset, tid1, f_ptr, error, H5S_ALL_F, H5S_ALL_F, H5P_DEFAULT_F)
CALL check("H5Dread_f", error, total_error)
! Compare data read in
DO i = 1, SPACE1_DIM1
DO j = 1, ARRAY1_DIM1
IF(wdata(i,j)%i.NE.rdata(i,j)%i)THEN
PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f '
total_error = total_error + 1
ENDIF
CALL VERIFY('ERROR: Wrong real data is read back by H5Dread_f ',wdata(i,j)%f, rdata(i,j)%f, total_error)
ENDDO
ENDDO
! Close Datatype
CALL h5tclose_f(tid1,error)
CALL check("h5tclose_f", error, total_error)
! Close Dataset
CALL h5dclose_f(dataset, error)
CALL check("h5dclose_f", error, total_error)
! Close file
CALL h5fclose_f(fid1,error)
CALL check("h5fclose_f", error, total_error)
END SUBROUTINE test_array_compound_atomic
!!$
!!$!***************************************************************
!!$!**
!!$!** test_array_compound_array(): Test basic array datatype code.
!!$!** Tests 1-D array of compound datatypes (with array fields)
!!$!**
!!$!***************************************************************
!!$
SUBROUTINE test_array_compound_array(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
! 1-D array datatype
INTEGER, PARAMETER :: ARRAY1_RANK= 1
INTEGER, PARAMETER :: ARRAY1_DIM1= 3
INTEGER, PARAMETER :: ARRAY2_DIM1= 5
INTEGER, PARAMETER :: SPACE1_RANK = 1
INTEGER, PARAMETER :: SPACE1_DIM1 = 4
CHARACTER(LEN=10), PARAMETER :: FILENAME = "tarray2.h5"
TYPE st_t_struct ! Typedef for compound datatype
SEQUENCE
INTEGER :: i
REAL, DIMENSION(1:ARRAY2_DIM1) :: f
CHARACTER(LEN=2), DIMENSION(1:ARRAY2_DIM1) :: c
END TYPE st_t_struct
! Information to write
TYPE(st_t_struct), DIMENSION(1:SPACE1_DIM1,1:ARRAY1_DIM1), TARGET :: wdata
! Information read in
TYPE(st_t_struct), DIMENSION(1:SPACE1_DIM1,1:ARRAY1_DIM1), TARGET :: rdata
INTEGER(hid_t) :: fid1 ! HDF5 File IDs
INTEGER(hid_t) :: dataset ! Dataset ID
integer(hid_t) :: sid1 ! Dataspace ID
integer(hid_t) :: tid1 ! Array Datatype ID
integer(hid_t) :: tid2 ! Compound Datatype ID
integer(hid_t) :: tid3 ! Nested Array Datatype ID
integer(hid_t) :: tid4 ! Nested Array Datatype ID
INTEGER(HSIZE_T), DIMENSION(1) :: sdims1 = (/SPACE1_DIM1/)
INTEGER(HSIZE_T), DIMENSION(1) :: tdims1=(/ARRAY1_DIM1/)
INTEGER(HSIZE_T), DIMENSION(1) :: tdims2=(/ARRAY2_DIM1/)
INTEGER ndims ! Array rank for reading
INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: rdims1 ! Array dimensions for reading
INTEGER :: nmemb ! Number of compound members
CHARACTER(LEN=20) :: mname ! Name of compound field
INTEGER(size_t) :: off ! Offset of compound field
INTEGER(hid_t) :: mtid ! Datatype ID for field
INTEGER(hid_t) :: mtid2 ! Datatype ID for field
INTEGER :: mclass ! Datatype class for field
INTEGER :: i,j,k ! counting variables
INTEGER :: error
CHARACTER(LEN=2) :: ichr2
INTEGER :: namelen
LOGICAL :: flag
INTEGER(HID_T) :: atype_id !String Attribute Datatype identifier
INTEGER(SIZE_T) :: attrlen ! Length of the attribute string
TYPE(c_ptr) :: f_ptr
! Initialize array data to write
DO i = 1, SPACE1_DIM1
DO j = 1, array1_DIM1
wdata(i,j)%i = i*10+j
DO k = 1, ARRAY2_DIM1
wdata(i,j)%f(k) = 10*i+j+.5
WRITE(ichr2,'(I2.2)') k
wdata(i,j)%c(k) = ichr2
ENDDO
ENDDO
ENDDO
! Create file
CALL h5fcreate_f(FILENAME,H5F_ACC_TRUNC_F,fid1,error)
CALL check("h5fcreate_f", error, total_error)
! Create dataspace for datasets
CALL h5screate_simple_f(SPACE1_RANK, sdims1, sid1, error)
CALL check("h5screate_simple_f", error, total_error)
! Create a compound datatype to refer to
!
CALL h5tcreate_f(H5T_COMPOUND_F, H5OFFSETOF(C_LOC(wdata(1,1)), C_LOC(wdata(2,1))), tid2, error)
CALL check("h5tcreate_f", error, total_error)
! Insert integer field
CALL h5tinsert_f(tid2, "i", H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%i)), H5T_NATIVE_INTEGER, error)
CALL check("h5tinsert_f", error, total_error)
! Create an array of floats datatype
CALL h5tarray_create_f(H5T_NATIVE_REAL, ARRAY1_RANK, tdims2, tid3, error)
CALL check("h5tarray_create_f", error, total_error)
! Insert float array field
CALL h5tinsert_f(tid2, "f", H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%f)), tid3, error)
CALL check("h5tinsert_f", error, total_error)
!
! Create datatype for the String attribute.
!
CALL h5tcopy_f(H5T_NATIVE_CHARACTER, atype_id, error)
CALL check("h5tcopy_f",error,total_error)
attrlen = LEN(wdata(1,1)%c(1))
CALL h5tset_size_f(atype_id, attrlen, error)
CALL check("h5tset_size_f",error,total_error)
! Create an array of character datatype
CALL h5tarray_create_f(atype_id, ARRAY1_RANK, tdims2, tid4, error)
CALL check("h5tarray_create_f", error, total_error)
! Insert character array field
CALL h5tinsert_f(tid2, "c", H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%c(1)(1:1))), tid4, error)
CALL check("h5tinsert2_f", error, total_error)
! Close array of floats field datatype
CALL h5tclose_f(tid3,error)
CALL check("h5tclose_f", error, total_error)
CALL h5tclose_f(tid4,error)
CALL check("h5tclose_f", error, total_error)
! Create an array datatype to refer to
CALL h5tarray_create_f(tid2, ARRAY1_RANK, tdims1, tid1, error)
CALL check("h5tarray_create_f", error, total_error)
! Close compound datatype
CALL h5tclose_f(tid2,error)
CALL check("h5tclose_f", error, total_error)
! Create a dataset
CALL h5dcreate_f(fid1,"Dataset1",tid1, sid1, dataset,error)
CALL check("h5dcreate_f", error, total_error)
! Write dataset to disk
f_ptr = C_LOC(wdata(1,1))
CALL h5dwrite_f(dataset, tid1, f_ptr, error )
CALL check("h5dwrite_f", error, total_error)
! Close Dataset
CALL h5dclose_f(dataset, error)
CALL check("h5dclose_f", error, total_error)
! Close datatype
CALL h5tclose_f(tid1,error)
CALL check("h5tclose_f", error, total_error)
! Close disk dataspace
CALL h5sclose_f(sid1,error)
CALL check("h5sclose_f", error, total_error)
! Close file
CALL h5fclose_f(fid1,error)
CALL check("h5fclose_f", error, total_error)
! Re-open file
CALL h5fopen_f (FILENAME, H5F_ACC_RDONLY_F, fid1, error)
CALL check("h5fopen_f", error, total_error)
! Open the dataset
CALL h5dopen_f(fid1, "Dataset1", dataset, error)
CALL check("h5dopen_f", error, total_error)
! Get the datatype
CALL h5dget_type_f(dataset, tid1, error)
CALL check("h5dget_type_f", error, total_error)
! Check the array rank
CALL h5tget_array_ndims_f(tid1, ndims, error)
CALL check("h5tget_array_ndims_f", error, total_error)
CALL VERIFY("h5tget_array_ndims_f",ndims, ARRAY1_RANK, total_error)
! Get the array dimensions
ALLOCATE(rdims1(1:ndims))
CALL h5tget_array_dims_f(tid1, rdims1, error)
CALL check("h5tget_array_dims_f", error, total_error)
! Check the array dimensions
DO i = 1, ndims
CALL VERIFY("h5tget_array_dims_f", INT(rdims1(i)), INT(tdims1(i)), total_error)
ENDDO
! Get the compound datatype
CALL h5tget_super_f(tid1, tid2, error)
CALL check("h5tget_super_f", error, total_error)
! Check the number of members
CALL h5tget_nmembers_f(tid2, nmemb, error)
CALL check("h5tget_nmembers_f", error, total_error)
CALL VERIFY("h5tget_nmembers_f", nmemb, 3, total_error)
! Check the 1st field's name
CALL H5Tget_member_name_f(tid2, 0, mname, namelen,error)
CALL check("H5Tget_member_name_f", error, total_error)
CALL verify("H5Tget_member_name_f",mname(1:namelen),"i", total_error)
! Check the 1st field's offset
CALL H5Tget_member_offset_f(tid2, 0, off, error)
CALL check("H5Tget_member_offset_f", error, total_error)
CALL VERIFY("H5Tget_member_offset_f",INT(off),0, total_error)
! Check the 1st field's datatype
CALL H5Tget_member_type_f(tid2, 0, mtid, error)
CALL check("H5Tget_member_type_f", error, total_error)
CALL H5Tequal_f(mtid, H5T_NATIVE_INTEGER, flag, error)
CALL check("H5Tequal_f", error, total_error)
CALL verify("H5Tequal_f", flag, .TRUE., total_error)
CALL h5tclose_f(mtid,error)
CALL check("h5tclose_f", error, total_error)
! Check the 2nd field's name
CALL H5Tget_member_name_f(tid2, 1, mname, namelen,error)
CALL check("H5Tget_member_name_f", error, total_error)
CALL verify("H5Tget_member_name_f",mname(1:namelen),"f", total_error)
! Check the 2nd field's offset
CALL H5Tget_member_offset_f(tid2, 1, off, error)
CALL check("H5Tget_member_offset_f", error, total_error)
CALL VERIFY("H5Tget_member_offset_f",INT(off),INT(H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%f))), total_error)
! Check the 2nd field's datatype
CALL H5Tget_member_type_f(tid2, 1, mtid, error)
CALL check("H5Tget_member_type_f", error, total_error)
! Get the 2nd field's class
CALL H5Tget_class_f(mtid, mclass, error)
CALL check("H5Tget_class_f", error, total_error)
CALL VERIFY("H5Tget_class_f",mclass, H5T_ARRAY_F, total_error)
! Check the array rank
CALL h5tget_array_ndims_f(mtid, ndims, error)
CALL check("h5tget_array_ndims_f", error, total_error)
CALL VERIFY("h5tget_array_ndims_f",ndims, ARRAY1_RANK, total_error)
! Get the array dimensions
CALL h5tget_array_dims_f(mtid, rdims1, error)
CALL check("h5tget_array_dims_f", error, total_error)
! Check the array dimensions
DO i = 1, ndims
CALL VERIFY("h5tget_array_dims_f", INT(rdims1(i)), INT(tdims2(i)), total_error)
ENDDO
! Check the 3rd field's name
CALL H5Tget_member_name_f(tid2, 2, mname, namelen,error)
CALL check("H5Tget_member_name_f", error, total_error)
CALL verify("H5Tget_member_name_f",mname(1:namelen),"c", total_error)
! Check the 3rd field's offset
CALL H5Tget_member_offset_f(tid2, 2, off, error)
CALL check("H5Tget_member_offset_f", error, total_error)
CALL VERIFY("H5Tget_member_offset_f",INT(off),&
INT(H5OFFSETOF(C_LOC(wdata(1,1)),C_LOC(wdata(1,1)%c(1)(1:1)))), total_error)
! Check the 3rd field's datatype
CALL H5Tget_member_type_f(tid2, 2, mtid2, error)
CALL check("H5Tget_member_type_f", error, total_error)
! Get the 3rd field's class
CALL H5Tget_class_f(mtid2, mclass, error)
CALL check("H5Tget_class_f", error, total_error)
CALL VERIFY("H5Tget_class_f",mclass, H5T_ARRAY_F, total_error)
! Check the array rank
CALL h5tget_array_ndims_f(mtid2, ndims, error)
CALL check("h5tget_array_ndims_f", error, total_error)
CALL VERIFY("h5tget_array_ndims_f",ndims, ARRAY1_RANK, total_error)
! Get the array dimensions
CALL h5tget_array_dims_f(mtid2, rdims1, error)
CALL check("h5tget_array_dims_f", error, total_error)
! Check the array dimensions
DO i = 1, ndims
CALL VERIFY("h5tget_array_dims_f", INT(rdims1(i)), INT(tdims2(i)), total_error)
ENDDO
! Check the nested array's datatype
CALL H5Tget_super_f(mtid, tid3, error)
CALL check("H5Tget_super_f", error, total_error)
CALL H5Tequal_f(tid3, H5T_NATIVE_REAL, flag, error)
CALL check("H5Tequal_f", error, total_error)
CALL verify("H5Tequal_f", flag, .TRUE., total_error)
! Check the nested array's datatype
CALL H5Tget_super_f(mtid2, tid3, error)
CALL check("H5Tget_super_f", error, total_error)
CALL H5Tequal_f(tid3, atype_id, flag, error)
CALL check("H5Tequal_f", error, total_error)
CALL verify("H5Tequal_f", flag, .TRUE., total_error)
! Close the array's base type datatype
CALL h5tclose_f(tid3, error)
CALL check("h5tclose_f", error, total_error)
! Close the member datatype
CALL h5tclose_f(mtid,error)
CALL check("h5tclose_f", error, total_error)
! Close the member datatype
CALL h5tclose_f(mtid2,error)
CALL check("h5tclose_f", error, total_error)
! Close Compound Datatype
CALL h5tclose_f(tid2,error)
CALL check("h5tclose_f", error, total_error)
! READ dataset from disk
f_ptr = c_null_ptr
f_ptr = C_LOC(rdata(1,1))
CALL H5Dread_f(dataset, tid1, f_ptr, error)
CALL check("H5Dread_f", error, total_error)
! Compare data read in
DO i = 1, SPACE1_DIM1
DO j = 1, ARRAY1_DIM1
IF(wdata(i,j)%i.NE.rdata(i,j)%i)THEN
PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f '
total_error = total_error + 1
ENDIF
DO k = 1, ARRAY2_DIM1
CALL VERIFY("h5dread_f",wdata(i,j)%f(k),rdata(i,j)%f(k),total_error)
IF(total_error.NE.0) PRINT*,'ERROR: Wrong real array data is read back by H5Dread_f'
CALL VERIFY("h5dread_f",wdata(i,j)%c(k),rdata(i,j)%c(k),total_error)
IF(total_error.NE.0) PRINT*,'ERROR: Wrong character array data is read back by H5Dread_f'
ENDDO
ENDDO
ENDDO
! Close Datatype
CALL h5tclose_f(tid1,error)
CALL check("h5tclose_f", error, total_error)
! Close Dataset
CALL h5dclose_f(dataset, error)
CALL check("h5dclose_f", error, total_error)
! Close file
CALL h5fclose_f(fid1,error)
CALL check("h5fclose_f", error, total_error)
END SUBROUTINE test_array_compound_array
!!$
!!$!***************************************************************
!!$!**
!!$!** test_array_bkg(): Test basic array datatype code.
!!$!** Tests reading compound datatype with array fields and
!!$!** writing partial fields.
!!$!**
!!$!***************************************************************
!!$
SUBROUTINE test_array_bkg(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
INTEGER, PARAMETER :: LENGTH = 5
INTEGER, PARAMETER :: ALEN = 10
INTEGER, PARAMETER :: RANK = 1
INTEGER, PARAMETER :: NMAX = 100
CHARACTER(LEN=17), PARAMETER :: FIELDNAME = "ArrayofStructures"
INTEGER(hid_t) :: fid, array_dt
INTEGER(hid_t) :: space
INTEGER(hid_t) :: type
INTEGER(hid_t) :: dataset
INTEGER(hsize_t), DIMENSION(1:1) :: dim =(/LENGTH/)
INTEGER(hsize_t), DIMENSION(1:1) :: dima =(/ALEN/)
INTEGER :: i, j
INTEGER, DIMENSION(1:3) :: ndims = (/1,1,1/)
TYPE CmpField_struct
INTEGER, DIMENSION(1:ALEN) :: a
REAL(KIND=sp), DIMENSION(1:ALEN) :: b
REAL(KIND=dp), DIMENSION(1:ALEN) :: c
ENDTYPE CmpField_struct
TYPE(CmpField_struct), DIMENSION(1:LENGTH), TARGET :: cf
TYPE(CmpField_struct), DIMENSION(1:LENGTH), TARGET :: cfr
TYPE CmpDTSinfo_struct
INTEGER :: nsubfields
CHARACTER(LEN=5), DIMENSION(1:nmax) :: name
INTEGER(size_t), DIMENSION(1:nmax) :: offset
INTEGER(hid_t), DIMENSION(1:nmax) :: datatype
END TYPE CmpDTSinfo_struct
TYPE(CmpDTSinfo_struct) :: dtsinfo
TYPE fld_t_struct
REAL(KIND=sp), DIMENSION(1:ALEN) :: b
END TYPE fld_t_struct
INTEGER(SIZE_T) :: type_sizei ! Size of the integer datatype
INTEGER(SIZE_T) :: type_sizer ! Size of the real datatype
INTEGER(SIZE_T) :: type_sized ! Size of the double datatype
INTEGER(SIZE_T) :: sizeof_compound ! total size of compound
TYPE(fld_t_struct), DIMENSION(1:LENGTH), TARGET :: fld
TYPE(fld_t_struct), DIMENSION(1:LENGTH), TARGET :: fldr
CHARACTER(LEN=10), PARAMETER :: FILENAME = "tarray3.h5"
INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: rdims1 ! Array dimensions for reading
INTEGER(HSIZE_T), ALLOCATABLE, DIMENSION(:) :: rdims ! Array dimensions for reading
INTEGER :: error
TYPE(c_ptr) :: f_ptr
! Initialize the data
! -------------------
DO i = 1, LENGTH
DO j = 1, ALEN
cf(i)%a(j) = 100*(i+1) + j
cf(i)%b(j) = (100.*(i+1) + 0.01*j)
cf(i)%c(j) = 100.*(i+1) + 0.02*j
ENDDO
ENDDO
! Set the number of data members
! ------------------------------
dtsinfo%nsubfields = 3
! Initialize the offsets
! -----------------------
CALL h5tget_size_f(H5T_NATIVE_INTEGER, type_sizei, error)
CALL check("h5tget_size_f", error, total_error)
IF(h5_sizeof(cf(1)%b(1)).EQ.4_size_t)THEN
CALL h5tget_size_f(H5T_NATIVE_REAL_C_FLOAT, type_sizer, error)
CALL check("h5tget_size_f", error, total_error)
ELSE IF(h5_sizeof(cf(1)%b(1)).EQ.8_size_t)THEN
CALL h5tget_size_f(H5T_NATIVE_REAL_C_DOUBLE, type_sizer, error)
CALL check("h5tget_size_f", error, total_error)
ENDIF
CALL h5tget_size_f(H5T_NATIVE_DOUBLE, type_sized, error)
CALL check("h5tget_size_f", error, total_error)
dtsinfo%offset(1) = H5OFFSETOF(C_LOC(cf(1)),C_LOC(cf(1)%a(1)))
dtsinfo%offset(2) = H5OFFSETOF(C_LOC(cf(1)),C_LOC(cf(1)%b(1)))
dtsinfo%offset(3) = H5OFFSETOF(C_LOC(cf(1)),C_LOC(cf(1)%c(1)))
! Initialize the data type IDs
! ----------------------------
dtsinfo%datatype(1) = H5T_NATIVE_INTEGER;
dtsinfo%datatype(2) = H5T_NATIVE_REAL_C_FLOAT;
dtsinfo%datatype(3) = H5T_NATIVE_REAL_C_DOUBLE;
! Initialize the names of data members
! ------------------------------------
dtsinfo%name(1) = "One "
dtsinfo%name(2) = "Two "
dtsinfo%name(3) = "Three"
! Create file
! -----------
CALL h5fcreate_f(FILENAME,H5F_ACC_TRUNC_F,fid,error)
CALL check("h5fcreate_f", error, total_error)
! Create data space
! -----------------
CALL h5screate_simple_f(RANK, dim, space, error)
CALL check("h5screate_simple_f", error, total_error)
! Create the memory data type
! ---------------------------
CALL h5tcreate_f(H5T_COMPOUND_F, H5OFFSETOF(C_LOC(cf(1)), C_LOC(cf(2))), type, error)
CALL check("h5tcreate_f", error, total_error)
! Add members to the compound data type
! --------------------------------------
DO i = 1, dtsinfo%nsubfields
CALL h5tarray_create_f(dtsinfo%datatype(i), ndims(i), dima, array_dt, error)
CALL check("h5tarray_create_f", error, total_error)
CALL H5Tinsert_f(type, dtsinfo%name(i), dtsinfo%offset(i), array_dt, error)
CALL check("h5tinsert_f", error, total_error)
CALL h5tclose_f(array_dt,error)
CALL check("h5tclose_f", error, total_error)
ENDDO
! Create the dataset
! ------------------ /
CALL h5dcreate_f(fid,FIELDNAME,type, space, dataset,error)
CALL check("h5dcreate_f", error, total_error)
! Write data to the dataset
! -------------------------
ALLOCATE(rdims(1:2)) ! dummy not needed
f_ptr = C_LOC(cf(1))
CALL h5dwrite_f(dataset, type, f_ptr, error )
CALL check("h5dwrite_f", error, total_error)
ALLOCATE(rdims1(1:2)) ! dummy not needed
f_ptr = C_LOC(cfr(1))
CALL H5Dread_f(dataset, type, f_ptr, error)
CALL check("H5Dread_f", error, total_error)
! Verify correct data
! -------------------
DO i = 1, LENGTH
DO j = 1, ALEN
IF( cf(i)%a(j) .NE. cfr(i)%a(j) )THEN
PRINT*, 'ERROR: Wrong integer data is read back by H5Dread_f '
total_error = total_error + 1
ENDIF
CALL VERIFY('ERROR: Wrong real data is read back by H5Dread_f ',cf(i)%b(j), cfr(i)%b(j), total_error)
CALL VERIFY('ERROR: Wrong double data is read back by H5Dread_f ',cf(i)%c(j), cfr(i)%c(j), total_error)
ENDDO
ENDDO
! Release IDs
! -----------
CALL h5tclose_f(type,error)
CALL check("h5tclose_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(fid,error)
CALL check("h5fclose_f", error, total_error)
!****************************
! Reopen the file and update
!****************************
CALL h5fopen_f (FILENAME, H5F_ACC_RDWR_F, fid, error)
CALL check("h5fopen_f", error, total_error)
CALL h5dopen_f(fid, FIELDNAME, dataset, error)
CALL check("h5dopen_f", error, total_error)
sizeof_compound = INT( type_sizer*ALEN, size_t)
CALL h5tcreate_f(H5T_COMPOUND_F, sizeof_compound , type, error)
CALL check("h5tcreate_f", error, total_error)
CALL h5tarray_create_f(H5T_NATIVE_REAL_C_FLOAT, 1, dima, array_dt, error)
CALL check("h5tarray_create_f", error, total_error)
CALL h5tinsert_f(TYPE, "Two", 0_size_t, array_dt, error)
CALL check("h5tinsert_f", error, total_error)
! Initialize the data to overwrite
! --------------------------------
DO i = 1, LENGTH
DO j = 1, ALEN
fld(i)%b(j) = 1.313
cf(i)%b(j) = fld(i)%b(j)
ENDDO
ENDDO
f_ptr = C_LOC(fld(1))
CALL h5dwrite_f(dataset, TYPE, f_ptr, error )
CALL check("h5dwrite_f", error, total_error)
! Read just the field changed
f_ptr = C_LOC(fldr(1))
CALL H5Dread_f(dataset, TYPE, f_ptr, error)
CALL check("H5Dread_f", error, total_error)
DO i = 1, LENGTH
DO j = 1, ALEN
CALL VERIFY('ERROR: Wrong real data is read back by H5Dread_f ',fld(i)%b(j), fldr(i)%b(j), total_error)
ENDDO
ENDDO
CALL h5tclose_f(TYPE,error)
CALL check("h5tclose_f", error, total_error)
CALL h5tclose_f(array_dt,error)
CALL check("h5tclose_f", error, total_error)
CALL h5dget_type_f(dataset, type, error)
CALL check("h5dget_type_f", error, total_error)
! Read the entire dataset again
f_ptr = C_LOC(cfr(1))
CALL H5Dread_f(dataset, TYPE, f_ptr, error)
CALL check("H5Dread_f", error, total_error)
! Verify correct data
! -------------------
DO i = 1, LENGTH
DO j = 1, ALEN
CALL VERIFY('ERROR: Wrong integer data is read back by H5Dread_f ',cf(i)%a(j), cfr(i)%a(j), total_error)
CALL VERIFY('ERROR: Wrong real data is read back by H5Dread_f ',cf(i)%b(j),cfr(i)%b(j), total_error)
CALL VERIFY('ERROR: Wrong double data is read back by H5Dread_f ',cf(i)%c(j), cfr(i)%c(j), total_error)
ENDDO
ENDDO
CALL h5dclose_f(dataset, error)
CALL check("h5dclose_f", error, total_error)
CALL h5tclose_f(type,error)
CALL check("h5tclose_f", error, total_error)
CALL h5fclose_f(fid,error)
CALL check("h5fclose_f", error, total_error)
!**************************************************
! Reopen the file and print out all the data again
!**************************************************
CALL h5fopen_f (FILENAME, H5F_ACC_RDWR_F, fid, error)
CALL check("h5fopen_f", error, total_error)
CALL h5dopen_f(fid, FIELDNAME, dataset, error)
CALL check("h5dopen_f", error, total_error)
CALL h5dget_type_f(dataset, type, error)
CALL check("h5dget_type_f", error, total_error)
! Reset the data to read in
! -------------------------
DO i = 1, LENGTH
cfr(i)%a(:) = 0
cfr(i)%b(:) = 0
cfr(i)%c(:) = 0
ENDDO
f_ptr = C_LOC(cfr(1))
CALL H5Dread_f(dataset, TYPE, f_ptr, error)
CALL check("H5Dread_f", error, total_error)
! Verify correct data
! -------------------
DO i = 1, LENGTH
DO j = 1, ALEN
CALL VERIFY('ERROR: Wrong integer data is read back by H5Dread_f ',cf(i)%a(j), cfr(i)%a(j), total_error)
CALL VERIFY('ERROR: Wrong real data is read back by H5Dread_f ',cf(i)%b(j),cfr(i)%b(j), total_error)
CALL VERIFY('ERROR: Wrong double data is read back by H5Dread_f ',cf(i)%c(j), cfr(i)%c(j), total_error)
ENDDO
ENDDO
CALL h5dclose_f(dataset, error)
CALL check("h5dclose_f", error, total_error)
CALL h5tclose_f(type,error)
CALL check("h5tclose_f", error, total_error)
CALL h5fclose_f(fid,error)
CALL check("h5fclose_f", error, total_error)
END SUBROUTINE test_array_bkg
SUBROUTINE test_h5kind_to_type(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
INTEGER, PARAMETER :: int_kind_1 = SELECTED_INT_KIND(2) !should map to INTEGER*1 on most modern processors
INTEGER, PARAMETER :: int_kind_4 = SELECTED_INT_KIND(4) !should map to INTEGER*2 on most modern processors
INTEGER, PARAMETER :: int_kind_8 = SELECTED_INT_KIND(9) !should map to INTEGER*4 on most modern processors
INTEGER, PARAMETER :: int_kind_16 = SELECTED_INT_KIND(18) !should map to INTEGER*8 on most modern processors
#if H5_HAVE_Fortran_INTEGER_SIZEOF_16!=0
INTEGER, PARAMETER :: int_kind_32 = SELECTED_INT_KIND(36) !should map to INTEGER*16 on most modern processors
INTEGER(int_kind_32), DIMENSION(1:4), TARGET :: dset_data_i32, data_out_i32
INTEGER(HID_T) :: dset_id32 ! Dataset identifier
CHARACTER(LEN=6), PARAMETER :: dsetname16 = "dset16" ! Dataset name
#endif
INTEGER, PARAMETER :: real_kind_7 = C_FLOAT !should map to REAL*4 on most modern processors
INTEGER, PARAMETER :: real_kind_15 = C_DOUBLE !should map to REAL*8 on most modern processors
! Check if C has quad precision extension
#if H5_HAVE_FLOAT128!=0
! Check if Fortran supports quad precision
# if H5_PAC_FC_MAX_REAL_PRECISION > 26
INTEGER, PARAMETER :: real_kind_31 = SELECTED_REAL_KIND(31)
# else
INTEGER, PARAMETER :: real_kind_31 = SELECTED_REAL_KIND(15,307)
# endif
#else
! Check if the default of long double is quad precision
# if H5_PAC_C_MAX_REAL_PRECISION > 26
# if H5_PAC_FC_MAX_REAL_PRECISION > 26
INTEGER, PARAMETER :: real_kind_31 = SELECTED_REAL_KIND(31)
# else
INTEGER, PARAMETER :: real_kind_31 = SELECTED_REAL_KIND(15,307)
# endif
# else
INTEGER, PARAMETER :: real_kind_31 = SELECTED_REAL_KIND(15,307)
# endif
#endif
REAL(real_kind_31), DIMENSION(1:4), TARGET :: dset_data_r31, data_out_r31
INTEGER(HID_T) :: dset_idr16 ! Dataset identifier
CHARACTER(LEN=7), PARAMETER :: dsetnamer16 = "dsetr16" ! Dataset name
CHARACTER(LEN=12), PARAMETER :: filename = "dsetf_F03.h5" ! File name
CHARACTER(LEN=5), PARAMETER :: dsetname1 = "dset1" ! Dataset name
CHARACTER(LEN=5), PARAMETER :: dsetname2 = "dset2" ! Dataset name
CHARACTER(LEN=5), PARAMETER :: dsetname4 = "dset4" ! Dataset name
CHARACTER(LEN=5), PARAMETER :: dsetname8 = "dset8" ! Dataset name
CHARACTER(LEN=6), PARAMETER :: dsetnamer = "dsetr" ! Dataset name
CHARACTER(LEN=6), PARAMETER :: dsetnamer4 = "dsetr4" ! Dataset name
CHARACTER(LEN=6), PARAMETER :: dsetnamer8 = "dsetr8" ! Dataset name
INTEGER(HID_T) :: file_id ! File identifier
INTEGER(HID_T) :: dset_id1 ! Dataset identifier
INTEGER(HID_T) :: dset_id4 ! Dataset identifier
INTEGER(HID_T) :: dset_id8 ! Dataset identifier
INTEGER(HID_T) :: dset_id16 ! Dataset identifier
INTEGER(HID_T) :: dset_idr ! Dataset identifier
INTEGER(HID_T) :: dset_idr4 ! Dataset identifier
INTEGER(HID_T) :: dset_idr8 ! Dataset identifier
INTEGER :: error ! Error flag
INTEGER :: i
! Data buffers:
INTEGER(int_kind_1), DIMENSION(1:4), TARGET :: dset_data_i1, data_out_i1
INTEGER(int_kind_4), DIMENSION(1:4), TARGET :: dset_data_i4, data_out_i4
INTEGER(int_kind_8), DIMENSION(1:4), TARGET :: dset_data_i8, data_out_i8
INTEGER(int_kind_16), DIMENSION(1:4), TARGET :: dset_data_i16, data_out_i16
REAL, DIMENSION(1:4), TARGET :: dset_data_r, data_out_r
REAL(real_kind_7), DIMENSION(1:4), TARGET :: dset_data_r7, data_out_r7
REAL(real_kind_15), DIMENSION(1:4), TARGET :: dset_data_r15, data_out_r15
INTEGER(HSIZE_T), DIMENSION(1:1) :: data_dims = (/4/)
INTEGER(HID_T) :: dspace_id ! Dataspace identifier
TYPE(C_PTR) :: f_ptr
!
! Initialize the dset_data array.
!
DO i = 1, 4
dset_data_i1(i) = HUGE(0_int_kind_1)-INT(i,int_kind_1)
dset_data_i4(i) = HUGE(0_int_kind_4)-INT(i,int_kind_4)
dset_data_i8(i) = HUGE(0_int_kind_8)-INT(i,int_kind_8)
dset_data_i16(i) = HUGE(0_int_kind_16)-INT(i,int_kind_16)
#if H5_HAVE_Fortran_INTEGER_SIZEOF_16!=0
dset_data_i32(i) = HUGE(0_int_kind_32)-INT(i,int_kind_32)
#endif
dset_data_r(i) = 4.0*ATAN(1.0)-REAL(i-1)
dset_data_r7(i) = 4.0_real_kind_7*ATAN(1.0_real_kind_7)-REAL(i-1,real_kind_7)
dset_data_r15(i) = 4.0_real_kind_15*ATAN(1.0_real_kind_15)-REAL(i-1,real_kind_15)
dset_data_r31(i) = 4.0_real_kind_31*ATAN(1.0_real_kind_31)-REAL(i-1,real_kind_31)
END DO
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, error)
CALL check("h5fcreate_f",error, total_error)
!
! Create dataspaces for datasets
!
CALL h5screate_simple_f(1, data_dims , dspace_id, error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset.
!
CALL H5Dcreate_f(file_id, dsetname1, h5kind_to_type(int_kind_1,H5_INTEGER_KIND), dspace_id, dset_id1, error)
CALL check("H5Dcreate_f",error, total_error)
CALL H5Dcreate_f(file_id, dsetname2, h5kind_to_type(int_kind_4,H5_INTEGER_KIND), dspace_id, dset_id4, error)
CALL check("H5Dcreate_f",error, total_error)
CALL H5Dcreate_f(file_id, dsetname4, h5kind_to_type(int_kind_8,H5_INTEGER_KIND), dspace_id, dset_id8, error)
CALL check("H5Dcreate_f",error, total_error)
CALL H5Dcreate_f(file_id, dsetname8, h5kind_to_type(int_kind_16,H5_INTEGER_KIND), dspace_id, dset_id16, error)
CALL check("H5Dcreate_f",error, total_error)
#if H5_HAVE_Fortran_INTEGER_SIZEOF_16!=0
CALL H5Dcreate_f(file_id, dsetname16, h5kind_to_type(int_kind_32,H5_INTEGER_KIND), dspace_id, dset_id32, error)
CALL check("H5Dcreate_f",error, total_error)
#endif
CALL H5Dcreate_f(file_id, dsetnamer, H5T_NATIVE_REAL, dspace_id, dset_idr, error)
CALL check("H5Dcreate_f",error, total_error)
CALL H5Dcreate_f(file_id, dsetnamer4, h5kind_to_type(real_kind_7,H5_REAL_KIND), dspace_id, dset_idr4, error)
CALL check("H5Dcreate_f",error, total_error)
CALL H5Dcreate_f(file_id, dsetnamer8, h5kind_to_type(real_kind_15,H5_REAL_KIND), dspace_id, dset_idr8, error)
CALL check("H5Dcreate_f",error, total_error)
!#ifdef H5_HAVE_FLOAT128
CALL H5Dcreate_f(file_id, dsetnamer16, h5kind_to_type(real_kind_31,H5_REAL_KIND), dspace_id, dset_idr16, error)
CALL check("H5Dcreate_f",error, total_error)
!#endif
!
! Write the dataset.
!
f_ptr = C_LOC(dset_data_i1(1))
CALL h5dwrite_f(dset_id1, h5kind_to_type(int_kind_1,H5_INTEGER_KIND), f_ptr, error)
CALL check("H5Dwrite_f",error, total_error)
f_ptr = C_LOC(dset_data_i4(1))
CALL h5dwrite_f(dset_id4, h5kind_to_type(int_kind_4,H5_INTEGER_KIND), f_ptr, error)
CALL check("H5Dwrite_f",error, total_error)
f_ptr = C_LOC(dset_data_i8(1))
CALL h5dwrite_f(dset_id8, h5kind_to_type(int_kind_8,H5_INTEGER_KIND), f_ptr, error)
CALL check("H5Dwrite_f",error, total_error)
f_ptr = C_LOC(dset_data_i16(1))
CALL h5dwrite_f(dset_id16, h5kind_to_type(int_kind_16,H5_INTEGER_KIND), f_ptr, error)
CALL check("H5Dwrite_f",error, total_error)
#if H5_HAVE_Fortran_INTEGER_SIZEOF_16!=0
f_ptr = C_LOC(dset_data_i32(1))
CALL h5dwrite_f(dset_id32, h5kind_to_type(int_kind_32,H5_INTEGER_KIND), f_ptr, error)
CALL check("H5Dwrite_f",error, total_error)
#endif
f_ptr = C_LOC(dset_data_r(1))
CALL h5dwrite_f(dset_idr, H5T_NATIVE_REAL, f_ptr, error)
CALL check("H5Dwrite_f",error, total_error)
f_ptr = C_LOC(dset_data_r7(1))
CALL h5dwrite_f(dset_idr4, h5kind_to_type(real_kind_7,H5_REAL_KIND), f_ptr, error)
CALL check("H5Dwrite_f",error, total_error)
f_ptr = C_LOC(dset_data_r15(1))
CALL h5dwrite_f(dset_idr8, h5kind_to_type(real_kind_15,H5_REAL_KIND), f_ptr, error)
CALL check("H5Dwrite_f",error, total_error)
!#ifdef H5_HAVE_FLOAT128
f_ptr = C_LOC(dset_data_r31(1))
CALL h5dwrite_f(dset_idr16, h5kind_to_type(real_kind_31,H5_REAL_KIND), f_ptr, error)
CALL check("H5Dwrite_f",error, total_error)
!#endif
!
! Close the file
!
CALL h5fclose_f(file_id, error)
CALL check("h5fclose_f",error, total_error)
! Open the file
CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file_id, error)
CALL check("h5fopen_f",error, total_error)
!
! Read the dataset.
!
! Read data back into an integer size that is larger then the original size used for
! writing the data
f_ptr = C_LOC(data_out_i1(1))
CALL h5dread_f(dset_id1, h5kind_to_type(int_kind_1,H5_INTEGER_KIND), f_ptr, error)
CALL check("h5dread_f",error, total_error)
f_ptr = C_LOC(data_out_i4(1))
CALL h5dread_f(dset_id4, h5kind_to_type(int_kind_4,H5_INTEGER_KIND), f_ptr, error)
CALL check("h5dread_f",error, total_error)
f_ptr = C_LOC(data_out_i8(1))
CALL h5dread_f(dset_id8, h5kind_to_type(int_kind_8,H5_INTEGER_KIND), f_ptr, error)
CALL check("h5dread_f",error, total_error)
f_ptr = C_LOC(data_out_i16(1))
CALL h5dread_f(dset_id16, h5kind_to_type(int_kind_16,H5_INTEGER_KIND), f_ptr, error)
CALL check("h5dread_f",error, total_error)
#if H5_HAVE_Fortran_INTEGER_SIZEOF_16!=0
f_ptr = C_LOC(data_out_i32(1))
CALL h5dread_f(dset_id32, h5kind_to_type(int_kind_32,H5_INTEGER_KIND), f_ptr, error)
CALL check("h5dread_f",error, total_error)
#endif
f_ptr = C_LOC(data_out_r(1))
CALL h5dread_f(dset_idr, H5T_NATIVE_REAL, f_ptr, error)
CALL check("h5dread_f",error, total_error)
f_ptr = C_LOC(data_out_r7(1))
CALL h5dread_f(dset_idr4, h5kind_to_type(real_kind_7,H5_REAL_KIND), f_ptr, error)
CALL check("h5dread_f",error, total_error)
f_ptr = C_LOC(data_out_r15(1))
CALL h5dread_f(dset_idr8, h5kind_to_type(real_kind_15,H5_REAL_KIND), f_ptr, error)
CALL check("h5dread_f",error, total_error)
f_ptr = C_LOC(data_out_r31(1))
CALL h5dread_f(dset_idr16, h5kind_to_type(real_kind_31,H5_REAL_KIND), f_ptr, error)
CALL check("h5dread_f",error, total_error)
DO i = 1, 4
CALL verify("h5kind_to_type",dset_data_i1(i),data_out_i1(i),total_error)
CALL verify("h5kind_to_type",dset_data_i4(i),data_out_i4(i),total_error)
CALL verify("h5kind_to_type",dset_data_i8(i),data_out_i8(i),total_error)
CALL verify("h5kind_to_type",dset_data_i16(i),data_out_i16(i),total_error)
#if H5_HAVE_Fortran_INTEGER_SIZEOF_16!=0
CALL verify("h5kind_to_type",dset_data_i32(i),data_out_i32(i),total_error)
#endif
CALL verify("h5kind_to_type",dset_data_r(i),data_out_r(i),total_error)
CALL verify("h5kind_to_type",dset_data_r7(i),data_out_r7(i),total_error)
CALL verify("h5kind_to_type",dset_data_r15(i),data_out_r15(i),total_error)
CALL verify("h5kind_to_type",dset_data_r31(i),data_out_r31(i),total_error)
END DO
!
! Close the dataset.
!
CALL h5dclose_f(dset_id1, error)
CALL check("h5dclose_f",error, total_error)
CALL h5dclose_f(dset_id4, error)
CALL check("h5dclose_f",error, total_error)
CALL h5dclose_f(dset_id8, error)
CALL check("h5dclose_f",error, total_error)
CALL h5dclose_f(dset_id16, error)
CALL check("h5dclose_f",error, total_error)
CALL h5dclose_f(dset_idr4, error)
CALL check("h5dclose_f",error, total_error)
CALL h5dclose_f(dset_idr8, error)
CALL check("h5dclose_f",error, total_error)
!
! Close the file.
!
CALL h5fclose_f(file_id, error)
CALL check("h5fclose_f",error, total_error)
END SUBROUTINE test_h5kind_to_type
!************************************************************
!
! This test reads and writes array datatypes
! to a dataset. The test first writes integers arrays of
! dimension ADIM0xADIM1 to a dataset with a dataspace of
! DIM0, then closes the file. Next, it reopens the file,
! reads back the data.
!
!************************************************************
SUBROUTINE t_array(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=19), PARAMETER :: filename = "t_array_F03.h5"
CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
INTEGER , PARAMETER :: dim0 = 4
INTEGER , PARAMETER :: adim0 = 3
INTEGER , PARAMETER :: adim1 = 5
INTEGER(HID_T) :: file, filetype, memtype, space, dset ! Handles
INTEGER(HSIZE_T), DIMENSION(1:1) :: dims = (/dim0/)
INTEGER(HSIZE_T), DIMENSION(1:2) :: adims = (/adim0, adim1/)
INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
INTEGER, DIMENSION(1:dim0, 1:adim0, 1:adim1), TARGET :: wdata ! Write buffer
INTEGER, DIMENSION(:,:,:), ALLOCATABLE, TARGET :: rdata ! Read buffer
INTEGER :: i, j, k
TYPE(C_PTR) :: f_ptr
INTEGER :: error ! Error flag
!
! Initialize data. i is the element in the dataspace, j and k the
! elements within the array datatype.
!
DO i = 1, dim0
DO j = 1, adim0
DO k = 1, adim1
wdata(i,j,k) = (i-1)*(j-1)-(j-1)*(k-1)+(i-1)*(k-1)
ENDDO
ENDDO
ENDDO
!
! Create a new file using the default properties.
!
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f",error, error)
!
! Create array datatypes for file and memory.
!
CALL H5Tarray_create_f(INT(H5T_STD_I64LE, HID_T), 2, adims, filetype, error)
CALL check("H5Tarray_create_f",error, total_error)
CALL H5Tarray_create_f(H5T_NATIVE_INTEGER, 2, adims, memtype, error)
CALL check("H5Tarray_create_f",error, total_error)
!
! Create dataspace. Setting maximum size to be the current size.
!
CALL h5screate_simple_f(1, dims, space, error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset and write the array data to it.
!
CALL h5dcreate_f(file, dataset, filetype, space, dset, error)
CALL check("h5dcreate_f",error, total_error)
f_ptr = C_LOC(wdata)
CALL h5dwrite_f(dset, memtype, f_ptr, error)
CALL check("h5dwrite_f",error, total_error)
!
! Close and release resources.
!
CALL H5Dclose_f(dset, error)
CALL check("h5dclose_f",error, total_error)
CALL H5Sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(filetype, error)
CALL check("h5tclose_f",error, total_error)
CALL H5Tclose_f(memtype, error)
CALL check("h5tclose_f",error, total_error)
CALL H5Fclose_f(file, error)
CALL check("h5fclose_f",error, total_error)
!
! Now we begin the read section of this example.
!
! Open file, dataset, and attribute.
!
CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
CALL check("h5fopen_f",error, total_error)
CALL h5dopen_f(file, dataset, dset, error)
CALL check("h5dopen_f",error, total_error)
!
! Get the datatype and its dimensions.
!
CALL h5dget_type_f(dset, filetype, error)
CALL check("h5dget_type_f",error, error)
CALL H5Tget_array_dims_f(filetype, adims, error)
CALL check("h5dget_type_f",error, total_error)
CALL VERIFY("H5Tget_array_dims_f", adims(1), INT(adim0,hsize_t), total_error)
CALL VERIFY("H5Tget_array_dims_f", adims(2), INT(adim1,hsize_t), total_error)
!
! Get dataspace and allocate memory for read buffer. This is a
! three dimensional attribute when the array datatype is included.
!
CALL H5Dget_space_f(dset, space, error)
CALL check("H5Dget_space_f",error, error)
CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, error)
CALL check("H5Sget_simple_extent_dims_f",error, total_error)
CALL VERIFY("H5Sget_simple_extent_dims_f", dims(1), INT(dim0,hsize_t), total_error)
ALLOCATE(rdata(1:dims(1),1:adims(1),1:adims(2)))
!
! Create the memory datatype.
!
CALL H5Tarray_create_f(H5T_NATIVE_INTEGER, 2, adims, memtype, error)
CALL check("H5Tarray_create_f",error, total_error)
!
! Read the data.
!
f_ptr = C_LOC(rdata)
CALL H5Dread_f(dset, memtype, f_ptr, error)
CALL check("H5Dread_f",error, total_error)
!
! Output the data to the screen.
!
i_loop: DO i = 1, INT(dims(1))
DO j=1, INT(adim0)
DO k = 1, INT(adim1)
CALL VERIFY("H5Sget_simple_extent_dims_f", rdata(i,j,k), wdata(i,j,k), total_error)
IF(total_error.NE.0) EXIT i_loop
ENDDO
ENDDO
ENDDO i_loop
!
! Close and release resources.
!
DEALLOCATE(rdata)
CALL H5Dclose_f(dset, error)
CALL check("h5dclose_f",error, total_error)
CALL H5Sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(filetype, error)
CALL check("h5tclose_f",error, total_error)
CALL H5Tclose_f(memtype, error)
CALL check("h5tclose_f",error, total_error)
CALL H5Fclose_f(file, error)
CALL check("h5fclose_f",error, total_error)
END SUBROUTINE t_array
SUBROUTINE t_enum(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=19), PARAMETER :: filename = "t_enum_F03.h5"
CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
INTEGER , PARAMETER :: dim0 = 4
INTEGER , PARAMETER :: dim1 = 7
INTEGER(HID_T) :: F_BASET ! File base type
INTEGER(HID_T) :: M_BASET ! Memory base type
INTEGER(SIZE_T) , PARAMETER :: NAME_BUF_SIZE = 16
! Enumerated type
INTEGER, PARAMETER :: SOLID=0, LIQUID=1, GAS=2, PLASMA=3
INTEGER(HID_T) :: file, filetype, memtype, space, dset ! Handles
INTEGER(hsize_t), DIMENSION(1:2) :: dims = (/dim0, dim1/)
INTEGER, DIMENSION(1:dim0, 1:dim1), TARGET :: wdata ! Write buffer
INTEGER, DIMENSION(:,:), ALLOCATABLE, TARGET :: rdata ! Read buffer
INTEGER, DIMENSION(1:1), TARGET :: val
CHARACTER(LEN=6), DIMENSION(1:4) :: &
names = (/"SOLID ", "LIQUID", "GAS ", "PLASMA"/)
CHARACTER(LEN=NAME_BUF_SIZE) :: name
INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
INTEGER :: i, j, idx
TYPE(C_PTR) :: f_ptr
INTEGER :: error ! Error flag
!
! Initialize DATA.
!
F_BASET = H5T_STD_I16BE ! File base type
M_BASET = H5T_NATIVE_INTEGER ! Memory base type
DO i = 1, dim0
DO j = 1, dim1
wdata(i,j) = MOD( (j-1)*(i-1), PLASMA+1)
ENDDO
ENDDO
!
! Create a new file using the default properties.
!
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f",error, total_error)
!
! Create the enumerated datatypes for file and memory. This
! process is simplified IF native types are used for the file,
! as only one type must be defined.
!
CALL h5tenum_create_f(F_BASET, filetype, error)
CALL check("h5tenum_create_f",error, total_error)
CALL h5tenum_create_f(M_BASET, memtype, error)
CALL check("h5tenum_create_f",error, total_error)
DO i = SOLID, PLASMA
!
! Insert enumerated value for memtype.
!
val(1) = i
f_ptr = C_LOC(val(1))
CALL H5Tenum_insert_f(memtype, TRIM(names(i+1)), f_ptr, error)
CALL check("H5Tenum_insert_f", error, total_error)
!
! Insert enumerated value for filetype. We must first convert
! the numerical value val to the base type of the destination.
!
f_ptr = C_LOC(val(1))
CALL H5Tconvert_f(M_BASET, F_BASET, INT(1,SIZE_T), f_ptr, error)
CALL check("H5Tconvert_f",error, total_error)
IF(i.GE.1)THEN ! test both F90 and F03 APIs
CALL H5Tenum_insert_f(filetype, TRIM(names(i+1)), f_ptr, error)
ELSE
CALL H5Tenum_insert_f(filetype, TRIM(names(i+1)), val(1), error)
ENDIF
CALL check("H5Tenum_insert_f",error, total_error)
ENDDO
!
! Create dataspace. Setting maximum size to be the current size.
!
CALL h5screate_simple_f(2, dims, space, total_error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset and write the enumerated data to it.
!
CALL h5dcreate_f(file, dataset, filetype, space, dset, error)
CALL check("h5dcreate_f",error, total_error)
f_ptr = C_LOC(wdata(1,1))
CALL h5dwrite_f(dset, memtype, f_ptr, error)
CALL check("h5dwrite_f",error, total_error)
!
! Close and release resources.
!
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL h5tclose_f(filetype, error)
CALL check("h5tclose_f",error, total_error)
CALL h5fclose_f(file , error)
CALL check("h5fclose_f",error, total_error)
!
! Now we begin the read section of this example.
!
! Open file and dataset.
!
CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
CALL check("h5fopen_f",error, total_error)
CALL h5dopen_f (file, dataset, dset, error)
CALL check("h5dopen_f",error, total_error)
CALL h5dopen_f(file, dataset, dset, error)
CALL check("h5dopen_f",error, total_error)
!
! Get dataspace and allocate memory for read buffer.
!
CALL h5dget_space_f(dset,space, error)
CALL check("H5Dget_space_f",error, total_error)
CALL h5sget_simple_extent_dims_f(space, dims, maxdims, error)
CALL check("H5Sget_simple_extent_dims_f",error, total_error)
CALL VERIFY("H5Sget_simple_extent_dims_f", dims(1), INT(dim0,hsize_t), total_error)
CALL VERIFY("H5Sget_simple_extent_dims_f", dims(2), INT(dim1,hsize_t), total_error)
ALLOCATE(rdata(1:dims(1),1:dims(2)))
!
! Read the data.
!
f_ptr = C_LOC(rdata(1,1))
CALL h5dread_f(dset, memtype, f_ptr, error)
CALL check("H5Dread_f",error, total_error)
!
! Output the data to the screen.
!
i_loop: DO i = 1, INT(dims(1))
DO j = 1, INT(dims(2))
!
! Get the name of the enumeration member.
!
CALL h5tenum_nameof_f( memtype, rdata(i,j), NAME_BUF_SIZE, name, error)
CALL check("h5tenum_nameof_f",error, total_error)
idx = MOD( (j-1)*(i-1), PLASMA+1 ) + 1
CALL verify("h5tenum_nameof_f",TRIM(name),TRIM(names(idx)), total_error)
IF(total_error.NE.0) EXIT i_loop
ENDDO
ENDDO i_loop
!
! Close and release resources.
!
DEALLOCATE(rdata)
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL h5tclose_f(memtype, error)
CALL check("h5tclose_f",error, total_error)
CALL h5fclose_f(file , error)
CALL check("h5fclose_f",error, total_error)
END SUBROUTINE t_enum
SUBROUTINE t_bit(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=20), PARAMETER :: filename = "t_bit_F03.h5"
CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
INTEGER , PARAMETER :: dim0 = 4
INTEGER , PARAMETER :: dim1 = 7
INTEGER(HID_T) :: file, space, dset ! Handles
INTEGER(HSIZE_T), DIMENSION(1:2) :: dims = (/dim0, dim1/)
INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
INTEGER(C_SIGNED_CHAR), DIMENSION(1:dim0, 1:dim1), TARGET :: wdata ! Write buffer
INTEGER(C_SIGNED_CHAR), DIMENSION(:,:), ALLOCATABLE, TARGET :: rdata ! Read buffer
INTEGER :: A, B, C, D
INTEGER :: Aw, Bw, Cw, Dw
INTEGER :: i, j
INTEGER, PARAMETER :: hex = INT(Z'00000003')
TYPE(C_PTR) :: f_ptr
INTEGER :: error ! Error flag
!
! Initialize data. We will manually pack 4 2-bit integers into
! each unsigned char data element.
!
DO i = 0, dim0-1
DO j = 0, dim1-1
wdata(i+1,j+1) = 0
wdata(i+1,j+1) = IOR( wdata(i+1,j+1), INT(IAND(i * j - j, hex),C_SIGNED_CHAR) ) ! Field "A"
wdata(i+1,j+1) = IOR( wdata(i+1,j+1), INT(ISHFT(IAND(i,hex),2),C_SIGNED_CHAR) ) ! Field "B"
wdata(i+1,j+1) = IOR( wdata(i+1,j+1), INT(ISHFT(IAND(j,hex),4),C_SIGNED_CHAR) ) ! Field "C"
wdata(i+1,j+1) = IOR( wdata(i+1,j+1), INT(ISHFT(IAND(i+j,hex),6),C_SIGNED_CHAR) ) ! Field "D"
ENDDO
ENDDO
!
! Create a new file using the default properties.
!
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f",error, total_error)
!
! Create dataspace. Setting maximum size to be the current size.
!
CALL h5screate_simple_f(2, dims, space, error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset and write the bitfield data to it.
!
CALL H5Dcreate_f(file, dataset, H5T_STD_B8BE, space, dset, error)
CALL check("h5dcreate_f",error, total_error)
f_ptr = C_LOC(wdata(1,1))
CALL H5Dwrite_f(dset, H5T_NATIVE_B8, f_ptr, error)
CALL check("h5dwrite_f",error, total_error)
!
! Close and release resources.
!
CALL H5Dclose_f(dset, error)
CALL check("h5dclose_f",error, total_error)
CALL H5Sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Fclose_f(file, error)
CALL check("h5fclose_f",error, total_error)
!
! Now we begin the read section of this example.
!
! Open file, dataset.
!
CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
CALL check("h5fopen_f",error, total_error)
CALL h5dopen_f(file, dataset, dset, error)
CALL check("h5dopen_f",error, total_error)
!
! Get dataspace and allocate memory for read buffer.
!
CALL H5Dget_space_f(dset, space, error)
CALL check("H5Dget_space_f",error, total_error)
CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, error)
CALL check("H5Sget_simple_extent_dims_f",error, total_error)
CALL VERIFY("H5Sget_simple_extent_dims_f", dims(1), INT(dim0,hsize_t), total_error)
CALL VERIFY("H5Sget_simple_extent_dims_f", dims(2), INT(dim1,hsize_t), total_error)
ALLOCATE(rdata(1:dims(1),1:dims(2)))
!
! Read the data.
!
f_ptr = C_LOC(rdata)
CALL H5Dread_f(dset, H5T_NATIVE_B8, f_ptr, error)
CALL check("H5Dread_f",error, total_error)
!
! Output the data to the screen.
!
i_loop: DO i = 1, INT(dims(1))
DO j = 1, INT(dims(2))
A = IAND(rdata(i,j), INT(hex,C_SIGNED_CHAR)) ! Retrieve field "A"
B = IAND(ISHFT(rdata(i,j),-2), INT(hex,C_SIGNED_CHAR)) ! Retrieve field "B"
C = IAND(ISHFT(rdata(i,j),-4), INT(hex,C_SIGNED_CHAR)) ! Retrieve field "C"
D = IAND(ISHFT(rdata(i,j),-6), INT(hex,C_SIGNED_CHAR)) ! Retrieve field "D"
Aw = IAND(wdata(i,j), INT(hex,C_SIGNED_CHAR))
Bw = IAND(ISHFT(wdata(i,j),-2), INT(hex,C_SIGNED_CHAR))
Cw = IAND(ISHFT(wdata(i,j),-4), INT(hex,C_SIGNED_CHAR))
Dw = IAND(ISHFT(wdata(i,j),-6), INT(hex,C_SIGNED_CHAR))
CALL VERIFY("bitfield", A, Aw, total_error)
CALL VERIFY("bitfield", B, Bw, total_error)
CALL VERIFY("bitfield", C, Cw, total_error)
CALL VERIFY("bitfield", D, Dw, total_error)
IF(total_error.NE.0) EXIT i_loop
ENDDO
ENDDO i_loop
!
! Close and release resources.
!
DEALLOCATE(rdata)
CALL H5Dclose_f(dset, error)
CALL check("h5dclose_f",error, total_error)
CALL H5Sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Fclose_f(file, error)
CALL check("h5fclose_f",error, total_error)
END SUBROUTINE t_bit
SUBROUTINE t_opaque(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=20), PARAMETER :: filename = "t_opaque_F03.h5"
CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
INTEGER , PARAMETER :: dim0 = 4
INTEGER(SIZE_T) , PARAMETER :: size = 7
INTEGER(HID_T) :: file, space, dtype, dset ! Handles
INTEGER(size_t) :: len
INTEGER(hsize_t), DIMENSION(1:1) :: dims = (/DIM0/)
CHARACTER(LEN=size), DIMENSION(1:dim0), TARGET :: wdata ! Write buffer
CHARACTER(LEN=size), DIMENSION(:), ALLOCATABLE, TARGET :: rdata ! Read buffer
CHARACTER(LEN=size-1) :: str = "OPAQUE"
CHARACTER(LEN=14) :: tag_sm ! Test reading obaque tag into
CHARACTER(LEN=15) :: tag_exact ! buffers that are: to small, exact
CHARACTER(LEN=17) :: tag_big ! and to big.
INTEGER :: taglen
INTEGER(HSIZE_T), DIMENSION(1:1) :: maxdims
INTEGER(hsize_t) :: i
CHARACTER(LEN=1) :: ichr
TYPE(C_PTR) :: f_ptr
INTEGER :: error
!
! Initialize data.
!
DO i = 1, dim0
WRITE(ichr,'(I1)') i-1
wdata(i) = str//ichr
ENDDO
!
! Create a new file using the default properties.
!
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f",error, total_error)
!
! Create opaque datatype and set the tag to something appropriate.
! For this example we will write and view the data as a character
! array.
!
CALL h5tcreate_f(h5T_OPAQUE_F, size, dtype, error)
CALL check("h5tcreate_f",error, total_error)
CALL h5tset_tag_f(dtype,"Character array",error)
CALL check("h5tset_tag_f",error, total_error)
!
! Create dataspace. Setting maximum size to be the current size.
!
CALL h5screate_simple_f(1, dims, space, error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset and write the opaque data to it.
!
CALL h5dcreate_f(file, dataset, dtype, space, dset, error)
CALL check("h5dcreate_f",error, total_error)
f_ptr = C_LOC(wdata(1)(1:1))
CALL h5dwrite_f(dset, dtype, f_ptr, error)
CALL check("h5dwrite_f",error, total_error)
!
! Close and release resources.
!
CALL H5Dclose_f(dset, error)
CALL check("h5dclose_f",error, total_error)
CALL H5Sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(dtype, error)
CALL check("h5tclose_f",error, total_error)
CALL H5Fclose_f(file, error)
CALL check("h5fclose_f",error, total_error)
!
! Now we begin the read section of this example.
!
! Open file and dataset.
!
CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
CALL check("h5fopen_f",error, total_error)
CALL h5dopen_f(file, dataset, dset, error)
CALL check("h5dopen_f",error, total_error)
!
! Get datatype and properties for the datatype.
!
CALL h5dget_type_f(dset, dtype, error)
CALL check("h5dget_type_f",error, total_error)
CALL h5tget_size_f(dtype, len, error)
CALL check("h5tget_size_f",error, total_error)
! Next tests should return
! opaque_tag = tag = "Character array" and the actual length = 15
! Test reading into a string that is to small
CALL h5tget_tag_f(dtype, tag_sm, taglen, error)
CALL check("h5tget_tag_f",error, total_error)
CALL VERIFY("h5tget_tag_f", taglen, 15, total_error)
CALL verify("h5tget_tag_f",tag_sm,"Character arra", total_error)
! Test reading into a string that is exact
CALL h5tget_tag_f(dtype, tag_exact, taglen, error)
CALL check("h5tget_tag_f",error, total_error)
CALL VERIFY("h5tget_tag_f", taglen, 15, total_error)
CALL verify("h5tget_tag_f",tag_exact,"Character array", total_error)
! Test reading into a string that is to big
CALL h5tget_tag_f(dtype, tag_big, taglen, error)
CALL check("h5tget_tag_f",error, total_error)
CALL VERIFY("h5tget_tag_f", taglen, 15, total_error)
CALL verify("h5tget_tag_f",tag_big,"Character array ", total_error)
!
! Get dataspace and allocate memory for read buffer.
!
CALL h5dget_space_f(dset, space, error)
CALL check("H5Dget_space_f",error, total_error)
CALL h5sget_simple_extent_dims_f(space, dims, maxdims, error)
CALL check("H5Sget_simple_extent_dims_f",error, total_error)
CALL VERIFY("H5Sget_simple_extent_dims_f", dims(1), INT(dim0,hsize_t), total_error)
ALLOCATE(rdata(1:dims(1)))
!
! Read the data.
!
f_ptr = C_LOC(rdata(1)(1:1))
CALL h5dread_f(dset, dtype, f_ptr, error)
CALL check("H5Dread_f",error, total_error)
!
DO i = 1, dims(1)
CALL verify("t_opaque",TRIM(rdata(i)),TRIM(wdata(i)), total_error)
ENDDO
!
! Close and release resources.
!
DEALLOCATE(rdata)
CALL H5Dclose_f(dset, error)
CALL check("h5dclose_f",error, total_error)
CALL H5Sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(dtype, error)
CALL check("h5tclose_f",error, total_error)
CALL H5Fclose_f(file, error)
CALL check("h5fclose_f",error, total_error)
END SUBROUTINE t_opaque
SUBROUTINE t_objref(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=20), PARAMETER :: filename = "t_objref_F03.h5"
CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
INTEGER , PARAMETER :: dim0 = 2
INTEGER(HID_T) :: file, space, dset, obj ! Handles
INTEGER :: error
INTEGER(hsize_t), DIMENSION(1:1) :: dims = (/dim0/)
TYPE(hobj_ref_t_f), DIMENSION(1:dim0), TARGET :: wdata ! Write buffer
TYPE(hobj_ref_t_f), DIMENSION(:), ALLOCATABLE, TARGET :: rdata ! Read buffer
INTEGER :: objtype
INTEGER(SIZE_T) :: name_size
CHARACTER(LEN=80) :: name
INTEGER(HSIZE_T), DIMENSION(1:1) :: maxdims
INTEGER :: i
TYPE(C_PTR) :: f_ptr
!
! Create a new file using the default properties.
!
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f",error, total_error)
!
! Create a dataset with a null dataspace.
!
CALL h5screate_f(H5S_NULL_F,space,error)
CALL check("h5screate_f",error, total_error)
CALL h5dcreate_f(file, "DS2", H5T_STD_I32LE, space, obj, error)
CALL check("h5dcreate_f",error, total_error)
!
CALL h5dclose_f(obj , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
!
! Create a group.
!
CALL h5gcreate_f(file, "G1", obj, error)
CALL check("h5gcreate_f",error, total_error)
CALL h5gclose_f(obj, error)
CALL check("h5gclose_f",error, total_error)
!
! Create references to the previously created objects. note, space_id
! is not needed for object references.
!
f_ptr = C_LOC(wdata(1))
CALL H5Rcreate_f(file, "G1", H5R_OBJECT_F, f_ptr, error)
CALL check("H5Rcreate_f",error, total_error)
f_ptr = C_LOC(wdata(2))
CALL H5Rcreate_f(file, "DS2", H5R_OBJECT_F, f_ptr, error)
CALL check("H5Rcreate_f",error, total_error)
!
! Create dataspace. Setting maximum size to be the current size.
!
CALL h5screate_simple_f(1, dims, space, error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset and write the object references to it.
!
CALL h5dcreate_f(file, dataset, H5T_STD_REF_OBJ, space, dset, error)
CALL check("h5dcreate_f",error, total_error)
f_ptr = C_LOC(wdata(1))
CALL h5dwrite_f(dset, H5T_STD_REF_OBJ, f_ptr, error)
CALL check("h5dwrite_f",error, total_error)
!
! Close and release resources.
!
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL h5fclose_f(file , error)
CALL check("h5fclose_f",error, total_error)
!
! Now we begin the read section of this example.
!
! Open file and dataset.
!
CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
CALL check("h5fopen_f",error, total_error)
CALL h5dopen_f(file, dataset, dset, error)
CALL check("h5dopen_f",error, total_error)
!
! Get dataspace and allocate memory for read buffer.
!
CALL h5dget_space_f(dset, space, error)
CALL check("H5Dget_space_f",error, total_error)
CALL h5sget_simple_extent_dims_f(space, dims, maxdims, error)
CALL check("H5Sget_simple_extent_dims_f",error, total_error)
CALL VERIFY("H5Sget_simple_extent_dims_f", dims(1), INT(dim0,hsize_t), total_error)
ALLOCATE(rdata(1:maxdims(1)))
!
! Read the data.
!
f_ptr = C_LOC(rdata(1))
CALL h5dread_f( dset, H5T_STD_REF_OBJ, f_ptr, error)
CALL check("H5Dread_f",error, total_error)
!
! Output the data to the screen.
!
DO i = 1, INT(maxdims(1))
!
! Open the referenced object, get its name and type.
!
f_ptr = C_LOC(rdata(i))
CALL H5Rdereference_f(dset, H5R_OBJECT_F, f_ptr, obj, error)
CALL check("H5Rdereference_f",error, total_error)
CALL H5Rget_obj_type_f(dset, H5R_OBJECT_F, f_ptr, objtype, error)
CALL check("H5Rget_obj_type_f",error, total_error)
!
! Get the length of the name and name
!
name(:) = ' ' ! initialize string to blanks
CALL H5Iget_name_f(obj, name, 80_size_t, name_size, error)
CALL check("H5Iget_name_f",error, total_error)
!
! Print the object type and close the object.
!
IF(objtype.EQ.H5G_GROUP_F)THEN
CALL verify("t_objref", name(1:name_size),"/G1", total_error)
ELSE IF(objtype.EQ.H5G_DATASET_F)THEN
CALL verify("t_objref", name(1:name_size),"/DS2", total_error)
ELSE
total_error = total_error + 1
ENDIF
CALL h5oclose_f(obj, error)
CALL check("h5oclose_f",error, total_error)
END DO
!
! Close and release resources.
!
DEALLOCATE(rdata)
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL h5fclose_f(file , error)
CALL check("h5fclose_f",error, total_error)
END SUBROUTINE t_objref
SUBROUTINE t_regref(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=22), PARAMETER :: filename = "t_regref_F03.h5"
CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
CHARACTER(LEN=3) , PARAMETER :: dataset2 = "DS2"
INTEGER , PARAMETER :: dim0 = 2
INTEGER , PARAMETER :: ds2dim0 = 16
INTEGER , PARAMETER :: ds2dim1 = 3
INTEGER(HID_T) :: file, memspace, space, dset, dset2 ! Handles
INTEGER :: error
INTEGER(HSIZE_T), DIMENSION(1:1) :: dims = (/dim0/)
INTEGER(HSIZE_T), DIMENSION(1:1) :: dims3
INTEGER(HSIZE_T), DIMENSION(1:2) :: dims2 = (/ds2dim0,ds2dim1/)
INTEGER(HSIZE_T), DIMENSION(1:2,1:4) :: coords = RESHAPE((/2,1,12,3,1,2,5,3/),(/2,4/))
INTEGER(HSIZE_T), DIMENSION(1:2) :: start=(/0,0/),stride=(/11,2/),count=(/2,2/), BLOCK=(/3,1/)
INTEGER(HSIZE_T), DIMENSION(1:1) :: maxdims
INTEGER(hssize_t) :: npoints
TYPE(hdset_reg_ref_t_f03), DIMENSION(1:dim0), TARGET :: wdata ! Write buffer
TYPE(hdset_reg_ref_t_f03), DIMENSION(:), ALLOCATABLE, TARGET :: rdata ! Read buffer
INTEGER(size_t) :: size
CHARACTER(LEN=1), DIMENSION(1:ds2dim0,1:ds2dim1), TARGET :: wdata2
CHARACTER(LEN=80),DIMENSION(1:1), TARGET :: rdata2
CHARACTER(LEN=80) :: name
INTEGER(hsize_t) :: i
TYPE(C_PTR) :: f_ptr
CHARACTER(LEN=ds2dim0) :: chrvar
CHARACTER(LEN=20), DIMENSION(1:2) :: chrref_correct
chrvar = "The quick brown "
READ(chrvar,'(16A1)') wdata2(1:16,1)
chrvar = "fox jumps over "
READ(chrvar,'(16A1)') wdata2(1:16,2)
chrvar = "the 5 lazy dogs "
READ(chrvar,'(16A1)') wdata2(1:16,3)
chrref_correct(1) = 'hdf5'
chrref_correct(2) = 'Therowthedog'
!
! Create a new file using the default properties.
!
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f",error, total_error)
!
! Create a dataset with character data.
!
CALL h5screate_simple_f(2, dims2, space, error)
CALL check("h5screate_simple_f",error, total_error)
CALL h5dcreate_f(file,dataset2, H5T_STD_I8LE, space, dset2, error)
CALL check("h5dcreate_f",error, total_error)
f_ptr = C_LOC(wdata2(1,1))
CALL h5dwrite_f(dset2, H5T_NATIVE_INTEGER_KIND(1), f_ptr, error)
CALL check("h5dwrite_f",error, total_error)
!
! Create reference to a list of elements in dset2.
!
CALL h5sselect_elements_f(space, H5S_SELECT_SET_F, 2, INT(4,size_t), coords, error)
CALL check("h5sselect_elements_f",error, total_error)
f_ptr = C_LOC(wdata(1))
CALL h5rcreate_f(file, DATASET2, H5R_DATASET_REGION_F, f_ptr, error, space)
CALL check("h5rcreate_f",error, total_error)
!
! Create reference to a hyperslab in dset2, close dataspace.
!
CALL h5sselect_hyperslab_f (space, H5S_SELECT_SET_F, start, count, error, stride, block)
CALL check("h5sselect_hyperslab_f",error, total_error)
f_ptr = C_LOC(wdata(2))
CALL h5rcreate_f(file, DATASET2, H5R_DATASET_REGION_F, f_ptr, error, space)
CALL check("h5rcreate_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
!
! Create dataspace. Setting maximum size to the current size.
!
CALL h5screate_simple_f(1, dims, space, error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset and write the region references to it.
!
CALL h5dcreate_f(file, dataset, H5T_STD_REF_DSETREG, space, dset, error)
CALL check("h5dcreate_f",error, total_error)
f_ptr = C_LOC(wdata(1))
CALL h5dwrite_f(dset, H5T_STD_REF_DSETREG, f_ptr, error)
CALL check("h5dwrite_f",error, total_error)
!
! Close and release resources.
!
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5dclose_f(dset2, error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL h5fclose_f(file , error)
CALL check("h5fclose_f",error, total_error)
!
! Now we begin the read section of this example.
!
!
! Open file and dataset.
!
CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
CALL check("h5fopen_f",error, total_error)
CALL h5dopen_f(file, dataset, dset, error)
CALL check("h5dopen_f",error, total_error)
!
! Get dataspace and allocate memory for read buffer.
!
CALL h5dget_space_f(dset, space, error)
CALL check("H5Dget_space_f",error, total_error)
CALL h5sget_simple_extent_dims_f(space, dims, maxdims, error)
CALL check("H5Sget_simple_extent_dims_f",error, total_error)
CALL VERIFY("H5Sget_simple_extent_dims_f", dims(1), INT(dim0,hsize_t), total_error)
ALLOCATE(rdata(1:dims(1)))
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
!
! Read the data.
!
f_ptr = C_LOC(rdata(1))
CALL h5dread_f( dset, H5T_STD_REF_DSETREG, f_ptr, error)
CALL check("H5Dread_f",error, total_error)
!
! Output the data to the screen.
!
DO i = 1, dims(1)
!
! Open the referenced object, retrieve its region as a
! dataspace selection.
!
f_ptr = C_LOC(rdata(i))
CALL H5Rdereference_f(dset, H5R_DATASET_REGION_F, f_ptr, dset2, error)
CALL check("H5Rdereference_f",error, total_error)
CALL H5Rget_region_f(dset, f_ptr, space, error)
CALL check("H5Rget_region_f",error, total_error)
!
! Get the object's name
!
name(:) = ' ' ! initialize string to blanks
CALL H5Iget_name_f(dset2, name, 80_size_t, size, error)
CALL check("H5Iget_name_f",error, total_error)
CALL VERIFY("H5Iget_name_f", INT(size), LEN_TRIM(name), total_error)
CALL verify("H5Iget_name_f",name(1:size),TRIM(name), total_error)
!
! Allocate space for the read buffer.
!
CALL H5Sget_select_npoints_f(space, npoints, error)
CALL check("H5Sget_select_npoints_f",error, total_error)
CALL VERIFY("H5Sget_select_npoints_f", INT(npoints), LEN_TRIM(chrref_correct(i)), total_error)
dims3(1) = npoints
!
! Read the dataset region.
!
CALL h5screate_simple_f(1, dims3, memspace, error)
CALL check("h5screate_simple_f",error, total_error)
f_ptr = C_LOC(rdata2(1)(1:1))
CALL h5dread_f( dset2, H5T_NATIVE_INTEGER_KIND(1), f_ptr, error, memspace, space)
CALL check("H5Dread_f",error, total_error)
CALL verify("h5dread_f",rdata2(1)(1:npoints),TRIM(chrref_correct(i)), total_error)
CALL H5Sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Sclose_f(memspace, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Dclose_f(dset2, error)
CALL check("h5dclose_f",error, total_error)
END DO
!
! Close and release resources.
!
DEALLOCATE(rdata)
CALL H5Dclose_f(dset, error)
CALL check("h5dclose_f",error, total_error)
CALL H5Fclose_f(file, error)
CALL check("h5fclose_f",error, total_error)
END SUBROUTINE t_regref
SUBROUTINE t_vlen(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=18), PARAMETER :: filename = "t_vlen_F03.h5"
CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
INTEGER, PARAMETER :: LEN0 = 3
INTEGER, PARAMETER :: LEN1 = 12
INTEGER(hsize_t) :: dim0
INTEGER(HID_T) :: file, filetype, memtype, space, dset ! Handles
INTEGER :: error
INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
INTEGER :: i, j
! vl data
TYPE vl
INTEGER, DIMENSION(:), POINTER :: DATA
END TYPE vl
TYPE(vl), DIMENSION(:), ALLOCATABLE, TARGET :: ptr
TYPE(hvl_t), DIMENSION(1:2), TARGET :: wdata ! Array of vlen structures
TYPE(hvl_t), DIMENSION(1:2), TARGET :: rdata ! Pointer to vlen structures
INTEGER(hsize_t), DIMENSION(1:1) :: dims = (/2/)
INTEGER, DIMENSION(:), POINTER :: ptr_r
TYPE(C_PTR) :: f_ptr
!
! Initialize variable-length data. wdata(1) is a countdown of
! length LEN0, wdata(2) is a Fibonacci sequence of length LEN1.
!
wdata(1)%len = LEN0
wdata(2)%len = LEN1
ALLOCATE( ptr(1:2) )
ALLOCATE( ptr(1)%data(1:wdata(1)%len) )
ALLOCATE( ptr(2)%data(1:wdata(2)%len) )
DO i=1, INT(wdata(1)%len)
ptr(1)%data(i) = INT(wdata(1)%len) - i + 1 ! 3 2 1
ENDDO
wdata(1)%p = C_LOC(ptr(1)%data(1))
ptr(2)%data(1:2) = 1
DO i = 3, INT(wdata(2)%len)
ptr(2)%data(i) = ptr(2)%data(i-1) + ptr(2)%data(i-2) ! (1 1 2 3 5 8 etc.)
ENDDO
wdata(2)%p = C_LOC(ptr(2)%data(1))
!
! Create a new file using the default properties.
!
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f",error, total_error)
!
! Create variable-length datatype for file and memory.
!
CALL H5Tvlen_create_f(H5T_STD_I32LE, filetype, error)
CALL check("H5Tvlen_create_f",error, total_error)
CALL H5Tvlen_create_f(H5T_NATIVE_INTEGER, memtype, error)
CALL check("H5Tvlen_create_f",error, total_error)
!
! Create dataspace.
!
CALL h5screate_simple_f(1, dims, space, error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset and write the variable-length data to it.
!
CALL H5Dcreate_f(file, dataset, filetype, space, dset, error)
CALL check("h5dcreate_f",error, total_error)
f_ptr = C_LOC(wdata(1))
CALL h5dwrite_f(dset, memtype, f_ptr, error)
CALL check("h5dwrite_f",error, total_error)
!
! Close and release resources. Note the use of H5Dvlen_reclaim
! removes the need to manually deallocate the previously allocated
! data.
!
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(filetype, error)
CALL check("h5tclose_f",error, total_error)
CALL H5Tclose_f(memtype, error)
CALL check("h5tclose_f",error, total_error)
CALL h5fclose_f(file , error)
CALL check("h5fclose_f",error, total_error)
!
! Now we begin the read section of this example.
!
! Open file and dataset.
!
CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
CALL check("h5fopen_f",error, total_error)
CALL h5dopen_f(file, dataset, dset, error)
CALL check("h5dopen_f",error, total_error)
!
! Get dataspace and allocate memory for array of vlen structures.
! This does not actually allocate memory for the vlen data, that
! will be done by the library.
!
CALL H5Dget_space_f(dset, space, error)
CALL check("H5Dget_space_f",error, total_error)
dim0 = dims(1)
CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, error)
CALL check("H5Sget_simple_extent_dims_f",error, total_error)
CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(1)), INT(dim0), total_error)
!
! Create the memory datatype.
!
CALL H5Tvlen_create_f(H5T_NATIVE_INTEGER, memtype, error)
CALL check("H5Tvlen_create_f",error, total_error)
!
! Read the data.
!
f_ptr = C_LOC(rdata(1))
CALL H5Dread_f(dset, memtype, f_ptr, error)
CALL check("H5Dread_f",error, total_error)
DO i = 1, INT(dims(1))
CALL c_f_pointer(rdata(i)%p, ptr_r, [rdata(i)%len] )
DO j = 1, INT(rdata(i)%len)
CALL VERIFY("t_vlen", ptr_r(j), ptr(i)%data(j), total_error)
ENDDO
ENDDO
!
! Close and release resources.
!
DEALLOCATE(ptr)
CALL h5dvlen_reclaim_f(memtype, space, H5P_DEFAULT_F, f_ptr, error)
CALL h5dclose_f(dset, error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(memtype, error)
CALL check("h5tclose_f",error, total_error)
CALL h5fclose_f(file, error)
CALL check("h5fclose_f",error, total_error)
END SUBROUTINE t_vlen
SUBROUTINE t_vlstring(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=18), PARAMETER :: filename = "t_vlstring.h5"
CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
INTEGER(SIZE_T), PARAMETER :: dim0 = 4
INTEGER(SIZE_T), PARAMETER :: sdim = 7
INTEGER(HID_T) :: file, filetype, space, dset ! Handles
INTEGER :: error
INTEGER(HSIZE_T), DIMENSION(1:1) :: dims = (/dim0/)
INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
CHARACTER(LEN=sdim), DIMENSION(1:dim0), TARGET :: &
wdata = (/"Parting", "is such", "sweet ", "sorrow."/) ! Write buffer
CHARACTER(LEN=sdim), DIMENSION(:), ALLOCATABLE :: rdata ! Read buffer
INTEGER(HSIZE_T), DIMENSION(2) :: data_dims = (/sdim,dim0/)
INTEGER(SIZE_T), DIMENSION(4) :: str_len = (/7,7,5,7/)
INTEGER(hsize_t) :: i
!
! Create a new file using the default properties.
!
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f",error, total_error)
!
! Create file and memory datatypes. For this example we will save
! the strings as C variable length strings, H5T_STRING is defined
! as a variable length string.
!
CALL H5Tcopy_f(H5T_STRING, filetype, error)
CALL check("H5Tcopy_f",error, total_error)
CALL H5Tset_strpad_f(filetype, H5T_STR_NULLPAD_F, error)
CALL check("H5Tset_strpad_f",error, total_error)
!
! Create dataspace.
!
CALL h5screate_simple_f(1, dims, space, error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset and write the variable-length string data to
! it.
!
CALL h5dcreate_f(file, dataset, filetype, space, dset, error)
CALL check("h5dcreate_f",error, total_error)
CALL h5dwrite_vl_f(dset, filetype, wdata, data_dims, str_len, error, space)
CALL check("h5dwrite_vl_f",error, total_error)
!
! Close and release resources.
!
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(filetype, error)
CALL check("h5tclose_f",error, total_error)
CALL h5fclose_f(file , error)
CALL check("h5fclose_f",error, total_error)
!
! Now we begin the read section of this example.
!
!
! Open file and dataset.
!
CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
CALL check("h5fopen_f",error, total_error)
CALL h5dopen_f(file, dataset, dset, error)
CALL check("h5dopen_f",error, total_error)
!
! Get the datatype.
!
CALL H5Dget_type_f(dset, filetype, error)
CALL check("H5Dget_type_f",error, total_error)
!
! Get dataspace and allocate memory for read buffer.
!
CALL H5Dget_space_f(dset, space, error)
CALL check("H5Dget_space_f",error, total_error)
CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, error)
CALL check("H5Sget_simple_extent_dims_f",error, total_error)
CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(1)), INT(dim0), total_error)
ALLOCATE(rdata(1:dims(1)))
!
! Read the data.
!
CALL h5dread_vl_f(dset, filetype, rdata, data_dims, str_len, error, space)
CALL check("H5Dread_vl_f",error, total_error)
!
! Output the data to the screen.
!
DO i = 1, dims(1)
CALL verify("h5dopen_f",TRIM(rdata(i)),TRIM(wdata(i)) , total_error)
END DO
DEALLOCATE(rdata)
CALL h5dclose_f(dset, error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(filetype, error)
CALL check("h5tclose_f",error, total_error)
CALL h5fclose_f(file , error)
CALL check("h5fclose_f",error, total_error)
END SUBROUTINE t_vlstring
SUBROUTINE t_vlstring_readwrite(total_error)
! test writing and reading vl string using h5dread_f and h5dwrite_f, C_LOC and C_F_POINTER
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=19), PARAMETER :: filename = "t_vlstringrw_F03.h5"
CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
CHARACTER(LEN=3) , PARAMETER :: dataset2D = "DS2"
INTEGER(HSIZE_T) , PARAMETER :: dim0 = 4
INTEGER(HSIZE_T) , PARAMETER :: dim1 = 2
INTEGER(HID_T) :: file, filetype, space, dset ! Handles
INTEGER(HSIZE_T), DIMENSION(1:1) :: dims = (/dim0/)
INTEGER(HSIZE_T), DIMENSION(1:2) :: dims2D = (/dim1,dim0/)
INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
TYPE(C_PTR), DIMENSION(1:dim0), TARGET :: wdata
CHARACTER(len=7, KIND=c_char), DIMENSION(1:1), TARGET :: A = "123456"//C_NULL_CHAR
CHARACTER(len=5, KIND=c_char), DIMENSION(1:1), TARGET :: B = "7890"//C_NULL_CHAR
CHARACTER(len=4, KIND=c_char), DIMENSION(1:1), TARGET :: C = "abc"//C_NULL_CHAR
CHARACTER(len=3, KIND=c_char), DIMENSION(1:1), TARGET :: D = "df"//C_NULL_CHAR
TYPE(C_PTR), DIMENSION(1:dim1,1:dim0), TARGET :: wdata2D
CHARACTER(len=7, KIND=c_char), DIMENSION(1:1), TARGET :: A11 = "A(1,1)"//C_NULL_CHAR
CHARACTER(len=4, KIND=c_char), DIMENSION(1:1), TARGET :: A12 = "A12"//C_NULL_CHAR
CHARACTER(len=5, KIND=c_char), DIMENSION(1:1), TARGET :: A13 = "A_13"//C_NULL_CHAR
CHARACTER(len=8, KIND=c_char), DIMENSION(1:1), TARGET :: A14 = "A_{1,4}"//C_NULL_CHAR
CHARACTER(len=8, KIND=c_char), DIMENSION(1:1), TARGET :: A21 = "A_{2,1}"//C_NULL_CHAR
CHARACTER(len=5, KIND=c_char), DIMENSION(1:1), TARGET :: A22 = "A_22"//C_NULL_CHAR
CHARACTER(len=4, KIND=c_char), DIMENSION(1:1), TARGET :: A23 = "A23"//C_NULL_CHAR
CHARACTER(len=7, KIND=c_char), DIMENSION(1:1), TARGET :: A24 = "A(2,4)"//C_NULL_CHAR
TYPE(C_PTR), DIMENSION(:), ALLOCATABLE, TARGET :: rdata ! Read buffer
TYPE(C_PTR), DIMENSION(:,:), ALLOCATABLE, TARGET :: rdata2D ! Read 2D buffer
CHARACTER(len=8, kind=c_char), POINTER :: data ! A pointer to a Fortran string
CHARACTER(len=8, kind=c_char), DIMENSION(1:4) :: data_w ! A pointer to a Fortran string
CHARACTER(len=8, kind=c_char), DIMENSION(1:dim1,1:dim0) :: data2D_w ! A pointer to a Fortran string
TYPE(C_PTR) :: f_ptr
INTEGER(hsize_t) :: i, j
INTEGER :: len
INTEGER :: error
! Initialize array of C pointers
wdata(1) = C_LOC(A(1)(1:1))
wdata(2) = C_LOC(B(1)(1:1))
wdata(3) = C_LOC(C(1)(1:1))
wdata(4) = C_LOC(D(1)(1:1))
data_w(1) = A(1)
data_w(2) = B(1)
data_w(3) = C(1)
data_w(4) = D(1)
wdata2D(1,1) = C_LOC(A11(1)(1:1))
wdata2D(1,2) = C_LOC(A12(1)(1:1))
wdata2D(1,3) = C_LOC(A13(1)(1:1))
wdata2D(1,4) = C_LOC(A14(1)(1:1))
wdata2D(2,1) = C_LOC(A21(1)(1:1))
wdata2D(2,2) = C_LOC(A22(1)(1:1))
wdata2D(2,3) = C_LOC(A23(1)(1:1))
wdata2D(2,4) = C_LOC(A24(1)(1:1))
data2D_w(1,1) = A11(1)
data2D_w(1,2) = A12(1)
data2D_w(1,3) = A13(1)
data2D_w(1,4) = A14(1)
data2D_w(2,1) = A21(1)
data2D_w(2,2) = A22(1)
data2D_w(2,3) = A23(1)
data2D_w(2,4) = A24(1)
!
! Create a new file using the default properties.
!
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f",error, total_error)
!
! Create file and memory datatypes. For this test we will save
! the strings as C variable length strings, H5T_STRING is defined
! as a variable length string.
!
CALL H5Tcopy_f(H5T_STRING, filetype, error)
CALL check("H5Tcopy_f",error, total_error)
!
! Create dataspace.
!
CALL h5screate_simple_f(1, dims, space, error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset and write the variable-length string data to
! it.
!
CALL h5dcreate_f(file, dataset, filetype, space, dset, error)
CALL check("h5dcreate_f",error, total_error)
f_ptr = C_LOC(wdata(1))
CALL h5dwrite_f(dset, filetype, f_ptr, error)
CALL check("h5dwrite_f",error, total_error)
!
! Close and release resources.
!
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
!
! Create dataspace.
!
CALL h5screate_simple_f(2, dims2D, space, error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset and write the variable-length string data to
! it.
!
CALL h5dcreate_f(file, dataset2D, filetype, space, dset, error)
CALL check("h5dcreate_f",error, total_error)
f_ptr = C_LOC(wdata2D(1,1))
CALL h5dwrite_f(dset, filetype, f_ptr, error)
CALL check("h5dwrite_f",error, total_error)
!
! Close and release resources.
!
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(filetype, error)
CALL check("h5tclose_f",error, total_error)
CALL h5fclose_f(file , error)
CALL check("h5fclose_f",error, total_error)
!
! Now we begin the read section of this test.
!
!
! Open file and dataset.
!
CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
CALL check("h5fopen_f",error, total_error)
CALL h5dopen_f(file, dataset, dset, error)
CALL check("h5dopen_f",error, total_error)
!
! Get the datatype.
!
CALL H5Dget_type_f(dset, filetype, error)
CALL check("H5Dget_type_f",error, total_error)
!
! Get dataspace and allocate memory for read buffer.
!
CALL H5Dget_space_f(dset, space, error)
CALL check("H5Dget_space_f",error, total_error)
CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, error)
CALL check("H5Sget_simple_extent_dims_f",error, total_error)
ALLOCATE(rdata(1:dims(1)))
!
! Read the data.
!
f_ptr = C_LOC(rdata(1))
CALL h5dread_f(dset, H5T_STRING, f_ptr, error)
CALL check("H5Dread_f",error, total_error)
!
! Check the data.
!
DO i = 1, dims(1)
CALL C_F_POINTER(rdata(i), data)
len = 0
DO
IF(DATA(len+1:len+1).EQ.C_NULL_CHAR.OR.len.GE.8) EXIT
len = len + 1
ENDDO
CALL verify("h5dread_f",data(1:len), data_w(i)(1:len), total_error)
END DO
DEALLOCATE(rdata)
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
!
! Test reading in 2D dataset
!
CALL h5dopen_f(file, dataset2D, dset, error)
CALL check("h5dopen_f",error, total_error)
!
! Get the datatype.
!
CALL H5Dget_type_f(dset, filetype, error)
CALL check("H5Dget_type_f",error, total_error)
!
! Get dataspace and allocate memory for read buffer.
!
CALL H5Dget_space_f(dset, space, error)
CALL check("H5Dget_space_f",error, total_error)
CALL H5Sget_simple_extent_dims_f(space, dims2D, maxdims, error)
CALL check("H5Sget_simple_extent_dims_f",error, total_error)
ALLOCATE(rdata2D(1:dims2D(1),1:dims2D(2)))
!
! Read the data.
!
f_ptr = C_LOC(rdata2D(1,1))
CALL h5dread_f(dset, H5T_STRING, f_ptr, error)
CALL check("H5Dread_f",error, total_error)
!
! Check the data.
!
DO i = 1, dims2D(1)
DO j = 1, dims2D(2)
CALL C_F_POINTER(rdata2D(i,j), DATA)
len = 0
DO
IF(DATA(len+1:len+1).EQ.C_NULL_CHAR.OR.len.GE.8) EXIT
len = len + 1
ENDDO
CALL verify("h5dread_f",DATA(1:len), data2D_w(i,j)(1:len), total_error)
ENDDO
END DO
DEALLOCATE(rdata2D)
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(filetype, error)
CALL check("h5tclose_f",error, total_error)
CALL h5fclose_f(file , error)
CALL check("h5fclose_f",error, total_error)
END SUBROUTINE t_vlstring_readwrite
SUBROUTINE t_string(total_error)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
CHARACTER(LEN=20), PARAMETER :: filename = "t_string_F03.h5"
CHARACTER(LEN=3) , PARAMETER :: dataset = "DS1"
INTEGER , PARAMETER :: dim0 = 4
INTEGER(SIZE_T) , PARAMETER :: sdim = 8
INTEGER(HID_T) :: file, filetype, memtype, space, dset ! Handles
INTEGER :: error
INTEGER(HSIZE_T), DIMENSION(1:1) :: dims = (/dim0/)
INTEGER(HSIZE_T), DIMENSION(1:1) :: maxdims
CHARACTER(LEN=sdim), DIMENSION(1:dim0), TARGET :: &
wdata = (/"Parting", "is such", "sweet ", "sorrow."/)
CHARACTER(LEN=sdim), DIMENSION(:), ALLOCATABLE, TARGET :: rdata
INTEGER(hsize_t) :: i
INTEGER(SIZE_T) :: size
TYPE(C_PTR) :: f_ptr
!
! Create a new file using the default properties.
!
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f",error, total_error)
!
! Create file datatypes. For this example we will save
! the strings as FORTRAN strings
!
CALL H5Tcopy_f(H5T_FORTRAN_S1, filetype, error)
CALL check("H5Tcopy_f",error, total_error)
CALL H5Tset_size_f(filetype, sdim, error)
CALL check("H5Tset_size_f",error, total_error)
!
! Create dataspace.
!
CALL h5screate_simple_f(1, dims, space, error)
CALL check("h5screate_simple_f",error, total_error)
!
! Create the dataset and write the string data to it.
!
CALL h5dcreate_f(file, dataset, filetype, space, dset, error)
CALL check("h5dcreate_f",error, total_error)
f_ptr = C_LOC(wdata(1)(1:1))
CALL H5Dwrite_f(dset, filetype, f_ptr, error)
CALL check("H5Dwrite_f",error, total_error)
!
! Close and release resources.
!
CALL h5dclose_f(dset , error)
CALL check("h5dclose_f",error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(filetype, error)
CALL check("h5tclose_f",error, total_error)
CALL h5fclose_f(file , error)
CALL check("h5fclose_f",error, total_error)
!
! Now we begin the read section of this example.
!
! Open file and dataset.
!
CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, error)
CALL check("h5fopen_f",error, total_error)
CALL h5dopen_f(file, dataset, dset, error)
CALL check("h5dopen_f",error, total_error)
!
! Get the datatype and its size.
!
CALL H5Dget_type_f(dset, filetype, error)
CALL check("H5Dget_type_f",error, total_error)
CALL H5Tget_size_f(filetype, size, error)
CALL check("H5Tget_size_f",error, total_error)
CALL VERIFY("H5Tget_size_f", INT(size), INT(sdim), total_error)
!
! Get dataspace.
!
CALL H5Dget_space_f(dset, space, error)
CALL check("H5Dget_space_f",error, total_error)
CALL H5Sget_simple_extent_dims_f(space, dims, maxdims, error)
CALL check("H5Sget_simple_extent_dims_f",error, total_error)
CALL VERIFY("H5Sget_simple_extent_dims_f", dims(1), INT(dim0,hsize_t), total_error)
ALLOCATE(rdata(1:dims(1)))
!
! Create the memory datatype.
!
CALL H5Tcopy_f(H5T_FORTRAN_S1, memtype, error)
CALL check("H5Tcopy_f",error, total_error)
CALL H5Tset_size_f(memtype, sdim, error)
CALL check("H5Tset_size_f",error, total_error)
!
! Read the data.
!
f_ptr = C_LOC(rdata(1)(1:1))
CALL H5Dread_f(dset, memtype, f_ptr, error, space)
CALL check("H5Dread_f",error, total_error)
DO i = 1, dims(1)
CALL verify("h5dread_f",TRIM(rdata(i)),TRIM(wdata(i)) , total_error)
END DO
DEALLOCATE(rdata)
!
! Close and release resources.
!
CALL H5Dclose_f(dset, error)
CALL check("h5dclose_f",error, total_error)
CALL H5Sclose_f(space, error)
CALL check("h5sclose_f",error, total_error)
CALL H5Tclose_f(memtype, error)
CALL check("h5tclose_f",error, total_error)
CALL H5Fclose_f(file, error)
CALL check("h5fclose_f",error, total_error)
END SUBROUTINE t_string
SUBROUTINE vl_test_special_char(total_error)
IMPLICIT NONE
! INTERFACE
! SUBROUTINE setup_buffer(data_in, line_lengths, char_type)
! USE HDF5
! USE ISO_C_BINDING
! IMPLICIT NONE
! CHARACTER(len=*), DIMENSION(:) :: data_in
! INTEGER(size_t), DIMENSION(:) :: line_lengths
! CHARACTER(KIND=C_CHAR,LEN=*) :: char_type
! END SUBROUTINE setup_buffer
! END INTERFACE
INTEGER, INTENT(OUT) :: total_error
CHARACTER(LEN=16), PARAMETER :: filename = "t_controlchar.h5"
INTEGER, PARAMETER :: line_length = 10
INTEGER(hid_t) :: file
INTEGER(hid_t) :: dataset0
CHARACTER(len=line_length), DIMENSION(1:100) :: data_in
CHARACTER(len=line_length), DIMENSION(1:100) :: data_out
INTEGER(size_t), DIMENSION(1:100) :: line_lengths
INTEGER(hid_t) :: string_id, space, dcpl
INTEGER(hsize_t), DIMENSION(1:1) :: dims = (/0/)
INTEGER(hsize_t), DIMENSION(1:1) :: max_dims = (/0/)
INTEGER(hsize_t), DIMENSION(1:2) :: data_dims = (/0,0/)
INTEGER(hsize_t), DIMENSION(1:1) :: chunk =(/10/)
INTEGER, PARAMETER :: ncontrolchar = 7
CHARACTER(KIND=C_CHAR,LEN=1), DIMENSION(1:ncontrolchar) :: controlchar = &
(/C_ALERT, C_BACKSPACE,C_CARRIAGE_RETURN, C_FORM_FEED,C_HORIZONTAL_TAB,C_VERTICAL_TAB, C_NEW_LINE/)
INTEGER :: i, j, n, error
n = 8
!
! Create a new file using the default properties.
!
CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f",error, total_error)
max_dims = (/H5S_UNLIMITED_F/)
!
! Create the memory datatype.
!
CALL h5tcopy_f(h5t_string, string_id, error)
CALL check("h5tcopy_f", error, total_error)
CALL h5tset_strpad_f(string_id, h5t_str_nullpad_f, error)
CALL check("h5tset_strpad_f", error, total_error)
dims(1) = n
!
! Create dataspace.
!
CALL h5screate_simple_f(1, dims, space, error, max_dims)
CALL check("h5screate_simple_f", error, total_error)
CALL h5pcreate_f(h5p_dataset_create_f, dcpl, error)
CALL check("h5pcreate_f", error, total_error)
CALL h5pset_chunk_f(dcpl, 1, chunk, error)
CALL check("h5pset_chunk_f", error, total_error)
data_dims(1) = line_length
data_dims(2) = n
!
! Create data with strings containing various control characters.
!
DO i = 1, ncontrolchar
!
! Create the dataset, for the string with control character and write the string data to it.
!
CALL h5dcreate_f(file, controlchar(i), string_id, space, dataset0, error, dcpl)
CALL check("h5dcreate_f", error, total_error)
CALL setup_buffer(data_in(1:n), line_lengths, controlchar(i))
CALL h5dwrite_vl_f(dataset0, string_id, data_in(1:n), data_dims, line_lengths(1:n), error, space)
CALL check("h5dwrite_vl_f", error, total_error)
!
! Read the string back.
!
CALL h5dread_vl_f(dataset0, string_id, data_out(1:n), data_dims, line_lengths(1:n), error, space)
CALL check("h5dread_vl_f", error, total_error)
DO j = 1, n
IF(data_in(j).NE.data_out(j))THEN
total_error = total_error + 1
EXIT
ENDIF
ENDDO
CALL h5dclose_f(dataset0, error)
CALL check("h5dclose_f", error, total_error)
ENDDO
CALL h5pclose_f(dcpl, error)
CALL check("h5pclose_f", error, total_error)
CALL h5sclose_f(space, error)
CALL check("h5sclose_f", error, total_error)
CALL h5fclose_f(file, error)
CALL check("h5fclose_f", error, total_error)
END SUBROUTINE vl_test_special_char
SUBROUTINE setup_buffer(data_in, line_lengths, char_type)
IMPLICIT NONE
! Creates a simple "Data_in" consisting of the letters of the alphabet,
! one per line, with a control character.
CHARACTER(len=10), DIMENSION(:) :: data_in
INTEGER(size_t), DIMENSION(:) :: line_lengths
CHARACTER(LEN=3) :: lets = 'abc'
CHARACTER(KIND=C_CHAR,LEN=*) :: char_type
INTEGER :: i, j, n
n = SIZE(data_in)
j = 1
DO i=1,n-1
IF( j .EQ. 4 )THEN
data_in(i:i) = char_type(1:1)
ELSE
data_in(i:i) = lets(j:j)
ENDIF
line_lengths(i) = LEN_TRIM(data_in(i))
j = j + 1
IF( j .EQ. 5 ) j = 1
END DO
data_in(n:n) = char_type(1:1)
line_lengths(n) = 1
END SUBROUTINE setup_buffer
!-------------------------------------------------------------------------
! Function: test_nbit
!
! Purpose: Tests (real, 4 byte) datatype for nbit filter
!
! Return: Success: 0
! Failure: >0
!
! Programmer: M. Scot Breitenfeld
! Decemeber 7, 2010
!
! Modifications: Moved this subroutine from the 1.8 test file and
! modified it to use F2003 features.
! This routine requires 4 byte reals, so we use F2003 features to
! ensure the requirement is satisfied in a portable way.
! The need for this arises when a user specifies the default real is 8 bytes.
! MSB 7/31/12
!
!-------------------------------------------------------------------------
!
SUBROUTINE test_nbit(total_error )
IMPLICIT NONE
INTEGER, PARAMETER :: wp = C_FLOAT !should map to REAL*4 on most modern processors
INTEGER, INTENT(INOUT) :: total_error
INTEGER(hid_t) :: file
INTEGER(hid_t) :: dataset, datatype, space, dc, mem_type_id
INTEGER(hsize_t), DIMENSION(1:2) :: dims = (/2,5/)
INTEGER(hsize_t), DIMENSION(1:2) :: chunk_dim = (/2,5/)
! orig_data[] are initialized to be within the range that can be represented by
! dataset datatype (no precision loss during datatype conversion)
!
REAL(kind=wp), DIMENSION(1:2,1:5), TARGET :: orig_data = &
RESHAPE( (/188384.00, 19.103516, -1.0831790e9, -84.242188, &
5.2045898, -49140.000, 2350.2500, -3.2110596e-1, 6.4998865e-5, -0.0000000/) , (/2,5/) )
REAL(kind=wp), DIMENSION(1:2,1:5), TARGET :: new_data
INTEGER(size_t) :: PRECISION, offset
INTEGER :: error
LOGICAL :: status
INTEGER(hsize_t) :: i, j
TYPE(C_PTR) :: f_ptr
! check to see if filter is available
CALL H5Zfilter_avail_f(H5Z_FILTER_NBIT_F, status, error)
IF(.NOT.status)THEN ! We don't have H5Z_FILTER_NBIT_F filter
total_error = -1 ! so return
RETURN
ENDIF
CALL H5Fcreate_f("nbit.h5", H5F_ACC_TRUNC_F, file, error)
CALL check("H5Fcreate_f", error, total_error)
! Define dataset datatype (integer), and set precision, offset
CALL H5Tcopy_f(H5T_IEEE_F32BE, datatype, error)
CALL CHECK(" H5Tcopy_f", error, total_error)
CALL H5Tset_fields_f(datatype, 26_size_t, 20_size_t, 6_size_t, 7_size_t, 13_size_t, error)
CALL CHECK(" H5Tset_fields_f", error, total_error)
offset = 7
CALL H5Tset_offset_f(datatype, offset, error)
CALL CHECK(" H5Tset_offset_f", error, total_error)
PRECISION = 20
CALL H5Tset_precision_f(datatype,PRECISION, error)
CALL CHECK(" H5Tset_precision_f", error, total_error)
CALL H5Tset_size_f(datatype, 4_size_t, error)
CALL CHECK(" H5Tset_size_f", error, total_error)
CALL H5Tset_ebias_f(datatype, 31_size_t, error)
CALL CHECK(" H5Tset_ebias_f", error, total_error)
! Create the data space
CALL H5Screate_simple_f(2, dims, space, error)
CALL CHECK(" H5Screate_simple_f", error, total_error)
! USE nbit filter
CALL H5Pcreate_f(H5P_DATASET_CREATE_F, dc, error)
CALL CHECK(" H5Pcreate_f", error, total_error)
CALL H5Pset_chunk_f(dc, 2, chunk_dim, error)
CALL CHECK(" H5Pset_chunk_f", error, total_error)
CALL H5Pset_nbit_f(dc, error)
CALL CHECK(" H5Pset_nbit_f", error, total_error)
! Create the dataset
CALL H5Dcreate_f(file, "nbit_real", datatype, &
space, dataset, error, dc)
CALL CHECK(" H5Dcreate_f", error, total_error)
!----------------------------------------------------------------------
! STEP 1: Test nbit by setting up a chunked dataset and writing
! to it.
!----------------------------------------------------------------------
!
mem_type_id = h5kind_to_type(wp,H5_REAL_KIND)
f_ptr = C_LOC(orig_data(1,1))
CALL H5Dwrite_f(dataset, mem_type_id, f_ptr, error)
CALL CHECK(" H5Dwrite_f", error, total_error)
!----------------------------------------------------------------------
! STEP 2: Try to read the data we just wrote.
!----------------------------------------------------------------------
!
f_ptr = C_LOC(new_data(1,1))
CALL H5Dread_f(dataset, mem_type_id, f_ptr, error)
CALL CHECK(" H5Dread_f", error, total_error)
! Check that the values read are the same as the values written
! Assume size of long long = size of double
!
i_loop: DO i = 1, dims(1)
j_loop: DO j = 1, dims(2)
IF(.NOT.(orig_data(i,j).EQ.orig_data(i,j))) CYCLE ! skip IF value is NaN
IF( .NOT.check_real_eq( new_data(i,j), orig_data(i,j)) ) THEN
total_error = total_error + 1
WRITE(*,'(" Read different values than written.")')
WRITE(*,'(" At index ", 2(1X,I0))') i, j
EXIT i_loop
END IF
ENDDO j_loop
ENDDO i_loop
!----------------------------------------------------------------------
! 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)
END SUBROUTINE test_nbit
SUBROUTINE t_enum_conv(total_error)
!-------------------------------------------------------------------------
! Subroutine: t_enum_conv
!
! Purpose: Tests converting data from enumeration datatype
! to numeric (integer or floating-point number)
! datatype. Tests various KINDs of INTEGERs
! and REALs. Checks reading enum data into
! INTEGER and REAL KINDs.
!
! Return: Success: 0
! Failure: number of errors
!
! Programmer: M. Scot Breitenfeld
! October 27, 2012
!
! Note: Adapted from C test (enum.c -- test_conv)
! No reliance on C tests.
!-------------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: total_error
INTEGER, PARAMETER :: int_kind_8 = SELECTED_INT_KIND(9) !should map to INTEGER*4 on most modern processors
INTEGER, PARAMETER :: int_kind_16 = SELECTED_INT_KIND(18) !should map to INTEGER*8 on most modern processors
INTEGER, PARAMETER :: real_kind_7 = C_FLOAT !should map to REAL*4 on most modern processors
INTEGER(hid_t) :: cwg=-1, dtype=-1, space=-1, dset=-1 ! Handles
INTEGER(hid_t) :: file ! Handles
! Enumerated type
ENUM, BIND(C)
ENUMERATOR :: E1_RED, E1_GREEN, E1_BLUE, E1_WHITE, E1_BLACK
END ENUM
INTEGER(KIND(E1_RED)), TARGET :: val
! Enumerated data array
! Some values are out of range for testing. The library should accept them
INTEGER(KIND(E1_RED)), DIMENSION(1:20), TARGET :: data1 = (/INT(E1_RED,KIND(E1_RED)), &
INT(E1_GREEN,KIND(E1_RED)), INT(E1_BLUE,KIND(E1_RED)), &
INT(E1_GREEN,KIND(E1_RED)), INT(E1_WHITE,KIND(E1_RED)), &
INT(E1_WHITE,KIND(E1_RED)), INT(E1_BLACK,KIND(E1_RED)), &
INT(E1_GREEN,KIND(E1_RED)), INT(E1_BLUE,KIND(E1_RED)), &
INT(E1_RED,KIND(E1_RED)), INT(E1_RED,KIND(E1_RED)), INT(E1_BLUE,KIND(E1_RED)), &
INT(E1_GREEN,KIND(E1_RED)), INT(E1_BLACK,KIND(E1_RED)), INT(E1_WHITE,KIND(E1_RED)),&
INT(E1_RED,KIND(E1_RED)), INT(E1_WHITE,KIND(E1_RED)), &
INT(0,KIND(E1_RED)), INT(-1,KIND(E1_RED)), INT(-2,KIND(E1_RED))/)
! Reading array for enum data
INTEGER(KIND(E1_RED)), DIMENSION(1:20), TARGET :: data2
! Reading array's for converted enum data
INTEGER(C_SHORT), DIMENSION(1:20), TARGET :: data_short
INTEGER(C_INT), DIMENSION(1:20), TARGET :: data_int
REAL(C_DOUBLE), DIMENSION(1:20), TARGET :: data_double
INTEGER(int_kind_8), DIMENSION(1:20), TARGET :: data_i8
INTEGER(int_kind_16), DIMENSION(1:20), TARGET :: data_i16
REAL(real_kind_7), DIMENSION(1:20), TARGET :: data_r7
INTEGER(hsize_t), DIMENSION(1:1) :: ds_size = (/20/)
INTEGER(size_t) :: i
INTEGER(hsize_t) :: ih
INTEGER :: error
TYPE(C_PTR) :: f_ptr
INTEGER(HID_T) :: m_baset ! Memory base type
!
! Create a new file using the default properties.
!
CALL h5fcreate_f("enum1.h5", H5F_ACC_TRUNC_F, file, error)
CALL check("h5fcreate_f", error, total_error)
!
! Create a new group using the default properties.
!
CALL h5gcreate_f(file, "test_conv", cwg, error)
CALL check("h5gcreate_f",error, total_error)
!
! Create a enum type
!
CALL H5Tcreate_f(H5T_ENUM_F, H5OFFSETOF(C_LOC(data1(1)), C_LOC(data1(2))), dtype, error)
CALL check("h5tcreate_f",error, total_error)
!
! Initialize enum data.
!
val = E1_RED
CALL H5Tenum_insert_f(dtype, "RED", C_LOC(val), error)
CALL check("h5tenum_insert_f",error, total_error)
val = E1_GREEN
f_ptr = C_LOC(val)
CALL H5Tenum_insert_f(dtype, "GREEN", f_ptr, error)
CALL check("h5tenum_insert_f",error, total_error)
val = E1_BLUE
f_ptr = C_LOC(val)
CALL H5Tenum_insert_f(dtype, "BLUE", f_ptr, error)
CALL check("h5tenum_insert_f",error, total_error)
val = E1_WHITE
f_ptr = C_LOC(val)
CALL H5Tenum_insert_f(dtype, "WHITE", f_ptr, error)
CALL check("h5tenum_insert_f",error, total_error)
val = E1_BLACK
f_ptr = C_LOC(val)
CALL H5Tenum_insert_f(dtype, "BLACK", f_ptr, error)
CALL check("h5tenum_insert_f",error, total_error)
!
! Create dataspace. Setting maximum size to be the current size.
!
CALL h5screate_simple_f(1, ds_size, space, error)
CALL check("h5screate_simple_f", error, total_error)
! ***************************************
! * Dataset of enumeration type
! ***************************************
!
! Create a dataset of enum type and write enum data to it
CALL h5dcreate_f(cwg, "color_table1", dtype, space, dset, error)
CALL check("h5dcreate_f", error, total_error)
f_ptr = C_LOC(data1(1))
CALL h5dwrite_f(dset, dtype, f_ptr, error, space, space)
CALL check(" h5dwrite_f", error, total_error)
! Test reading back the data with no conversion
f_ptr = C_LOC(data2(1))
CALL h5dread_f(dset, dtype, f_ptr, error, space, space)
CALL check(" h5dread_f", error, total_error)
! Check values
DO ih = 1, ds_size(1)
IF(data1(ih) .NE. data2(ih))THEN
total_error = total_error + 1
WRITE(*,'(" 1. data1(",I0,")=",I0," .NE. data2(",I0,")=",I0)') ih, data1(ih),i,data2(ih)
EXIT
ENDIF
ENDDO
! Test converting the data to integer (KIND=C_SHORT). Read enum data back as integer
m_baset = h5kind_to_type(KIND(data_short(1)), H5_INTEGER_KIND) ! Memory base type
f_ptr = C_LOC(data_short(1))
CALL h5dread_f(dset, m_baset, f_ptr, error, space, space)
CALL check("h5dread_f", error, total_error)
! Check values
DO ih = 1, ds_size(1)
IF(data1(ih) .NE. data_short(ih))THEN
total_error = total_error + 1
WRITE(*,'(" 2. data1(",I0,")=",I0," .NE. data_short(",I0,")=",I0)') ih, data1(ih),i,data_short(ih)
EXIT
ENDIF
ENDDO
! Test converting the data to (KIND=C_double) number.
! Read enum data back as (KIND=C_double) number
m_baset = h5kind_to_type(KIND(data_double(1)), H5_REAL_KIND) ! Memory base type
f_ptr = C_LOC(data_double(1))
CALL h5dread_f(dset, m_baset, f_ptr, error, space, space)
CALL check("h5dread_f", error, total_error)
! Check values
DO ih = 1, ds_size(1)
IF(data1(ih) .NE. INT(data_double(ih)))THEN
total_error = total_error + 1
WRITE(*,'(" 3. data_double(",I0,")=",I0," .NE. data_double(",I0,")=",I0)') &
ih, INT(data1(ih)), ih, INT(data_double(ih))
EXIT
ENDIF
ENDDO
! Test converting the data to (SELECTED_INT_KIND(9)) number.
! Read enum data back as (SELECTED_INT_KIND(9)) number
m_baset = h5kind_to_type(int_kind_8, H5_INTEGER_KIND) ! Memory base type
f_ptr = C_LOC(data_i8(1))
CALL h5dread_f(dset, m_baset, f_ptr, error, space, space)
CALL check("h5dread_f", error, total_error)
! Check values
DO ih = 1, ds_size(1)
IF(data1(ih) .NE. INT(data_i8(ih)))THEN
total_error = total_error + 1
WRITE(*,'(" 4. data_i8(",I0,")=",I0," .NE. data_i8(",I0,")=",I0)') &
ih, INT(data1(ih)), i, INT(data_i8(ih))
EXIT
ENDIF
ENDDO
! Test converting the data to (SELECTED_INT_KIND(18)) number.
! Read enum data back as (SELECTED_INT_KIND(18)) number
m_baset = h5kind_to_type(int_kind_16, H5_INTEGER_KIND) ! Memory base type
f_ptr = C_LOC(data_i16(1))
CALL h5dread_f(dset, m_baset, f_ptr, error, space, space)
CALL check("h5dread_f", error, total_error)
! Check values
DO ih = 1, ds_size(1)
IF(data1(ih) .NE. INT(data_i16(ih)))THEN
total_error = total_error + 1
WRITE(*,'(" 5. data_i16(",I0,")=",I0," .NE. data_i16(",I0,")=",I0)') &
ih, INT(data1(ih)), i, INT(data_i16(ih))
EXIT
ENDIF
ENDDO
! Test converting the data to C_FLOAT number.
! Read enum data back as C_FLOAT number
m_baset = h5kind_to_type(KIND(data_r7(1)), H5_REAL_KIND) ! Memory base type
f_ptr = C_LOC(data_r7(1))
CALL h5dread_f(dset, m_baset, f_ptr, error, space, space)
CALL check("h5dread_f", error, total_error)
! Check values
DO ih = 1, ds_size(1)
IF(data1(ih) .NE. INT(data_r7(ih)))THEN
total_error = total_error + 1
WRITE(*,'(" 6. data_r7(",I0,")=",I0," .NE. data_r7(",I0,")=",I0)') &
ih, INT(data1(ih)), i, INT(data_r7(ih))
EXIT
ENDIF
ENDDO
CALL h5dclose_f(dset, error)
CALL check("h5dclose_f", error, total_error)
! ***************************************
! * Dataset of C_int type
! ***************************************
! Create a integer dataset of KIND=C_INT and write enum data to it
m_baset = h5kind_to_type(KIND(data_int(1)), H5_INTEGER_KIND) ! Memory base type
CALL h5dcreate_f(cwg, "color_table2", m_baset, space, dset, error)
CALL check("h5dcreate_f", error, total_error)
! Write the enum data
f_ptr = C_LOC(data1(1))
CALL h5dwrite_f(dset, dtype, f_ptr, error, space, space)
CALL check("h5dwrite_f", error, total_error)
! Test reading back the data with no conversion
f_ptr = C_LOC(data_int(1))
CALL h5dread_f(dset, m_baset, f_ptr, error, space, space)
CALL check("h5dread_f", error, total_error)
DO ih = 1, ds_size(1)
IF(data1(ih) .NE. data_int(ih))THEN
total_error = total_error + 1
WRITE(*,'(" 7. data1(",I0,")=",I0," .NE. data_int(",I0,")=",I0)') ih, data1(ih),i,data_int(ih)
EXIT
ENDIF
ENDDO
CALL h5dclose_f(dset, error)
CALL check("h5dclose_f", error, total_error)
!**************************************
!* Dataset of C_double type
!**************************************
! Create a dataset of KIND=C_DOUBLE and write enum data to it
m_baset = h5kind_to_type(KIND(data_double(1)), H5_REAL_KIND) ! Memory base type
CALL h5dcreate_f(cwg, "color_table3", m_baset, space, dset, error)
CALL check("h5dcreate_f", error, total_error)
f_ptr = C_LOC(data1(1))
CALL h5dwrite_f(dset, dtype, f_ptr, error, space, space)
CALL check("h5dwrite_f", error, total_error)
! Test reading back the data with no conversion
f_ptr = C_LOC(data_double(1))
CALL h5dread_f(dset, m_baset, f_ptr, error, space, space)
CALL check("h5dread_f", error, total_error)
DO ih = 1, ds_size(1)
IF(data1(ih) .NE. INT(data_double(ih)))THEN
total_error = total_error + 1
WRITE(*,'(" 8. data1(",I0,")=",I0," .NE. data_double(",I0,")=",I0)') ih, data1(ih),ih,INT(data_double(ih))
EXIT
ENDIF
ENDDO
CALL h5dclose_f(dset, error)
CALL check("h5dclose_f", error, total_error)
!*********************************************************
!* Dataset of real C_FLOAT type
!*********************************************************
! Create a dataset of C_FLOAT and write enum data to it
m_baset = h5kind_to_type(KIND(data_r7(1)), H5_REAL_KIND) ! Memory base type
CALL h5dcreate_f(cwg, "color_table4", m_baset, space, dset, error)
CALL check("h5dcreate_f", error, total_error)
f_ptr = C_LOC(data1(1))
CALL h5dwrite_f(dset, dtype, f_ptr, error, space, space)
CALL check("h5dwrite_f", error, total_error)
! Test reading back the data with no conversion
f_ptr = C_LOC(data_r7(1))
CALL h5dread_f(dset, m_baset, f_ptr, error, space, space)
CALL check("h5dread_f", error, total_error)
DO ih = 1, ds_size(1)
IF(data1(ih) .NE. INT(data_r7(ih)))THEN
total_error = total_error + 1
WRITE(*,'(" 9. data1(",I0,")=",I0," .NE. data_r7(",I0,")=",I0)') ih, data1(ih),ih,INT(data_r7(ih))
EXIT
ENDIF
ENDDO
CALL h5dclose_f(dset, error)
CALL check("h5dclose_f", error, total_error)
! *****************************************************************
! * Dataset of integer SELECTED_INT_KIND(18) type
! *****************************************************************
! Create a integer dataset of (SELECTED_INT_KIND(18)) and write enum data to it
m_baset = h5kind_to_type(KIND(data_i16(1)), H5_INTEGER_KIND) ! Memory base type
CALL h5dcreate_f(cwg, "color_table5", m_baset, space, dset, error)
CALL check("h5dcreate_f", error, total_error)
! Write the enum data
f_ptr = C_LOC(data1(1))
CALL h5dwrite_f(dset, dtype, f_ptr, error, space, space)
CALL check("h5dwrite_f", error, total_error)
! Test reading back the data with no conversion
f_ptr = C_LOC(data_i16(1))
CALL h5dread_f(dset, m_baset, f_ptr, error, space, space)
CALL check("h5dread_f", error, total_error)
DO ih = 1, ds_size(1)
IF(data1(ih) .NE. data_i16(ih))THEN
total_error = total_error + 1
WRITE(*,'(" 10. data1(",I0,")=",I0," .NE. data_i16(",I0,")=",I0)') ih, data1(ih),ih,data_i16(ih)
EXIT
ENDIF
ENDDO
CALL h5dclose_f(dset, error)
CALL check("h5dclose_f", error, total_error)
!
! Close and release resources.
!
CALL h5sclose_f(space, error)
CALL check("H5Sclose_f", error, total_error)
CALL h5tclose_f(dtype, error)
CALL check("H5Tclose_f", error, total_error)
CALL h5gclose_f(cwg, error)
CALL check("h5gclose_f",error, total_error)
CALL h5fclose_f(file, error)
CALL check("H5Fclose_f", error, total_error)
END SUBROUTINE t_enum_conv
END MODULE TH5T_F03
Reference in New Issue View Git Blame Copy Permalink