[svn-r27625] Added preprocessor commands for PGI compiler.

tested: h5committest

1 files changed, 318 insertions, 0 deletions

diff --git a/fortran/test/tH5L_F03.F90 b/fortran/test/tH5L_F03.F90
new file mode 100644
index 0000000..40afdbc
--- /dev/null
+++ b/fortran/test/tH5L_F03.F90
@@ -0,0 +1,318 @@
+!****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