summaryrefslogtreecommitdiffstats
path: root/fortran/src/H5test_kind.f90
diff options
context:
space:
mode:
Diffstat (limited to 'fortran/src/H5test_kind.f90')
-rw-r--r--fortran/src/H5test_kind.f90269
1 files changed, 269 insertions, 0 deletions
diff --git a/fortran/src/H5test_kind.f90 b/fortran/src/H5test_kind.f90
new file mode 100644
index 0000000..1a1a0ec
--- /dev/null
+++ b/fortran/src/H5test_kind.f90
@@ -0,0 +1,269 @@
+!****p* Program/H5test_kind
+!
+! NAME
+! Executable: H5test_kind
+!
+! FILE
+! fortran/src/H5test_kind.f90
+!
+! PURPOSE
+! This stand alone program is used at build time to generate the program
+! H5fortran_detect.f90. It cycles through all the available KIND parameters for
+! integers and reals. The appropriate program and subroutines are then generated
+! 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.
+!
+! The availability of SIZEOF is checked at configure time and the TRUE/FALSE
+! condition is set in the configure variable "FORTRAN_HAVE_SIZEOF".
+!
+! 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. *
+! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+!
+! AUTHOR
+! Elena Pourma
+!
+!*****
+
+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)
+ DO i = 1,100
+ j = SELECTED_INT_KIND(i)
+ IF(j .NE. last) THEN
+ IF(last .NE. -1) THEN
+ ii = ii + 1
+ ikind_numbers(ii) = last
+ ENDIF
+ last = j
+ IF(j .EQ. -1) EXIT
+ ENDIF
+ ENDDO
+
+ last = -1
+ ir = 0
+ DO i = 1,100
+ j = SELECTED_REAL_KIND(i)
+ IF(j .NE. last) THEN
+ IF(last .NE. -1) THEN
+ ir = ir + 1
+ rkind_numbers(ir) = last
+ ENDIF
+ last = j
+ IF(j .EQ. -1) EXIT
+ ENDIF
+ ENDDO
+
+! Generate program information:
+
+WRITE(*,'(40(A,/))') &
+'!****h* ROBODoc/H5fortran_detect.f90',&
+'!',&
+'! NAME',&
+'! H5fortran_detect',&
+'! ',&
+'! PURPOSE',&
+'! This stand alone program is used at build time to generate the header file',&
+'! 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 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. *',&
+'! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *',&
+'!',&
+'! AUTHOR',&
+'! H5test_kind.f90',&
+'!',&
+'!*****'
+
+! Generate a program
+
+ 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"
+ 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(*,*)" RETURN"
+ WRITE(*,*)"END SUBROUTINE"
+ jr = KIND(1.0)
+ WRITE(*, "("" SUBROUTINE r"", i2.2,""()"")") j
+ 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(*,*)" RETURN"
+ WRITE(*,*)"END SUBROUTINE"
+ jd = KIND(1.d0)
+ WRITE(*, "("" SUBROUTINE d"", i2.2,""()"")") j
+ 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(*,*)" 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(*,*)" RETURN"
+ 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(*,*)" RETURN"
+ WRITE(*,*)" END SUBROUTINE"
+ ENDDO
+END PROGRAM test_kind
+
+
+