[svn-r27134] Switched to uses a verify for each kind for the tests. Testing quad precision.

5 files changed, 239 insertions, 4 deletions

diff --git a/fortran/src/H5_f.c b/fortran/src/H5_f.c
index 5eb6ef8..6a6be41 100644
--- a/fortran/src/H5_f.c
+++ b/fortran/src/H5_f.c
@@ -126,7 +126,11 @@ h5init_types_c( hid_t_f * types, hid_t_f * floatingtypes, hid_t_f * integertypes
       if ((types[6] = (hid_t_f)H5Tcopy(H5T_NATIVE_INT)) < 0) return ret_value;
     } /*end if */
     else if (sizeof(int_1_f) == sizeof(long long)) {
-	if ((types[6] = (hid_t_f)H5Tcopy(H5T_NATIVE_LLONG)) < 0) return ret_value;
+      if ((types[6] = (hid_t_f)H5Tcopy(H5T_NATIVE_LLONG)) < 0) return ret_value;
+    } /*end if */
+    else {
+      if ((types[6] = H5Tcopy (H5T_NATIVE_INT)) < 0) return ret_value;
+      if ( H5Tset_precision (types[6], 128) < 0) return ret_value;
     } /*end else */
     /*
      * FIND H5T_NATIVE_INTEGER_2
@@ -143,6 +147,10 @@ h5init_types_c( hid_t_f * types, hid_t_f * floatingtypes, hid_t_f * integertypes
     else if (sizeof(int_2_f) == sizeof(long long)) {
 	if ((types[7] = (hid_t_f)H5Tcopy(H5T_NATIVE_LLONG)) < 0) return ret_value;
     } /*end else */
+    else {
+      if ((types[7] = H5Tcopy (H5T_NATIVE_INT)) < 0) return ret_value;
+      if ( H5Tset_precision (types[7], 128) < 0) return ret_value;
+    } /*end else */
     /*
      * FIND H5T_NATIVE_INTEGER_4
      */
@@ -158,6 +166,10 @@ h5init_types_c( hid_t_f * types, hid_t_f * floatingtypes, hid_t_f * integertypes
     else if (sizeof(int_4_f) == sizeof(long long)) {
 	if ((types[8] = (hid_t_f)H5Tcopy(H5T_NATIVE_LLONG)) < 0) return ret_value;
     } /*end else */
+    else {
+      if ((types[8] = H5Tcopy (H5T_NATIVE_INT)) < 0) return ret_value;
+      if ( H5Tset_precision (types[8], 128) < 0) return ret_value;
+    } /*end else */
     /*
      * FIND H5T_NATIVE_INTEGER_8
      */
@@ -173,6 +185,11 @@ h5init_types_c( hid_t_f * types, hid_t_f * floatingtypes, hid_t_f * integertypes
     else if (sizeof(int_8_f) == sizeof(long long)) {
 	if ((types[9] = (hid_t_f)H5Tcopy(H5T_NATIVE_LLONG)) < 0) return ret_value;
     } /*end else */
+    else {
+      if ((types[9] = H5Tcopy (H5T_NATIVE_INT)) < 0) return ret_value;
+      if ( H5Tset_precision (types[9], 128) < 0) return ret_value;
+    } /*end else */
+
     /*
      * FIND H5T_NATIVE_REAL_C_FLOAT
      */
@@ -221,7 +238,36 @@ h5init_types_c( hid_t_f * types, hid_t_f * floatingtypes, hid_t_f * integertypes
     if ((types[13] = (hid_t_f)H5Tcopy(H5T_NATIVE_B8))  < 0) return ret_value;
     if ((types[14] = (hid_t_f)H5Tcopy(H5T_NATIVE_B16)) < 0) return ret_value;
     if ((types[15] = (hid_t_f)H5Tcopy(H5T_NATIVE_B32)) < 0) return ret_value;
-    if ((types[16] = (hid_t_f)H5Tcopy(H5T_NATIVE_B64)) < 0) return ret_value;  
+    if ((types[16] = (hid_t_f)H5Tcopy(H5T_NATIVE_B64)) < 0) return ret_value;
+
+/* #ifdef -MSB-  */
+     /*
+     * FIND H5T_NATIVE_INTEGER_16
+     */
+    if (sizeof(int_16_f) == sizeof(char)) {
+      if ((types[17] = (hid_t_f)H5Tcopy(H5T_NATIVE_CHAR)) < 0) return ret_value;
+    } /*end if */
+    else if (sizeof(int_16_f) == sizeof(short)) {
+      if ((types[17] = (hid_t_f)H5Tcopy(H5T_NATIVE_SHORT)) < 0) return ret_value;
+    } /*end if */
+    else if (sizeof(int_16_f) == sizeof(int)) {
+      if ((types[17] = (hid_t_f)H5Tcopy(H5T_NATIVE_INT)) < 0) return ret_value;
+    } /*end if */
+    else if (sizeof(int_16_f) == sizeof(long long)) {
+	if ((types[17] = (hid_t_f)H5Tcopy(H5T_NATIVE_LLONG)) < 0) return ret_value;
+    } /*end else */
+    else {
+      if ((types[17] = H5Tcopy (H5T_NATIVE_INT)) < 0) return ret_value;
+      if ( H5Tset_precision (types[17], 128) < 0) return ret_value;
+    } /*end else */
+
+
+/* #ifdef -MSB-  */
+     /*
+     * FIND H5T_NATIVE_FLOAT_128
+     */
+    if ((types[18] = H5Tcopy (H5T_NATIVE_FLOAT)) < 0) return ret_value;
+    if ( H5Tset_precision (types[18], 128) < 0) return ret_value;
 
     if ((floatingtypes[0] = (hid_t_f)H5Tcopy(H5T_IEEE_F32BE)) < 0) return ret_value;
     if ((floatingtypes[1] = (hid_t_f)H5Tcopy(H5T_IEEE_F32LE)) < 0) return ret_value;
diff --git a/fortran/src/H5_ff.F90 b/fortran/src/H5_ff.F90
index d7d9efe..25c7eab 100644
--- a/fortran/src/H5_ff.F90
+++ b/fortran/src/H5_ff.F90
@@ -377,6 +377,9 @@ CONTAINS
           h5_type = H5T_NATIVE_INTEGER_4
        ELSE IF(kind.EQ.Fortran_INTEGER_8)THEN
           h5_type = H5T_NATIVE_INTEGER_8
+! NEED ifdef -MSB-
+       ELSE IF(kind.EQ.Fortran_INTEGER_16)THEN
+          h5_type = H5T_NATIVE_INTEGER_16
        ENDIF
     ELSE IF(flag.EQ.H5_REAL_KIND)THEN
        IF(kind.EQ.Fortran_REAL_C_FLOAT)THEN
@@ -385,6 +388,9 @@ CONTAINS
           h5_type = H5T_NATIVE_REAL_C_DOUBLE
        ELSE IF(kind.EQ.Fortran_REAL_C_LONG_DOUBLE)THEN
           h5_type = H5T_NATIVE_REAL_C_LONG_DOUBLE
+! NEED ifdef -MSB-
+       ELSE IF(kind.EQ.Fortran_REAL_C_FLOAT128)THEN
+          h5_type = H5T_NATIVE_FLOAT_128
        ENDIF
     ENDIF
 
diff --git a/fortran/src/H5config_f.inc.in b/fortran/src/H5config_f.inc.in
index 3786130..0203315 100644
--- a/fortran/src/H5config_f.inc.in
+++ b/fortran/src/H5config_f.inc.in
@@ -15,5 +15,8 @@
 ! Define if the intrinsic function C_LONG_DOUBLE exists
 #undef FORTRAN_HAVE_C_LONG_DOUBLE
 
+! Define if the intrinsic module ISO_FORTRAN_ENV exists
+#undef HAVE_ISO_FORTRAN_ENV
+
 ! Define the size of C's long double
 #define H5_SIZEOF_LONG_DOUBLE
diff --git a/fortran/src/H5f90global.F90 b/fortran/src/H5f90global.F90
index 5e67220..c88327c 100644
--- a/fortran/src/H5f90global.F90
+++ b/fortran/src/H5f90global.F90
@@ -66,7 +66,7 @@ MODULE H5GLOBAL
      INTEGER, DIMENSION(1:REF_REG_BUF_LEN) :: ref
   END TYPE hdset_reg_ref_t_f
 
-  INTEGER, PARAMETER :: PREDEF_TYPES_LEN = 17 ! Do not forget to change this
+  INTEGER, PARAMETER :: PREDEF_TYPES_LEN = 19 ! Do not forget to change this
                                               ! value when new predefined
                                               ! datatypes are added
 
@@ -108,6 +108,9 @@ MODULE H5GLOBAL
        H5T_STD_U16BE,   &
        H5T_STD_U16LE,   &
        H5T_STD_U32BE
+       
+  INTEGER(HID_T) :: H5T_NATIVE_INTEGER_16 ! NEED IFDEF -MSB-
+  INTEGER(HID_T) :: H5T_NATIVE_FLOAT_128 ! NEED IFDEF -MSB-
 
 ! NOTE: Splitting the line since the Fortran 95 standard limits the number of 
 !       continuation lines to 39; the F03/F08 standard limits the number 
@@ -151,6 +154,8 @@ MODULE H5GLOBAL
   EQUIVALENCE (predef_types(15), H5T_NATIVE_B16)
   EQUIVALENCE (predef_types(16), H5T_NATIVE_B32)
   EQUIVALENCE (predef_types(17), H5T_NATIVE_B64)  
+  EQUIVALENCE (predef_types(18), H5T_NATIVE_INTEGER_16)   ! ADDED NEW TYPE -MSB- 
+  EQUIVALENCE (predef_types(19), H5T_NATIVE_FLOAT_128)   ! ADDED NEW TYPE -MSB-
 
   INTEGER(HID_T), DIMENSION(FLOATING_TYPES_LEN) :: floating_types
   EQUIVALENCE (floating_types(1), H5T_IEEE_F32BE )
diff --git a/fortran/src/H5test_kind.F90 b/fortran/src/H5test_kind.F90
index 018e603..e83139a 100644
--- a/fortran/src/H5test_kind.F90
+++ b/fortran/src/H5test_kind.F90
@@ -322,7 +322,7 @@ WRITE(*,'(40(A,/))') &
 !
 ! Only interfaces with arrays of rank 7 and less are provided. Even-though, the F2008 
 ! standard extended the maximum rank to 15, it was decided that they should use the
-! new APIs to handle this use case. Handling rank 7 and less is for backward compatibility
+! new APIs to handle those use cases. Handling rank 7 and less is for backward compatibility
 ! with the Fortran 90/95 APIs codes which could never handle rank 15 array sizes.
 
   OPEN(11,FILE='H5_KINDff.F90')
@@ -770,6 +770,181 @@ WRITE(*,'(40(A,/))') &
 
   WRITE(11,'(A)') 'END MODULE H5_KIND'
 
+  CLOSE(11)
+
+! (b) Generate Fortran Check routines for the tests KIND interfaces.
+  OPEN(11,FILE='../test/tf_gen.F90')
+  WRITE(11,'(40(A,/))') &
+'!****h* ROBODoc/TH5_MISC_gen.F90',&
+'!',&
+'! NAME',&
+'!  TH5_MISC_gen',&
+'! ',&
+'! PURPOSE',&
+'!  This module is generated at build by H5test_kind.F90 to handle checking ',&
+'!  in the tests all the detected KINDs.',&
+'!',&
+'! COPYRIGHT',&
+'! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *',&
+'!   Copyright by The HDF Group.                                               *',&
+'!   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.     *',&
+'! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *',&
+'!',&
+'! AUTHOR',&
+'!  H5test_kind.F90',&
+'!',&
+'!*****'
+
+  WRITE(11,'(a)') "MODULE TH5_MISC_gen"
+
+  WRITE(11,'(A)') '  USE, INTRINSIC :: ISO_C_BINDING'
+  WRITE(11,'(A)') '  USE H5GLOBAL'
+  
+! Interfaces for validating REALs, INTEGERs, CHARACTERs, LOGICALs
+
+  WRITE(11,'(A)') '  INTERFACE verify'
+  DO i = 1, ir
+     j = rkind_numbers(i)
+     WRITE(chr2,'(I2)') j
+     WRITE(11,'(A)') "     MODULE PROCEDURE verify_real_kind_"//TRIM(ADJUSTL(chr2))
+  END DO
+  DO i = 1, ii
+     j = ikind_numbers(i)
+     WRITE(chr2,'(I2)') j
+     WRITE(11,'(A)') "     MODULE PROCEDURE verify_integer_kind_"//TRIM(ADJUSTL(chr2))
+  END DO
+  WRITE(11,'(A)') "     MODULE PROCEDURE verify_character"
+  WRITE(11,'(A)') "     MODULE PROCEDURE verify_logical"
+  WRITE(11,'(A)') "  END INTERFACE"
+
+  WRITE(11,'(A)') '  INTERFACE check_real_eq'
+  DO i = 1, ir
+     j = rkind_numbers(i)
+     WRITE(chr2,'(I2)') j
+     WRITE(11,'(A)') "     MODULE PROCEDURE real_eq_kind_"//TRIM(ADJUSTL(chr2))
+  END DO
+  WRITE(11,'(A)') "  END INTERFACE"
+
+  WRITE(11,'(A)') 'CONTAINS'
+
+! ***************************
+! VALIDATE INTEGERS
+! ***************************
+  DO i = 1, ii
+     k = ikind_numbers(i)
+     WRITE(chr2,'(I2)') k
+! DLL definitions for windows
+     WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_TEST_DLL)'
+     WRITE(11,'(A)') '!DEC$attributes dllexport :: verify_integer_kind_'//TRIM(ADJUSTL(chr2))
+     WRITE(11,'(A)') '!DEC$endif'
+
+! Subroutine API
+     WRITE(11,'(A)') '  SUBROUTINE verify_integer_kind_'//TRIM(ADJUSTL(chr2))//'(string,value,correct_value,total_error)'
+     WRITE(11,'(A)') '    IMPLICIT NONE'
+     WRITE(11,'(A)') '    CHARACTER(LEN=*) :: string'
+     WRITE(11,'(A)') '    INTEGER(KIND='//TRIM(ADJUSTL(chr2))//') :: value, correct_value'
+     WRITE(11,'(A)') '    INTEGER :: total_error'
+     WRITE(11,'(A)') '    IF (value .NE. correct_value) THEN'
+     WRITE(11,'(A)') '       total_error=total_error+1'
+     WRITE(11,'(A)') '       WRITE(*,*) "ERROR: INCORRECT INTEGER VALIDATION ", string'
+     WRITE(11,'(A)') '    ENDIF'
+     WRITE(11,'(A)') '  END SUBROUTINE verify_integer_kind_'//TRIM(ADJUSTL(chr2))
+ ENDDO
+
+! ***************************
+! VALIDATE REALS
+! ***************************
+  DO i = 1, ir
+     k = rkind_numbers(i)
+     WRITE(chr2,'(I2)') k
+! DLL definitions for windows
+     WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_TEST_DLL)'
+     WRITE(11,'(A)') '!DEC$attributes dllexport :: verify_real_kind_'//TRIM(ADJUSTL(chr2))
+     WRITE(11,'(A)') '!DEC$endif'
+    
+! Subroutine API 
+     WRITE(11,'(A)') '  SUBROUTINE verify_real_kind_'//TRIM(ADJUSTL(chr2))//'(string,value,correct_value,total_error)'
+     WRITE(11,'(A)') '    IMPLICIT NONE'
+     WRITE(11,'(A)') '    CHARACTER(LEN=*) :: string'
+     WRITE(11,'(A)') '    REAL(KIND='//TRIM(ADJUSTL(chr2))//') :: value, correct_value'
+     WRITE(11,'(A)') '    INTEGER :: total_error'
+     WRITE(11,'(A)') '    IF (.NOT.real_eq_kind_'//TRIM(ADJUSTL(chr2))//'( value, correct_value) ) THEN'
+     WRITE(11,'(A)') '       total_error=total_error+1'
+     WRITE(11,'(A)') '       WRITE(*,*) "ERROR: INCORRECT REAL VALIDATION ", string'
+     WRITE(11,'(A)') '    ENDIF'
+     WRITE(11,'(A)') '  END SUBROUTINE verify_real_kind_'//TRIM(ADJUSTL(chr2))
+
+
+! ***********************************
+! TEST IF TWO REAL NUMBERS ARE EQUAL
+! ***********************************
+
+     WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_TEST_DLL)'
+     WRITE(11,'(A)') '!DEC$attributes dllexport :: real_eq_kind_'//TRIM(ADJUSTL(chr2))
+     WRITE(11,'(A)') '!DEC$endif'
+     WRITE(11,'(A)') '  LOGICAL FUNCTION real_eq_kind_'//TRIM(ADJUSTL(chr2))//'(a,b)'
+     WRITE(11,'(A)') '    REAL(KIND='//TRIM(ADJUSTL(chr2))//'), INTENT (in):: a,b'
+     WRITE(11,'(A)') '    REAL(KIND='//TRIM(ADJUSTL(chr2))//'), PARAMETER :: eps = 1.e-8'
+     WRITE(11,'(A)') '    real_eq_kind_'//TRIM(ADJUSTL(chr2))//' = ABS(a-b) .LT. eps'
+     WRITE(11,'(A)') '  END FUNCTION real_eq_kind_'//TRIM(ADJUSTL(chr2))
+  ENDDO
+
+! ***************************
+! VALIDATE CHARACTER STRINGS
+! ***************************
+
+! DLL definitions for windows
+  WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_TEST_DLL)'
+  WRITE(11,'(A)') '!DEC$attributes dllexport :: verify_character'
+  WRITE(11,'(A)') '!DEC$endif'
+
+! Subroutine API 
+  WRITE(11,'(A)') '  SUBROUTINE verify_character(string,value,correct_value,total_error)'
+  WRITE(11,'(A)') '    IMPLICIT NONE'
+  WRITE(11,'(A)') '    CHARACTER*(*) :: string'
+  WRITE(11,'(A)') '    CHARACTER*(*) :: value, correct_value'
+  WRITE(11,'(A)') '    INTEGER :: total_error'
+  WRITE(11,'(A)') '    IF (TRIM(value) .NE. TRIM(correct_value)) THEN'
+  WRITE(11,'(A)') '       total_error = total_error + 1'
+  WRITE(11,'(A)') '       WRITE(*,*) "ERROR: INCORRECT VALIDATION ", string'
+  WRITE(11,'(A)') '    ENDIF'
+  WRITE(11,'(A)') '  END SUBROUTINE verify_character'
+
+! ***************************
+! VALIDATE LOGICAL
+! ***************************
+
+! DLL definitions for windows
+  WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_TEST_DLL)'
+  WRITE(11,'(A)') '!DEC$attributes dllexport :: verify_logical'
+  WRITE(11,'(A)') '!DEC$endif'
+! Subroutine API 
+  WRITE(11,'(A)') '  SUBROUTINE verify_logical(string,value,correct_value,total_error)'
+  WRITE(11,'(A)') '    CHARACTER(LEN=*) :: string'
+  WRITE(11,'(A)') '    LOGICAL :: value, correct_value'
+  WRITE(11,'(A)') '    INTEGER :: total_error'
+  WRITE(11,'(A)') '    IF (value .NEQV. correct_value) THEN'
+  WRITE(11,'(A)') '       total_error = total_error + 1'
+  WRITE(11,'(A)') '       WRITE(*,*) "ERROR: INCORRECT VALIDATION ", string'
+  WRITE(11,'(A)') '    ENDIF'
+  
+  WRITE(11,'(A)') '  END SUBROUTINE verify_logical'
+
+
+
+  WRITE(11,'(A)') "END MODULE TH5_MISC_gen"
+
+  CLOSE(11)
+
 END PROGRAM test_kind