!****p* Program/H5_buildiface ! ! NAME ! Executable: H5_buildiface ! ! FILE ! fortran/src/H5_buildiface.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 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 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 ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! 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 ! M. Scot Breitenfeld ! !***** #include PROGRAM test_kind USE, INTRINSIC :: ISO_C_BINDING IMPLICIT NONE ! These values are valid REAL KINDs (with corresponding C float) found during configure H5_H5CONFIG_F_NUM_RKIND H5_H5CONFIG_F_RKIND ! These values are valid INTEGER KINDs (with corresponding C float) found during configure H5_H5CONFIG_F_NUM_IKIND H5_H5CONFIG_F_IKIND INTEGER :: i, j, k INTEGER :: ji, jr, jd #ifdef H5_FORTRAN_HAVE_C_LONG_DOUBLE REAL(KIND=C_LONG_DOUBLE) :: c_longdble #endif REAL(KIND=C_DOUBLE) :: c_dble REAL(KIND=C_FLOAT) :: c_flt INTEGER :: sizeof_var CHARACTER(LEN=2) :: chr2 ! subroutine rank of array being passed in CHARACTER(LEN=2), DIMENSION(1:8), PARAMETER :: chr_rank=(/"_0","_1","_2","_3","_4","_5","_6","_7"/) ! rank definitions CHARACTER(LEN=70), DIMENSION(1:8), PARAMETER :: rank_dim_line=(/ & ' ', & ', DIMENSION(dims(1)) ', & ', DIMENSION(dims(1),dims(2)) ', & ', DIMENSION(dims(1),dims(2),dims(3)) ', & ', DIMENSION(dims(1),dims(2),dims(3),dims(4)) ', & ', DIMENSION(dims(1),dims(2),dims(3),dims(4),dims(5)) ', & ', DIMENSION(dims(1),dims(2),dims(3),dims(4),dims(5),dims(6)) ', & ', DIMENSION(dims(1),dims(2),dims(3),dims(4),dims(5),dims(6),dims(7))' & /) ! pointer to the buffer CHARACTER(LEN=37), DIMENSION(1:8), PARAMETER :: f_ptr_line=(/ & ' f_ptr = C_LOC(buf) ', & ' f_ptr = C_LOC(buf(1)) ', & ' f_ptr = C_LOC(buf(1,1)) ', & ' f_ptr = C_LOC(buf(1,1,1)) ', & ' f_ptr = C_LOC(buf(1,1,1,1)) ', & ' f_ptr = C_LOC(buf(1,1,1,1,1)) ', & ' f_ptr = C_LOC(buf(1,1,1,1,1,1)) ', & ' f_ptr = C_LOC(buf(1,1,1,1,1,1,1))' & /) ! (a) Generate Fortran H5* interfaces having multiple KIND interfaces. ! ! DEVELOPER'S NOTES: ! ! 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 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') WRITE(11,'(40(A,/))') & '!****h* ROBODoc/H5_KINDff.F90',& '!',& '! NAME',& '! H5_KIND',& '! ',& '! PURPOSE',& '! This module is generated at build by H5_buildiface.F90 to handle all the',& '! detected REAL KINDs for APIs being passed REAL KINDs. Currently these ',& '! are H5A, H5D and H5P APIs',& '!',& '! 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',& '! H5_buildiface.F90',& '!',& '!*****' WRITE(11,'(a)') "MODULE H5_KIND" WRITE(11,'(A)') ' USE, INTRINSIC :: ISO_C_BINDING' WRITE(11,'(A)') ' USE H5GLOBAL' WRITE(11,'(A)') ' USE H5A' WRITE(11,'(A)') ' USE H5D' WRITE(11,'(A)') ' USE H5P' WRITE(11,'(A)') ' IMPLICIT NONE' !*************** ! H5A INTERFACES !*************** ! ! H5Awrite_f ! WRITE(11,'(A)') " INTERFACE h5awrite_f" DO i = 1, num_rkinds j = rkind(i) WRITE(chr2,'(I2)') j DO k = 1, 8 WRITE(11,'(A)') " MODULE PROCEDURE h5awrite_kind_"//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(k) ENDDO END DO WRITE(11,'(A)') " END INTERFACE" ! H5Aread_f WRITE(11,'(A)') " INTERFACE h5aread_f" DO i = 1, num_rkinds j = rkind(i) WRITE(chr2,'(I2)') j DO k = 1, 8 WRITE(11,'(A)') " MODULE PROCEDURE h5aread_kind_"//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(k) ENDDO END DO WRITE(11,'(A)') " END INTERFACE" !*************** ! H5D INTERFACES !*************** ! ! H5Dwrite_f WRITE(11,'(A)') " INTERFACE h5dwrite_f" DO i = 1, num_rkinds j = rkind(i) WRITE(chr2,'(I2)') j DO k = 1, 8 WRITE(11,'(A)') " MODULE PROCEDURE h5dwrite_kind_"//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(k) ENDDO END DO WRITE(11,'(A)') " END INTERFACE" ! H5Dread_f WRITE(11,'(A)') " INTERFACE h5dread_f" DO i = 1, num_rkinds j = rkind(i) WRITE(chr2,'(I2)') j DO k = 1, 8 WRITE(11,'(A)') " MODULE PROCEDURE h5dread_kind_"//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(k) ENDDO END DO WRITE(11,'(A)') " END INTERFACE" !*************** ! H5P INTERFACES !*************** ! ! H5Pset_fill_value_f WRITE(11,'(A)') " INTERFACE h5pset_fill_value_f" DO i = 1, num_rkinds j = rkind(i) WRITE(chr2,'(I2)') j WRITE(11,'(A)') " MODULE PROCEDURE h5pset_fill_value_kind_"//TRIM(ADJUSTL(chr2)) END DO WRITE(11,'(A)') " END INTERFACE" ! H5Pget_fill_value_f WRITE(11,'(A)') " INTERFACE h5pget_fill_value_f" DO i = 1, num_rkinds j = rkind(i) WRITE(chr2,'(I2)') j WRITE(11,'(A)') " MODULE PROCEDURE h5pget_fill_value_kind_"//TRIM(ADJUSTL(chr2)) END DO WRITE(11,'(A)') " END INTERFACE" ! H5Pset_f WRITE(11,'(A)') " INTERFACE h5pset_f" DO i = 1, num_rkinds j = rkind(i) WRITE(chr2,'(I2)') j WRITE(11,'(A)') " MODULE PROCEDURE h5pset_kind_"//TRIM(ADJUSTL(chr2)) END DO WRITE(11,'(A)') " END INTERFACE" ! H5Pget_f WRITE(11,'(A)') " INTERFACE h5pget_f" DO i = 1, num_rkinds j = rkind(i) WRITE(chr2,'(I2)') j WRITE(11,'(A)') " MODULE PROCEDURE h5pget_kind_"//TRIM(ADJUSTL(chr2)) END DO WRITE(11,'(A)') " END INTERFACE" ! H5Pregister_f WRITE(11,'(A)') " INTERFACE h5pregister_f" DO i = 1, num_rkinds j = rkind(i) WRITE(chr2,'(I2)') j WRITE(11,'(A)') " MODULE PROCEDURE h5pregister_kind_"//TRIM(ADJUSTL(chr2)) END DO WRITE(11,'(A)') " END INTERFACE" ! H5Pinsert_f WRITE(11,'(A)') " INTERFACE h5pinsert_f" DO i = 1, num_rkinds j = rkind(i) WRITE(chr2,'(I2)') j WRITE(11,'(A)') " MODULE PROCEDURE h5pinsert_kind_"//TRIM(ADJUSTL(chr2)) END DO WRITE(11,'(A)') " END INTERFACE" WRITE(11,'(A)') 'CONTAINS' !********************** ! H5A APIs !********************** ! ! H5Awrite_f DO i = 1, num_rkinds k = rkind(i) WRITE(chr2,'(I2)') k DO j = 1, 8 ! DLL definitions for windows WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_DLL)' WRITE(11,'(A)') '!DEC$attributes dllexport :: h5awrite_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) WRITE(11,'(A)') '!DEC$endif' ! Subroutine API WRITE(11,'(A)') ' SUBROUTINE h5awrite_kind_'//TRIM(ADJUSTL(chr2))& &//'_rank'//chr_rank(j)//'(attr_id, memtype_id, buf, dims, hdferr)' WRITE(11,'(A)') ' IMPLICIT NONE' WRITE(11,'(A)') ' INTEGER(HID_T) , INTENT(IN) :: attr_id' WRITE(11,'(A)') ' INTEGER(HID_T) , INTENT(IN) :: memtype_id' WRITE(11,'(A)') ' INTEGER(HSIZE_T) , INTENT(IN), DIMENSION(*) :: dims' WRITE(11,'(A)') ' REAL(KIND='//TRIM(ADJUSTL(chr2))//'),INTENT(IN)'//TRIM(rank_dim_line(j))//', TARGET :: buf' WRITE(11,'(A)') ' INTEGER , INTENT(OUT) :: hdferr' WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' WRITE(11,'(A)') f_ptr_line(j) WRITE(11,'(A)') ' hdferr = H5Awrite_f_c(attr_id, memtype_id, f_ptr)' WRITE(11,'(A)') ' END SUBROUTINE h5awrite_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) ENDDO ENDDO ! ! H5Aread_f DO i = 1, num_rkinds k = rkind(i) WRITE(chr2,'(I2)') k DO j = 1, 8 ! DLL definitions for windows WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_DLL)' WRITE(11,'(A)') '!DEC$attributes dllexport :: h5aread_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) WRITE(11,'(A)') '!DEC$endif' ! Subroutine API WRITE(11,'(A)') ' SUBROUTINE h5aread_kind_'//TRIM(ADJUSTL(chr2))& &//'_rank'//chr_rank(j)//'(attr_id, memtype_id, buf, dims, hdferr)' WRITE(11,'(A)') ' IMPLICIT NONE' WRITE(11,'(A)') ' INTEGER(HID_T) , INTENT(IN) :: attr_id' WRITE(11,'(A)') ' INTEGER(HID_T) , INTENT(IN) :: memtype_id' WRITE(11,'(A)') ' INTEGER(HSIZE_T) , INTENT(IN), DIMENSION(*) :: dims' WRITE(11,'(A)') ' REAL(KIND='//TRIM(ADJUSTL(chr2))//'),INTENT(INOUT)'//TRIM(rank_dim_line(j))//', TARGET :: buf' WRITE(11,'(A)') ' INTEGER , INTENT(OUT) :: hdferr' WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' WRITE(11,'(A)') f_ptr_line(j) WRITE(11,'(A)') ' hdferr = H5Aread_f_c(attr_id, memtype_id, f_ptr)' WRITE(11,'(A)') ' END SUBROUTINE h5aread_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) ENDDO ENDDO !********************** ! H5D APIs !********************** ! ! h5dread_f DO i = 1, num_rkinds k = rkind(i) WRITE(chr2,'(I2)') k DO j = 1, 8 ! DLL definitions for windows WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_DLL)' WRITE(11,'(A)') '!DEC$attributes dllexport :: h5dread_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) WRITE(11,'(A)') '!DEC$endif' ! Subroutine API WRITE(11,'(A)') ' SUBROUTINE h5dread_kind_'//TRIM(ADJUSTL(chr2))& &//'_rank'//chr_rank(j)//'(dset_id, mem_type_id, buf, dims, hdferr, &' WRITE(11,'(A)') ' mem_space_id, file_space_id, xfer_prp)' WRITE(11,'(A)') ' USE, INTRINSIC :: ISO_C_BINDING' WRITE(11,'(A)') ' IMPLICIT NONE' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: dset_id' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: mem_type_id' WRITE(11,'(A)') ' INTEGER(HSIZE_T), INTENT(IN), DIMENSION(*) :: dims' WRITE(11,'(A)') ' REAL(KIND='//TRIM(ADJUSTL(chr2))//'),INTENT(INOUT)'//TRIM(rank_dim_line(j))//', TARGET :: buf' WRITE(11,'(A)') ' INTEGER, INTENT(OUT) :: hdferr' WRITE(11,'(A)') ' INTEGER(HID_T), OPTIONAL, INTENT(IN) :: mem_space_id' WRITE(11,'(A)') ' INTEGER(HID_T), OPTIONAL, INTENT(IN) :: file_space_id' WRITE(11,'(A)') ' INTEGER(HID_T), OPTIONAL, INTENT(IN) :: xfer_prp' WRITE(11,'(A)') ' INTEGER(HID_T) :: xfer_prp_default' WRITE(11,'(A)') ' INTEGER(HID_T) :: mem_space_id_default' WRITE(11,'(A)') ' INTEGER(HID_T) :: file_space_id_default' WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' WRITE(11,'(A)') ' xfer_prp_default = H5P_DEFAULT_F' WRITE(11,'(A)') ' mem_space_id_default = H5S_ALL_F' WRITE(11,'(A)') ' file_space_id_default = H5S_ALL_F' WRITE(11,'(A)') ' IF(PRESENT(xfer_prp)) xfer_prp_default = xfer_prp' WRITE(11,'(A)') ' IF(PRESENT(mem_space_id)) mem_space_id_default = mem_space_id' WRITE(11,'(A)') ' IF(PRESENT(file_space_id)) file_space_id_default = file_space_id' WRITE(11,'(A)') f_ptr_line(j) WRITE(11,'(A)') ' hdferr = h5dread_f_c(dset_id, mem_type_id, mem_space_id_default, &' WRITE(11,'(A)') ' file_space_id_default, xfer_prp_default, f_ptr)' WRITE(11,'(A)') ' END SUBROUTINE h5dread_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) ENDDO ENDDO ! ! h5dwrite_f DO i = 1, num_rkinds k = rkind(i) WRITE(chr2,'(I2)') k DO j = 1, 8 ! DLL definitions for windows WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_DLL)' WRITE(11,'(A)') '!DEC$attributes dllexport :: h5dwrite_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) WRITE(11,'(A)') '!DEC$endif' ! Subroutine API WRITE(11,'(A)') ' SUBROUTINE h5dwrite_kind_'//TRIM(ADJUSTL(chr2))& &//'_rank'//chr_rank(j)//'(dset_id, mem_type_id, buf, dims, hdferr, &' WRITE(11,'(A)') ' mem_space_id, file_space_id, xfer_prp)' WRITE(11,'(A)') ' USE, INTRINSIC :: ISO_C_BINDING' WRITE(11,'(A)') ' IMPLICIT NONE' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: dset_id' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: mem_type_id' WRITE(11,'(A)') ' INTEGER(HSIZE_T), INTENT(IN), DIMENSION(*) :: dims' WRITE(11,'(A)') ' REAL(KIND='//TRIM(ADJUSTL(chr2))//'),INTENT(IN)'//TRIM(rank_dim_line(j))//', TARGET :: buf' WRITE(11,'(A)') ' INTEGER, INTENT(OUT) :: hdferr' WRITE(11,'(A)') ' INTEGER(HID_T), OPTIONAL, INTENT(IN) :: mem_space_id' WRITE(11,'(A)') ' INTEGER(HID_T), OPTIONAL, INTENT(IN) :: file_space_id' WRITE(11,'(A)') ' INTEGER(HID_T), OPTIONAL, INTENT(IN) :: xfer_prp' WRITE(11,'(A)') ' INTEGER(HID_T) :: xfer_prp_default' WRITE(11,'(A)') ' INTEGER(HID_T) :: mem_space_id_default' WRITE(11,'(A)') ' INTEGER(HID_T) :: file_space_id_default' WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' WRITE(11,'(A)') ' xfer_prp_default = H5P_DEFAULT_F' WRITE(11,'(A)') ' mem_space_id_default = H5S_ALL_F' WRITE(11,'(A)') ' file_space_id_default = H5S_ALL_F' WRITE(11,'(A)') ' IF(PRESENT(xfer_prp)) xfer_prp_default = xfer_prp' WRITE(11,'(A)') ' IF(PRESENT(mem_space_id)) mem_space_id_default = mem_space_id' WRITE(11,'(A)') ' IF(PRESENT(file_space_id)) file_space_id_default = file_space_id' WRITE(11,'(A)') f_ptr_line(j) WRITE(11,'(A)') ' hdferr = h5dwrite_f_c(dset_id, mem_type_id, mem_space_id_default, &' WRITE(11,'(A)') ' file_space_id_default, xfer_prp_default, f_ptr)' WRITE(11,'(A)') ' END SUBROUTINE h5dwrite_kind_'//TRIM(ADJUSTL(chr2))//'_rank'//chr_rank(j) ENDDO ENDDO !********************** ! H5P APIs !********************** ! ! H5Pset_fill_value_f DO i = 1, num_rkinds k = rkind(i) WRITE(chr2,'(I2)') k ! DLL definitions for windows WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_DLL)' WRITE(11,'(A)') '!DEC$attributes dllexport :: h5pset_fill_value_kind_'//TRIM(ADJUSTL(chr2)) WRITE(11,'(A)') '!DEC$endif' ! Subroutine API WRITE(11,'(A)') ' SUBROUTINE h5pset_fill_value_kind_'//TRIM(ADJUSTL(chr2))& &//'(prp_id, type_id, fillvalue, hdferr)' WRITE(11,'(A)') ' IMPLICIT NONE' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: prp_id' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: type_id' WRITE(11,'(A)') ' REAL(KIND='//TRIM(ADJUSTL(chr2))//'), INTENT(IN), TARGET :: fillvalue' WRITE(11,'(A)') ' INTEGER, INTENT(OUT) :: hdferr ' WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr ' WRITE(11,'(A)') ' f_ptr = C_LOC(fillvalue)' WRITE(11,'(A)') ' hdferr = h5pset_fill_value_c(prp_id, type_id, f_ptr)' WRITE(11,'(A)') ' END SUBROUTINE h5pset_fill_value_kind_'//TRIM(ADJUSTL(chr2)) ENDDO ! H5Pget_fill_value_f DO i = 1, num_rkinds k = rkind(i) WRITE(chr2,'(I2)') k ! DLL definitions for windows WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_DLL)' WRITE(11,'(A)') '!DEC$attributes dllexport :: h5pget_fill_value_kind_'//TRIM(ADJUSTL(chr2)) WRITE(11,'(A)') '!DEC$endif' ! Subroutine API WRITE(11,'(A)') ' SUBROUTINE h5pget_fill_value_kind_'//TRIM(ADJUSTL(chr2))& &//'(prp_id, type_id, fillvalue, hdferr)' WRITE(11,'(A)') ' IMPLICIT NONE' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: prp_id' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: type_id' WRITE(11,'(A)') ' REAL(KIND='//TRIM(ADJUSTL(chr2))//'), INTENT(OUT), TARGET :: fillvalue' WRITE(11,'(A)') ' INTEGER, INTENT(OUT) :: hdferr' WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' WRITE(11,'(A)') ' f_ptr = C_LOC(fillvalue)' WRITE(11,'(A)') ' hdferr = h5pget_fill_value_c(prp_id, type_id, f_ptr)' WRITE(11,'(A)') ' END SUBROUTINE h5pget_fill_value_kind_'//TRIM(ADJUSTL(chr2)) ENDDO ! H5Pset_f DO i = 1, num_rkinds k = rkind(i) WRITE(chr2,'(I2)') k ! DLL definitions for windows WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_DLL)' WRITE(11,'(A)') '!DEC$attributes dllexport :: h5pset_kind_'//TRIM(ADJUSTL(chr2)) WRITE(11,'(A)') '!DEC$endif' ! Subroutine API WRITE(11,'(A)') ' SUBROUTINE h5pset_kind_'//TRIM(ADJUSTL(chr2))& &//'(prp_id, name, value, hdferr)' WRITE(11,'(A)') ' IMPLICIT NONE' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: prp_id' WRITE(11,'(A)') ' CHARACTER(KIND=C_CHAR), DIMENSION(*), INTENT(IN) :: name' WRITE(11,'(A)') ' REAL(KIND='//TRIM(ADJUSTL(chr2))//'), INTENT(IN), TARGET :: value' WRITE(11,'(A)') ' INTEGER, INTENT(OUT) :: hdferr' WRITE(11,'(A)') ' INTEGER :: name_len' WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' WRITE(11,'(A)') ' f_ptr = C_LOC(value)' WRITE(11,'(A)') ' name_len = LEN(name)' WRITE(11,'(A)') ' hdferr = h5pget_c(prp_id, name, name_len, f_ptr)' WRITE(11,'(A)') ' END SUBROUTINE h5pset_kind_'//TRIM(ADJUSTL(chr2)) ENDDO ! H5Pget_f DO i = 1, num_rkinds k = rkind(i) WRITE(chr2,'(I2)') k ! DLL definitions for windows WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_DLL)' WRITE(11,'(A)') '!DEC$attributes dllexport :: h5pget_kind_'//TRIM(ADJUSTL(chr2)) WRITE(11,'(A)') '!DEC$endif' ! Subroutine API WRITE(11,'(A)') ' SUBROUTINE h5pget_kind_'//TRIM(ADJUSTL(chr2))& &//'(prp_id, name, value, hdferr)' WRITE(11,'(A)') ' IMPLICIT NONE' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: prp_id' WRITE(11,'(A)') ' CHARACTER(LEN=*), INTENT(IN) :: name' WRITE(11,'(A)') ' REAL(KIND='//TRIM(ADJUSTL(chr2))//'), INTENT(OUT), TARGET :: value' WRITE(11,'(A)') ' INTEGER, INTENT(OUT) :: hdferr' WRITE(11,'(A)') ' INTEGER :: name_len' WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' WRITE(11,'(A)') ' f_ptr = C_LOC(value)' WRITE(11,'(A)') ' name_len = LEN(name)' WRITE(11,'(A)') ' hdferr = h5pget_c(prp_id, name, name_len, f_ptr)' WRITE(11,'(A)') ' END SUBROUTINE h5pget_kind_'//TRIM(ADJUSTL(chr2)) ENDDO ! H5Pregister_f DO i = 1, num_rkinds k = rkind(i) WRITE(chr2,'(I2)') k ! DLL definitions for windows WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_DLL)' WRITE(11,'(A)') '!DEC$attributes dllexport :: h5pregister_kind_'//TRIM(ADJUSTL(chr2)) WRITE(11,'(A)') '!DEC$endif' ! Subroutine API WRITE(11,'(A)') 'SUBROUTINE h5pregister_kind_'//TRIM(ADJUSTL(chr2))& &//'(class, name, size, value, hdferr)' WRITE(11,'(A)') ' IMPLICIT NONE' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: class' WRITE(11,'(A)') ' CHARACTER(LEN=*), INTENT(IN) :: name' WRITE(11,'(A)') ' INTEGER(SIZE_T), INTENT(IN) :: size' WRITE(11,'(A)') ' REAL(KIND='//TRIM(ADJUSTL(chr2))//'), INTENT(IN), TARGET :: value' WRITE(11,'(A)') ' INTEGER, INTENT(OUT) :: hdferr' WRITE(11,'(A)') ' INTEGER :: name_len' WRITE(11,'(A)') ' TYPE(C_PTR) :: f_ptr' WRITE(11,'(A)') ' f_ptr = C_LOC(value)' WRITE(11,'(A)') ' name_len = LEN(name)' WRITE(11,'(A)') ' hdferr = h5pregister_c(class, name, name_len, size, f_ptr)' WRITE(11,'(A)') 'END SUBROUTINE h5pregister_kind_'//TRIM(ADJUSTL(chr2)) ENDDO ! H5Pinsert_f DO i = 1, num_rkinds k = rkind(i) WRITE(chr2,'(I2)') k ! DLL definitions for windows WRITE(11,'(A)') '!DEC$if defined(BUILD_HDF5_DLL)' WRITE(11,'(A)') '!DEC$attributes dllexport :: h5pinsert_kind_'//TRIM(ADJUSTL(chr2)) WRITE(11,'(A)') '!DEC$endif' ! Subroutine API WRITE(11,'(A)') ' SUBROUTINE h5pinsert_kind_'//TRIM(ADJUSTL(chr2))& &//'(plist, name, size, value, hdferr)' WRITE(11,'(A)') ' IMPLICIT NONE' WRITE(11,'(A)') ' INTEGER(HID_T), INTENT(IN) :: plist' WRITE(11,'(A)') ' CHARACTER(LEN=*), INTENT(IN) :: name' WRITE(11,'(A)') ' INTEGER(SIZE_T), INTENT(IN) :: size' WRITE(11,'(A)') ' REAL(KIND='//TRIM(ADJUSTL(chr2))//'), INTENT(IN), TARGET :: value' WRITE(11,'(A)') ' INTEGER, INTENT(OUT) :: hdferr' WRITE(11,'(A)') ' INTEGER :: name_len' WRITE(11,'(A)') ' TYPE(c_ptr) :: f_ptr' WRITE(11,'(A)') ' f_ptr = c_loc(value)' WRITE(11,'(A)') ' name_len = LEN(name)' WRITE(11,'(A)') ' hdferr = h5pinsert_c(plist, name , name_len, size, f_ptr)' WRITE(11,'(A)') ' END SUBROUTINE h5pinsert_kind_'//TRIM(ADJUSTL(chr2)) ENDDO 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 H5_buildiface.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',& '! H5_buildiface.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, num_rkinds j = rkind(i) WRITE(chr2,'(I2)') j WRITE(11,'(A)') " MODULE PROCEDURE verify_real_kind_"//TRIM(ADJUSTL(chr2)) END DO DO i = 1, num_ikinds j = ikind(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, num_rkinds j = rkind(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, num_ikinds k = ikind(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, num_rkinds k = rkind(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