summaryrefslogtreecommitdiffstats
path: root/fortran/test/tH5L_F03.f90
diff options
context:
space:
mode:
authorScot Breitenfeld <brtnfld@hdfgroup.org>2015-08-31 18:49:17 (GMT)
committerScot Breitenfeld <brtnfld@hdfgroup.org>2015-08-31 18:49:17 (GMT)
commite6f9fc5f7f58e4c0a9a8541bc5674b440abd658c (patch)
treefb806c6eebcecca69438629f6f7a6e0c9096ac1f /fortran/test/tH5L_F03.f90
parentde1bafd1d81f936c046317720d7a73bcdb41f5e6 (diff)
downloadhdf5-e6f9fc5f7f58e4c0a9a8541bc5674b440abd658c.zip
hdf5-e6f9fc5f7f58e4c0a9a8541bc5674b440abd658c.tar.gz
hdf5-e6f9fc5f7f58e4c0a9a8541bc5674b440abd658c.tar.bz2
[svn-r27625] Added preprocessor commands for PGI compiler.
tested: h5committest
Diffstat (limited to 'fortran/test/tH5L_F03.f90')
-rw-r--r--fortran/test/tH5L_F03.f90318
1 files changed, 0 insertions, 318 deletions
diff --git a/fortran/test/tH5L_F03.f90 b/fortran/test/tH5L_F03.f90
deleted file mode 100644
index 40afdbc..0000000
--- a/fortran/test/tH5L_F03.f90
+++ /dev/null
@@ -1,318 +0,0 @@
-!****h* root/fortran/test/tH5L_F03.f90
-!
-! NAME
-! tH5L_F03.f90
-!
-! FUNCTION
-! Test FORTRAN HDF5 H5L 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. *
-! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
-!
-! USES
-! liter_cb_mod
-!
-! CONTAINS SUBROUTINES
-! test_iter_group
-!
-!*****
-MODULE liter_cb_mod
-
- USE HDF5
- USE TH5_MISC
- USE TH5_MISC_GEN
- USE, INTRINSIC :: ISO_C_BINDING
- IMPLICIT NONE
-
- TYPE iter_enum
- INTEGER RET_ZERO
- INTEGER RET_TWO
- INTEGER RET_CHANGE
- INTEGER RET_CHANGE2
- END TYPE iter_enum
-
- ! Custom group iteration callback data
- TYPE, bind(c) :: iter_info
- CHARACTER(KIND=C_CHAR), DIMENSION(1:10) :: name ! The name of the object
- INTEGER(c_int) :: TYPE ! The TYPE of the object
- INTEGER(c_int) :: command ! The TYPE of RETURN value
- END TYPE iter_info
-
-CONTAINS
-
-!***************************************************************
-!**
-!** liter_cb(): Custom link iteration callback routine.
-!**
-!***************************************************************
-
- INTEGER(KIND=C_INT) FUNCTION liter_cb(group, name, link_info, op_data) bind(C)
-
- IMPLICIT NONE
-
- INTEGER(HID_T), VALUE :: group
- CHARACTER(LEN=1), DIMENSION(1:10) :: name
-
-
- TYPE (H5L_info_t) :: link_info
-
- TYPE(iter_info) :: op_data
-
- INTEGER, SAVE :: count
- INTEGER, SAVE :: count2
-
-!!$
-!!$ iter_info *info = (iter_info *)op_data;
-!!$ static int count = 0;
-!!$ static int count2 = 0;
-
- op_data%name(1:10) = name(1:10)
-
- SELECT CASE (op_data%command)
-
- CASE(0)
- liter_cb = 0
- CASE(2)
- liter_cb = 2
- CASE(3)
- count = count + 1
- IF(count.GT.10) THEN
- liter_cb = 1
- ELSE
- liter_cb = 0
- ENDIF
- CASE(4)
- count2 = count2 + 1
- IF(count2.GT.10) THEN
- liter_cb = 1
- ELSE
- liter_cb = 0
- ENDIF
- END SELECT
-
- END FUNCTION liter_cb
-END MODULE liter_cb_mod
-
-MODULE TH5L_F03
-
-CONTAINS
-
-! *****************************************
-! *** H 5 L T E S T S
-! *****************************************
-
-
-!***************************************************************
-!**
-!** test_iter_group(): Test group iteration functionality
-!**
-!***************************************************************
-SUBROUTINE test_iter_group(total_error)
-
- USE liter_cb_mod
- IMPLICIT NONE
-
- INTEGER, INTENT(INOUT) :: total_error
- INTEGER(HID_T) :: fapl
- INTEGER(HID_T) :: file ! File ID
- INTEGER(hid_t) :: dataset ! Dataset ID
- INTEGER(hid_t) :: datatype ! Common datatype ID
- INTEGER(hid_t) :: filespace ! Common dataspace ID
- INTEGER(hid_t) :: grp ! Group ID
- INTEGER i,j ! counting variable
- INTEGER(hsize_t) idx ! Index in the group
- CHARACTER(LEN=11) :: DATAFILE = "titerate.h5"
- INTEGER, PARAMETER :: ndatasets = 50
- CHARACTER(LEN=10) :: name ! temporary name buffer
- CHARACTER(LEN=10), DIMENSION(1:ndatasets+2) :: lnames ! Names of the links created
-
- TYPE(iter_info), TARGET :: info
-
- INTEGER :: error
- INTEGER :: ret_value
- TYPE(C_FUNPTR) :: f1
- TYPE(C_PTR) :: f2
- CHARACTER(LEN=2) :: ichr2
- CHARACTER(LEN=10) :: ichr10
-
- ! Get the default FAPL
- CALL H5Pcreate_f(H5P_FILE_ACCESS_F, fapl, error)
- CALL check("h5pcreate_f", error, total_error)
-
- ! Set the "use the latest version of the format" bounds for creating objects in the file
- CALL H5Pset_libver_bounds_f(fapl, H5F_LIBVER_LATEST_F, H5F_LIBVER_LATEST_F, error)
- CALL check("H5Pset_libver_bounds_f",error, total_error)
-
- ! Create the test file with the datasets
- CALL h5fcreate_f(DATAFILE, H5F_ACC_TRUNC_F, file, error, H5P_DEFAULT_F, fapl)
- CALL check("h5fcreate_f", error, total_error)
-
- ! Test iterating over empty group
- idx = 0
- info%command = 0
- f1 = C_FUNLOC(liter_cb)
- f2 = C_LOC(info)
-
-
- CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
- CALL check("H5Literate_f", error, total_error)
-
- CALL H5Tcopy_f(H5T_NATIVE_INTEGER, datatype, error)
- CALL check("H5Tcopy_f", error, total_error)
-
- CALL H5Screate_f(H5S_SCALAR_F, filespace, error)
- CALL check("H5Screate_f", error, total_error)
-
- DO i = 1, ndatasets
- WRITE(ichr2, '(I2.2)') i
-
- name = 'Dataset '//ichr2
-
- CALL h5dcreate_f(file, name, datatype, filespace, dataset, error)
- CALL check("H5dcreate_f", error, total_error)
-
- lnames(i) = name
-
- CALL h5dclose_f(dataset,error)
- CALL check("H5dclose_f", error, total_error)
-
- ENDDO
-
- ! Create a group and named datatype under root group for testing
-
- CALL H5Gcreate_f(file, "grp0000000", grp, error)
- CALL check("H5Gcreate_f", error, total_error)
-
- lnames(ndatasets+2) = "grp0000000"
-
-!!$
-!!$ lnames[NDATASETS] = HDstrdup("grp");
-!!$ CHECK(lnames[NDATASETS], NULL, "strdup");
-!!$
-
- CALL H5Tcommit_f(file, "dtype00000", datatype, error)
- CALL check("H5Tcommit_f", error, total_error)
-
- lnames(ndatasets+1) = "dtype00000"
-
- ! Close everything up
-
- CALL H5Tclose_f(datatype, error)
- CALL check("H5Tclose_f", error, total_error)
-
- CALL H5Gclose_f(grp, error)
- CALL check("H5Gclose_f", error, total_error)
-
- CALL H5Sclose_f(filespace, error)
- CALL check("H5Sclose_f", error, total_error)
-
- CALL H5Fclose_f(file, error)
- CALL check("H5Fclose_f", error, total_error)
-
- ! Iterate through the datasets in the root group in various ways
- CALL H5Fopen_f(DATAFILE, H5F_ACC_RDONLY_F, file, error, access_prp=fapl)
- CALL check("h5fopen_f", error, total_error)
-
- ! Test all objects in group, when callback always returns 0
- info%command = 0
- idx = 0
- CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
- IF(ret_value.GT.0)THEN
- PRINT*,"ERROR: Group iteration function didn't return zero correctly!"
- CALL verify("H5Literate_f", error, -1, total_error)
- ENDIF
-
- ! Test all objects in group, when callback always returns 1
- ! This also tests the "restarting" ability, because the index changes
-
- info%command = 2
- idx = 0
- i = 0
- f1 = C_FUNLOC(liter_cb)
- f2 = C_LOC(info)
- DO
- CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
- IF(error.LT.0) EXIT
- ! Verify return value from iterator gets propagated correctly
- CALL verify("H5Literate", ret_value, 2, total_error)
- ! Increment the number of times "2" is returned
- i = i + 1
- ! Verify that the index is the correct value
- CALL verify("H5Literate", INT(idx), INT(i), total_error)
- IF(idx .GT.ndatasets+2)THEN
- PRINT*,"ERROR: Group iteration function walked too far!"
- ENDIF
-
- ! Verify the correct name is retrieved
- DO j = 1, 10
- ichr10(j:j) = info%name(j)(1:1)
- ENDDO
- CALL verify("H5Literate_f", ichr10, lnames(INT(idx)), total_error)
- IF(i.EQ.52)EXIT ! prints out error message otherwise (for gcc/gfortran/g95) not intel (why) -FIXME- scot
- END DO
-
- ! put check if did not walk far enough -scot FIXME
-
- IF(i .NE. (NDATASETS + 2)) THEN
- CALL verify("H5Literate_f", i, INT(NDATASETS + 2), total_error)
- PRINT*,"ERROR: Group iteration function didn't perform multiple iterations correctly"
- ENDIF
-
- ! Test all objects in group, when callback changes return value
- ! This also tests the "restarting" ability, because the index changes
-
- info%command = 3
- idx = 0
- i = 0
-
- f1 = C_FUNLOC(liter_cb)
- f2 = C_LOC(info)
- DO
-
- CALL H5Literate_f(file, H5_INDEX_NAME_F, H5_ITER_INC_F, idx, f1, f2, ret_value, error)
- IF(error.LT.0) EXIT
- CALL verify("H5Literate_f", ret_value, 1, total_error)
-
- ! Increment the number of times "1" is returned
- i = i + 1
-
- ! Verify that the index is the correct value
- CALL verify("H5Literate_f", INT(idx), INT(i+10), total_error)
-
- IF(idx .GT.ndatasets+2)THEN
- PRINT*,"Group iteration function walked too far!"
- ENDIF
-
- DO j = 1, 10
- ichr10(j:j) = info%name(j)(1:1)
- ENDDO
- ! Verify that the correct name is retrieved
- CALL verify("H5Literate_f", ichr10, lnames(INT(idx)), total_error)
- IF(i.EQ.42)EXIT ! prints out error message otherwise (for gcc/gfortran/g95) not intel (why) -FIX- scot
- ENDDO
-
- IF(i .NE. 42 .OR. idx .NE. 52)THEN
- PRINT*,"ERROR: Group iteration function didn't perform multiple iterations correctly!"
- CALL check("H5Literate_f",-1,total_error)
- ENDIF
-
- CALL H5Fclose_f(file, error)
- CALL check("H5Fclose_f", error, total_error)
-
-END SUBROUTINE test_iter_group
-
-END MODULE TH5L_F03