[svn-r26847] combined H5test_kind programs

1 files changed, 117 insertions, 138 deletions

diff --git a/fortran/src/H5test_kind.F90 b/fortran/src/H5test_kind.F90
index 1a1a0ec..6cd75bc 100644
--- a/fortran/src/H5test_kind.F90
+++ b/fortran/src/H5test_kind.F90
@@ -13,13 +13,17 @@
 !  depending on which of the KIND values are found.
 !
 ! NOTES
-!  This program is depreciated in favor of H5test_kind_SIZEOF.f90 and is only
-!  used when the Fortran intrinsic function SIZEOF is not available. It generates
-!  code that does not make use of SIZEOF in H5fortran_detect.f90 which is less
-!  portable in comparison to using SIZEOF.
+!  This program uses the Fortran 2008 intrinsic function STORAGE_SIZE or SIZEOF 
+!  depending on availablity.It generates code that makes use of 
+!  STORAGE_SIZE/SIZEOF in H5fortran_detect.f90. STORAGE_SIZE is standard
+!  compliant and should always be chosen over SIZEOF.
 !
-!  The availability of SIZEOF is checked at configure time and the TRUE/FALSE
-!  condition is set in the configure variable "FORTRAN_HAVE_SIZEOF".
+!  The availability of STORAGE_SIZE/SIZEOF is checked at configure time and the TRUE/FALSE
+!  condition is set in the configure variable "FORTRAN_HAVE_STORAGE_SIZE" or
+!  "FORTRAN_HAVE_SIZEOF".
+!
+!  The use of C_SIZOF(X) is not used since the argument X must be an interoperable
+!  data entity.
 !
 ! COPYRIGHT
 !  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
@@ -38,17 +42,22 @@
 !  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 !
 ! AUTHOR
-!  Elena Pourma
+!  M. Scot Breitenfeld
 !
 !*****
 
+#include "H5config_f.inc"
+
 PROGRAM test_kind
   IMPLICIT NONE
   INTEGER :: i, j, ii, ir, last, ikind_numbers(10), rkind_numbers(10)
   INTEGER :: ji, jr, jd
   last = -1
   ii = 0
-  j = SELECTED_INT_KIND(18)
+
+  ikind_numbers = 0
+  rkind_numbers = 0
+
   DO i = 1,100
      j = SELECTED_INT_KIND(i)
      IF(j .NE. last) THEN
@@ -88,11 +97,7 @@ WRITE(*,'(40(A,/))') &
 '!  H5fort_type_defines.h. The source code itself was automatically generated by',&
 '!  the program H5test_kind.f90',&
 '!',&
-'! NOTES',&
-'!  This source code does not make use of the Fortran intrinsic function SIZEOF because',&
-'!  the availability of the intrinsic function was determined to be not available at',&
-'!  configure time',&
-'!',&
+'! COPYRIGHT',&
 '! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *',&
 '!   Copyright by The HDF Group.                                               *',&
 '!   Copyright by the Board of Trustees of the University of Illinois.         *',&
@@ -113,156 +118,130 @@ WRITE(*,'(40(A,/))') &
 '!',&
 '!*****'
 
-!  Generate a program
+! GENERATE A PROGRAM
+!
+! (a) Generate the module
 
-  WRITE(*,*) "PROGRAM int_kind"
-  WRITE(*,*) "WRITE(*,*) "" /*generating header file*/ """
-  ji = 0
-  WRITE(*, "("" CALL i"", i2.2,""()"")") ji
-  jr = 0
-  WRITE(*, "("" CALL r"", i2.2,""()"")") jr
-  jd = 0
-  WRITE(*, "("" CALL d"", i2.2,""()"")") jd
-  DO i = 1, ii
-     j = ikind_numbers(i)
-     WRITE(*, "("" CALL i"", i2.2,""()"")") j
-  ENDDO
-  DO i = 1, ir
-     j = rkind_numbers(i)
-     WRITE(*, "("" CALL r"", i2.2,""()"")") j
-  ENDDO
-  WRITE(*,*) "END PROGRAM int_kind"
+  WRITE(*,*) "MODULE H5test_kind_mod"
+  WRITE(*,*) "USE ISO_C_BINDING"
+  WRITE(*,*) "IMPLICIT NONE"
+  WRITE(*,*) "CONTAINS"
   j = 0
   ji = KIND(1)
   WRITE(*, "("" SUBROUTINE i"", i2.2,""()"")") j
   WRITE(*,*)"   IMPLICIT NONE"
-  WRITE(*,*)"   INTEGER :: a = 0"
-  WRITE(*,*)"   INTEGER :: a_size"
-  WRITE(*,*)"   CHARACTER(LEN=2) :: jchr2"
-  WRITE(*,*)"   a_size = BIT_SIZE(a)"
-  WRITE(*,*)"   IF (a_size .EQ. 8) THEN"
-  WRITE(*,*)"       WRITE(jchr2,'(I2)')",ji
-  WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_NATIVE_1_KIND "'//"//ADJUSTL(jchr2)"
-  WRITE(*,*)"   endif"
-  WRITE(*,*)"   IF (a_size .EQ. 16) THEN"
-  WRITE(*,*)"       WRITE(jchr2,'(I2)')",ji
-  WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_NATIVE_2_KIND "'//"//ADJUSTL(jchr2)"
-  WRITE(*,*)"   endif"
-  WRITE(*,*)"   IF (a_size .EQ. 32) THEN"
-  WRITE(*,*)"       WRITE(jchr2,'(I2)')",ji
-  WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_NATIVE_4_KIND "'//"//ADJUSTL(jchr2)"
-  WRITE(*,*)"   ENDIF"
-  WRITE(*,*)"   IF (a_size .EQ. 64) THEN"
-  WRITE(*,*)"       WRITE(jchr2,'(I2)')",ji
-  WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_NATIVE_8_KIND "'//"//ADJUSTL(jchr2)"
-  WRITE(*,*)"   ENDIF"
-  WRITE(*,*)"   IF (a_size .EQ. 128) THEN"
-  WRITE(*,*)"       WRITE(jchr2,'(I2)')",ji
-  WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_NATIVE_16_KIND "'//"//ADJUSTL(jchr2)"
-  WRITE(*,*)"   ENDIF"
+  WRITE(*,*)"   INTEGER :: a"
+  WRITE(*,*)"   INTEGER(C_SIZE_T) :: a_size"
+  WRITE(*,*)"   CHARACTER(LEN=2) :: ichr2, jchr2"
+#ifdef H5_FORTRAN_HAVE_STORAGE_SIZE
+  WRITE(*,*)"   a_size = STORAGE_SIZE(a, c_size_t)/STORAGE_SIZE(c_char_'a',c_size_t)"
+#else
+  WRITE(*,*)"   a_size = SIZEOF(a)"
+#endif
+  WRITE(*,*)"   WRITE(ichr2,'(I2)') a_size"
+  WRITE(*,'(A,I0)')"    WRITE(jchr2,'(I2)') ",ji
+  WRITE(*,'(A)')'    WRITE(*,*) "#define H5_FORTRAN_HAS_NATIVE_"'//  &
+       "//TRIM(ADJUSTL(ichr2))//"//'"_KIND "'//"//ADJUSTL(jchr2)"
   WRITE(*,*)"   RETURN"
   WRITE(*,*)"END SUBROUTINE"
-  jr = KIND(1.0)
-  WRITE(*, "("" SUBROUTINE r"", i2.2,""()"")") j
+  jr = 0
+  j = KIND(1.0)
+  WRITE(*, "("" SUBROUTINE r"", i2.2,""()"")") jr
   WRITE(*,*)"   IMPLICIT NONE"
-  WRITE(*,*)"   REAL :: b(32)"
-  WRITE(*,*)"   INTEGER :: a(1)"
-  WRITE(*,*)"   INTEGER :: a_size"
-  WRITE(*,*)"   INTEGER :: real_size"
-  WRITE(*,*)"   CHARACTER(LEN=2) :: jchr2"
-  WRITE(*,*)"   a_size = BIT_SIZE(a(1)) ! Size in bits for integer"
-  WRITE(*,*)"   real_size = (SIZE(TRANSFER(b,a))*a_size)/SIZE(b)"
-  WRITE(*,*)"   IF (real_size .EQ. 32) THEN"
-  WRITE(*,*)"       WRITE(jchr2,'(I2)')",jr
-  WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_REAL_NATIVE_4_KIND "'//"//ADJUSTL(jchr2)"
-  WRITE(*,*)"   ENDIF"
-  WRITE(*,*)"   IF (real_size .EQ. 64) THEN"
-  WRITE(*,*)"       WRITE(jchr2,'(I2)')",jr
-  WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_REAL_NATIVE_8_KIND "'//"//ADJUSTL(jchr2)"
-  WRITE(*,*)"   ENDIF"
-  WRITE(*,*)"   IF (real_size .EQ. 128) THEN"
-  WRITE(*,*)"       WRITE(jchr2,'(I2)')",jr
-  WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_REAL_NATIVE_16_KIND "'//"//ADJUSTL(jchr2)"
-  WRITE(*,*)"   ENDIF"
+  WRITE(*,*)"   REAL :: a"
+  WRITE(*,*)"   INTEGER(C_SIZE_T) :: a_size"
+  WRITE(*,*)"   CHARACTER(LEN=2) :: ichr2, jchr2"
+#ifdef H5_FORTRAN_HAVE_STORAGE_SIZE
+  WRITE(*,*)"   a_size = STORAGE_SIZE(a, c_size_t)/STORAGE_SIZE(c_char_'a',c_size_t)"
+#else
+  WRITE(*,*)"   a_size = SIZEOF(a)"
+#endif
+  WRITE(*,*)"   WRITE(ichr2,'(I2)') a_size"
+  WRITE(*,'(A,I0)')"    WRITE(jchr2,'(I2)') ",j
+  WRITE(*,'(A)')'    WRITE(*,*) "#define H5_FORTRAN_HAS_REAL_NATIVE_"'//  &
+       "//TRIM(ADJUSTL(ichr2))//"//'"_KIND "'//"//ADJUSTL(jchr2)"
   WRITE(*,*)"   RETURN"
   WRITE(*,*)"END SUBROUTINE"
-  jd = KIND(1.d0)
-  WRITE(*, "("" SUBROUTINE d"", i2.2,""()"")") j
+  jd = 0
+  j = KIND(1.d0)
+  WRITE(*, "("" SUBROUTINE d"", i2.2,""()"")") jd
   WRITE(*,*)"   IMPLICIT NONE"
-  WRITE(*,*)"   DOUBLE PRECISION :: b=0"
-  WRITE(*,*)"   INTEGER :: a(8)=0"
-  WRITE(*,*)"   INTEGER :: a_size"
-  WRITE(*,*)"   INTEGER :: b_size"
-  WRITE(*,*)"   CHARACTER(LEN=2) :: jchr2"
-  WRITE(*,*)"   a_size = BIT_SIZE(a(1))"
-  WRITE(*,*)"   b_size = SIZE(transfer(b,a))*a_size"
-  WRITE(*,*)"   IF (b_size .EQ. 64) THEN"
-  WRITE(*,*)"       WRITE(jchr2,'(I2)')",jd
-  WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_DOUBLE_NATIVE_8_KIND "'//"//ADJUSTL(jchr2)"
-  WRITE(*,*)"   ENDIF"
-  WRITE(*,*)"   IF (b_size .EQ. 128) THEN"
-  WRITE(*,*)"       WRITE(jchr2,'(I2)')",jd
-  WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_DOUBLE_NATIVE_16_KIND "'//"//ADJUSTL(jchr2)"
-  WRITE(*,*)"   ENDIF"
+  WRITE(*,*)"   DOUBLE PRECISION :: a"
+  WRITE(*,*)"   INTEGER(C_SIZE_T) :: a_size"
+  WRITE(*,*)"   CHARACTER(LEN=2) :: ichr2, jchr2"
+#ifdef H5_FORTRAN_HAVE_STORAGE_SIZE
+  WRITE(*,*)"   a_size = STORAGE_SIZE(a, c_size_t)/STORAGE_SIZE(c_char_'a',c_size_t)"
+#else
+  WRITE(*,*)"   a_size = SIZEOF(a)"
+#endif
+  WRITE(*,*)"   WRITE(ichr2,'(I2)') a_size"
+  WRITE(*,'(A,I0)')"    WRITE(jchr2,'(I2)') ",j
+  WRITE(*,'(A)')'    WRITE(*,*) "#define H5_FORTRAN_HAS_DOUBLE_NATIVE_"'//  &
+       "//TRIM(ADJUSTL(ichr2))//"//'"_KIND "'//"//ADJUSTL(jchr2)"
   WRITE(*,*)"   RETURN"
   WRITE(*,*)"END SUBROUTINE"
   DO i = 1, ii
      j = ikind_numbers(i)
      WRITE(*, "("" SUBROUTINE i"", i2.2,""()"")") j
      WRITE(*,*)"   IMPLICIT NONE"
-     WRITE(*,*)"   INTEGER(",j,") :: a = 0"
-     WRITE(*,*)"   INTEGER :: a_size"
-     WRITE(*,*)"   CHARACTER(LEN=2) :: jchr2"
-     WRITE(*,*)"   a_size = BIT_SIZE(a)"
-     WRITE(*,*)"   IF (a_size .EQ. 8) THEN"
-     WRITE(*,*)"       WRITE(jchr2,'(I2)')",j
-     WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_INTEGER_1_KIND "'//"//ADJUSTL(jchr2)"
-     WRITE(*,*)"   ENDIF"
-     WRITE(*,*)"   IF (a_size .EQ. 16) THEN"
-     WRITE(*,*)"       WRITE(jchr2,'(I2)')",j
-     WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_INTEGER_2_KIND "'//"//ADJUSTL(jchr2)"
-     WRITE(*,*)"   ENDIF"
-     WRITE(*,*)"   IF (a_size .EQ. 32) THEN"
-     WRITE(*,*)"       WRITE(jchr2,'(I2)')",j
-     WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_INTEGER_4_KIND "'//"//ADJUSTL(jchr2)"
-     WRITE(*,*)"   ENDIF"
-     WRITE(*,*)"   IF (a_size .EQ. 64) THEN"
-     WRITE(*,*)"       WRITE(jchr2,'(I2)')",j
-     WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_INTEGER_8_KIND "'//"//ADJUSTL(jchr2)"
-     WRITE(*,*)"   ENDIF"
-     WRITE(*,*)"   IF (a_size .EQ. 128) THEN"
-     WRITE(*,*)"       WRITE(jchr2,'(I2)')",j
-     WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_INTEGER_16_KIND "'//"//ADJUSTL(jchr2)"
-     WRITE(*,*)"   ENDIF"
+     WRITE(*,'(A,I0,A)')"   INTEGER(KIND=",j,") :: a"
+     WRITE(*,*)"   INTEGER(C_SIZE_T) :: a_size"
+     WRITE(*,*)"   CHARACTER(LEN=2) :: ichr2, jchr2"
+#ifdef H5_FORTRAN_HAVE_STORAGE_SIZE
+     WRITE(*,*)"   a_size = STORAGE_SIZE(a, c_size_t)/STORAGE_SIZE(c_char_'a',c_size_t)"
+#else
+     WRITE(*,*)"   a_size = SIZEOF(a)"
+#endif
+     WRITE(*,*)"   WRITE(ichr2,'(I2)') a_size"
+     WRITE(*,'(A,I0)')"    WRITE(jchr2,'(I2)') ",j
+     WRITE(*,'(A)')'    WRITE(*,*) "#define H5_FORTRAN_HAS_INTEGER_"'//  &
+          "//TRIM(ADJUSTL(ichr2))//"//'"_KIND "'//"//ADJUSTL(jchr2)"
      WRITE(*,*)"   RETURN"
-     WRITE(*,*)"   END SUBROUTINE"
+     WRITE(*,*)"END SUBROUTINE"
   ENDDO
   DO i = 1, ir
      j = rkind_numbers(i)
      WRITE(*, "("" SUBROUTINE r"", i2.2,""()"")") j
      WRITE(*,*)"   IMPLICIT NONE"
-     WRITE(*,*)"   REAL(KIND=",j,") :: b(32)"
-     WRITE(*,*)"   INTEGER :: a(1)"
-     WRITE(*,*)"   INTEGER :: a_size"
-     WRITE(*,*)"   INTEGER :: real_size"
-     WRITE(*,*)"   CHARACTER(LEN=2) :: jchr2"
-     WRITE(*,*)"   a_size = BIT_SIZE(a(1)) ! Size in bits for integer"
-     WRITE(*,*)"   real_size = (SIZE(TRANSFER(b,a))*a_size)/SIZE(b)"
-     WRITE(*,*)"   IF (real_size .EQ. 32) THEN"
-     WRITE(*,*)"       WRITE(jchr2,'(I2)')",j
-     WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_REAL_4_KIND "'//"//ADJUSTL(jchr2)"
-     WRITE(*,*)"   ENDIF"
-     WRITE(*,*)"   IF (real_size .EQ. 64) THEN"
-     WRITE(*,*)"       WRITE(jchr2,'(I2)')",j
-     WRITE(*,*)'       WRITE(*,*) "#define H5_FORTRAN_HAS_REAL_8_KIND "'//"//ADJUSTL(jchr2)"
-     WRITE(*,*)"   endif"
-     WRITE(*,*)"   IF (real_size .EQ. 128) THEN"
-     WRITE(*,*)"       WRITE(jchr2,'(I2)')",j
-     WRITE(*,'(A)')'       WRITE(*,*) "#define H5_FORTRAN_HAS_REAL_16_KIND "'//"//ADJUSTL(jchr2)"
-     WRITE(*,*)"   ENDIF"
+     WRITE(*,'(A,I0,A)')"    REAL(KIND= ",j,") :: a"
+     WRITE(*,*)"   INTEGER(C_SIZE_T) :: a_size"
+     WRITE(*,*)"   CHARACTER(LEN=2) :: ichr2, jchr2"
+#ifdef H5_FORTRAN_HAVE_STORAGE_SIZE
+     WRITE(*,*)"   a_size = STORAGE_SIZE(a, c_size_t)/STORAGE_SIZE(c_char_'a',c_size_t)"
+#else
+     WRITE(*,*)"   a_size = SIZEOF(a)"
+#endif
+     WRITE(*,*)"   WRITE(ichr2,'(I2)') a_size"
+     WRITE(*,'(A,I0)')"    WRITE(jchr2,'(I2)') ", j
+     WRITE(*,'(A)')'    WRITE(*,*) "#define H5_FORTRAN_HAS_REAL_"'//  &
+          "//TRIM(ADJUSTL(ichr2))//"//'"_KIND "'//"//ADJUSTL(jchr2)"
      WRITE(*,*)"   RETURN"
-     WRITE(*,*)"   END SUBROUTINE"
+     WRITE(*,*)"END SUBROUTINE"
+  ENDDO
+  WRITE(*,*) "END MODULE H5test_kind_mod"
+  WRITE(*,*) ""
+
+  ! (b) generate the main program
+
+  WRITE(*,*) "PROGRAM H5test_kind"
+  WRITE(*,*) "USE H5test_kind_mod"
+  WRITE(*,*) "WRITE(*,*) "" /*generating header file*/ """
+  ji = 0
+  WRITE(*, "("" CALL i"", i2.2,""()"")") ji
+  jr = 0
+  WRITE(*, "("" CALL r"", i2.2,""()"")") jr
+  jd = 0
+  WRITE(*, "("" CALL d"", i2.2,""()"")") jd
+  DO i = 1, ii
+     j = ikind_numbers(i)
+     WRITE(*, "("" CALL i"", i2.2,""()"")") j
   ENDDO
+  DO i = 1, ir
+     j = rkind_numbers(i)
+     WRITE(*, "("" CALL r"", i2.2,""()"")") j
+  ENDDO
+  WRITE(*,*) "END PROGRAM H5test_kind"
+
 END PROGRAM test_kind