diff options
Diffstat (limited to 'fortran/src')
-rw-r--r-- | fortran/src/H5_f.c | 50 | ||||
-rw-r--r-- | fortran/src/H5_ff.F90 | 6 | ||||
-rw-r--r-- | fortran/src/H5config_f.inc.in | 3 | ||||
-rw-r--r-- | fortran/src/H5f90global.F90 | 7 | ||||
-rw-r--r-- | fortran/src/H5test_kind.F90 | 177 |
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 |