diff options
author | Scot Breitenfeld <brtnfld@hdfgroup.org> | 2015-08-31 18:49:17 (GMT) |
---|---|---|
committer | Scot Breitenfeld <brtnfld@hdfgroup.org> | 2015-08-31 18:49:17 (GMT) |
commit | e6f9fc5f7f58e4c0a9a8541bc5674b440abd658c (patch) | |
tree | fb806c6eebcecca69438629f6f7a6e0c9096ac1f /fortran/test/tH5L_F03.f90 | |
parent | de1bafd1d81f936c046317720d7a73bcdb41f5e6 (diff) | |
download | hdf5-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.f90 | 318 |
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 |