diff options
Diffstat (limited to 'fortran/test/tH5T_F03.F90')
| -rw-r--r-- | fortran/test/tH5T_F03.F90 | 3419 |
1 files changed, 3419 insertions, 0 deletions
diff --git a/fortran/test/tH5T_F03.F90 b/fortran/test/tH5T_F03.F90 new file mode 100644 index 0000000..8117578 --- /dev/null +++ b/fortran/test/tH5T_F03.F90 @@ -0,0 +1,3419 @@ +!****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 files COPYING and Copyright.html. COPYING can be found at the root * +! of the source code distribution tree; Copyright.html can be found at the * +! root level of an installed copy of the electronic HDF5 document set and * +! is linked from the top-level documents page. It can also be found at * +! http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have * +! access to either file, you may request a copy from help@hdfgroup.org. * +! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! +! 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) +!** +!*************************************************************** +! + +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 + 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) + 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 + 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 + + IF(wdata(i,j)%f(k).NE.rdata(i,j)%f(k))THEN + PRINT*, 'ERROR: Wrong real array data is read back by H5Dread_f ' + total_error = total_error + 1 + ENDIF + IF(wdata(i,j)%c(k).NE.rdata(i,j)%c(k))THEN + PRINT*, 'ERROR: Wrong character array data is read back by H5Dread_f ' + total_error = total_error + 1 + ENDIF + 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(Fortran_INTEGER_1) !should map to INTEGER*1 on most modern processors +! INTEGER, PARAMETER :: int_kind_4 = SELECTED_INT_KIND(Fortran_INTEGER_2) !should map to INTEGER*2 on most modern processors +! INTEGER, PARAMETER :: int_kind_8 = SELECTED_INT_KIND(Fortran_INTEGER_4) !should map to INTEGER*4 on most modern processors +! INTEGER, PARAMETER :: int_kind_16 = SELECTED_INT_KIND(Fortran_INTEGER_8) !should map to INTEGER*8 on most modern processors + + 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 +!#ifdef + 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 = SELECTED_REAL_KIND(Fortran_REAL_C_FLOAT) !should map to REAL*4 on most modern processors + INTEGER, PARAMETER :: real_kind_15 = SELECTED_REAL_KIND(Fortran_REAL_C_DOUBLE) !should map to REAL*8 on most modern processors + +!#ifdef + INTEGER, PARAMETER :: real_kind_31 = SELECTED_REAL_KIND(31) + 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 + +!#endif + 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) = 2**(4)-i + dset_data_i4(i) = 2**(10)-i + dset_data_i8(i) = 2**(28)-i + dset_data_i16(i) = 2**(28)-i +!#ifdef + dset_data_i32(i) = 2**(28)-i +!#endif + dset_data_r(i) = (i)*100. + dset_data_r7(i) = (i)*100. + dset_data_r15(i) = (i)*1000. +!#ifdef + dset_data_r31(i) = 3.141592653589793238462643383279_real_kind_31 +!#endif + + 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) +!#ifdef + 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 + 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) +!#ifdef + 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 + 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) + 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) + 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) + 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) + CALL h5dread_f(dset_id16, h5kind_to_type(int_kind_16,H5_INTEGER_KIND), f_ptr, error) + CALL check("h5dread_f",error, total_error) +!#ifdef + f_ptr = C_LOC(data_out_i32) + 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) + 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) + 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) + CALL h5dread_f(dset_idr8, h5kind_to_type(real_kind_15,H5_REAL_KIND), f_ptr, error) + CALL check("h5dread_f",error, total_error) +!#ifdef + f_ptr = C_LOC(data_out_r31) + CALL h5dread_f(dset_idr16, h5kind_to_type(real_kind_31,H5_REAL_KIND), f_ptr, error) + CALL check("h5dread_f",error, total_error) +!#endif + DO i = 1, 4 + + CALL verify("h5kind_to_type1",dset_data_i1(i),data_out_i1(i),total_error) + CALL verify("h5kind_to_type2",dset_data_i4(i),data_out_i4(i),total_error) +!!$ CALL verify_Fortran_INTEGER_4("h5kind_to_type3",INT(dset_data_i8(i),int_kind_8),INT(data_out_i8(i),int_kind_8),total_error) +!!$ CALL verify_Fortran_INTEGER_4("h5kind_to_type4",INT(dset_data_i16(i),int_kind_8),INT(data_out_i16(i),int_kind_8),total_error) + +!#ifdef +! PRINT*,dset_data_i16(i),data_out_i16(i) +!!$ CALL verify_Fortran_INTEGER_4("h5kind_to_type4",INT(dset_data_i16(i),int_kind_8),INT(data_out_i16(i),int_kind_8),total_error) +!#endif + CALL verify("h5kind_to_type5",dset_data_r(i),data_out_r(i),total_error) + CALL verify("h5kind_to_type6",dset_data_r7(i),data_out_r7(i),total_error) + CALL verify("h5kind_to_type7",dset_data_r15(i),data_out_r15(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", INT(adims(1)), adim0, total_error) + CALL VERIFY("H5Tget_array_dims_f", INT(adims(2)), adim1, 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", INT(dims(1)), dim0, 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", INT(dims(1)), dim0, total_error) + CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(2)), dim1, 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 = 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", INT(dims(1)), dim0, total_error) + CALL VERIFY("H5Sget_simple_extent_dims_f", INT(dims(2)), dim1, 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", INT(dims(1)), dim0, 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", INT(dims(1)), dim0, 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_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", INT(dims(1)), dim0, 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_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, wdata(1)%len + ptr(1)%data(i) = 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, 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, 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", INT(dims(1)), dim0, 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 + INTEGER, DIMENSION(1:3) :: letters + CHARACTER(LEN=3) :: lets + CHARACTER(KIND=C_CHAR,LEN=*) :: char_type + CHARACTER(KIND=C_CHAR,LEN=1) :: char_tmp + INTEGER :: i, j, n, ff + + ! Convert the letters and special character to integers + lets = 'abc' + + READ(lets,'(3A1)') letters + READ(char_type,'(A1)') ff + n = SIZE(data_in) + j = 1 + DO i=1,n-1 + IF( j .EQ. 4 )THEN + WRITE(char_tmp,'(A1)') ff + data_in(i:i) = char_tmp + ELSE + WRITE(char_tmp,'(A1)') letters(j) + data_in(i:i) = char_tmp + ENDIF + line_lengths(i) = LEN_TRIM(data_in(i)) + j = j + 1 + IF( j .EQ. 5 ) j = 1 + END DO + WRITE(char_tmp,'(A1)') ff + data_in(n:n) = char_tmp + 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 = SELECTED_REAL_KIND(Fortran_REAL_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(Fortran_INTEGER_4) !should map to INTEGER*4 on most modern processors + INTEGER, PARAMETER :: int_kind_16 = SELECTED_INT_KIND(Fortran_INTEGER_8)!should map to INTEGER*8 on most modern processors + + INTEGER, PARAMETER :: real_kind_7 = SELECTED_REAL_KIND(Fortran_REAL_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(Fortran_INTEGER_4)) number. + ! Read enum data back as (SELECTED_INT_KIND(Fortran_INTEGER_4)) 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(Fortran_INTEGER_8)) number. + ! Read enum data back as (SELECTED_INT_KIND(Fortran_INTEGER_8)) 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 SELECTED_REAL_KIND(Fortran_REAL_4) number. + ! Read enum data back as SELECTED_REAL_KIND(Fortran_REAL_4) 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 SELECTED_REAL_KIND(Fortran_REAL_4) type + !********************************************************* + + ! Create a dataset of SELECTED_REAL_KIND(Fortran_REAL_4) 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(Fortran_INTEGER_8) type + ! ***************************************************************** + + ! Create a integer dataset of (SELECTED_INT_KIND(Fortran_INTEGER_8)) 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 |