mirror of
https://github.com/HDFGroup/hdf5.git
synced 2025-02-17 16:10:24 +08:00
Added new H5E with tests. (#4049)
Added Fortran H5E APIs: h5eregister_class_f, h5eunregister_class_f, h5ecreate_msg_f, h5eclose_msg_f h5eget_msg_f, h5epush_f, h5eget_num_f, h5ewalk_f, h5eget_class_name_f, h5eappend_stack_f, h5eget_current_stack_f, h5eset_current_stack_f, h5ecreate_stack_f, h5eclose_stack_f, h5epop_f, h5eprint_f (C h5eprint v2 signature) Addresses Issue #3987
This commit is contained in:
Scot Breitenfeld
GitHub
parent
fe5d0d5c53
commit
9d8e882496
@ -16,8 +16,8 @@ HDF5 version 1.15.0 currently under development
|
||||
*Please refer to the release_docs/INSTALL file for installation instructions.*
|
||||
|
||||
This repository contains a high-performance library's source code and a file format
|
||||
specification that implement the HDF5® data model. The model has been adopted across
|
||||
many industries and this implementation has become a de facto data management standard
|
||||
specification that implements the HDF5® data model. The model has been adopted across
|
||||
many industries, and this implementation has become a de facto data management standard
|
||||
in science, engineering, and research communities worldwide.
|
||||
|
||||
The HDF Group is the developer, maintainer, and steward of HDF5 software. Find more
|
||||
|
||||
@ -68,6 +68,9 @@
|
||||
/* Define if we have Fortran intrinsic STORAGE_SIZE */
|
||||
#cmakedefine H5_FORTRAN_HAVE_STORAGE_SIZE @H5_FORTRAN_HAVE_STORAGE_SIZE@
|
||||
|
||||
/* Define if Fortran supports allocatable character */
|
||||
#cmakedefine H5_FORTRAN_HAVE_CHAR_ALLOC @H5_FORTRAN_HAVE_CHAR_ALLOC@
|
||||
|
||||
/* Determine the size of C long double */
|
||||
#cmakedefine H5_FORTRAN_SIZEOF_LONG_DOUBLE @H5_FORTRAN_SIZEOF_LONG_DOUBLE@
|
||||
|
||||
|
||||
@ -124,6 +124,15 @@ else ()
|
||||
message (FATAL_ERROR "Fortran compiler requires either intrinsic functions SIZEOF or STORAGE_SIZE")
|
||||
endif ()
|
||||
|
||||
# Check to see of Fortran supports allocatable character
|
||||
READ_SOURCE("PROGRAM PROG_CHAR_ALLOC" "END PROGRAM PROG_CHAR_ALLOC" SOURCE_CODE)
|
||||
check_fortran_source_compiles (${SOURCE_CODE} FORTRAN_CHAR_ALLOC SRC_EXT f90)
|
||||
if (${FORTRAN_CHAR_ALLOC})
|
||||
set (${HDF_PREFIX}_FORTRAN_HAVE_CHAR_ALLOC 1)
|
||||
else ()
|
||||
set (${HDF_PREFIX}_FORTRAN_HAVE_CHAR_ALLOC 0)
|
||||
endif ()
|
||||
|
||||
#-----------------------------------------------------------------------------
|
||||
# Determine the available KINDs for REALs and INTEGERs
|
||||
#-----------------------------------------------------------------------------
|
||||
|
||||
@ -78,6 +78,13 @@ set (STORAGE_SIZE_CODE
|
||||
END PROGRAM
|
||||
"
|
||||
)
|
||||
set (CHAR_ALLOC
|
||||
"
|
||||
PROGRAM main
|
||||
CHARACTER(:), ALLOCATABLE :: str
|
||||
END PROGRAM
|
||||
"
|
||||
)
|
||||
set (ISO_FORTRAN_ENV_CODE
|
||||
"
|
||||
PROGRAM main
|
||||
@ -132,6 +139,7 @@ check_fortran_source_compiles (${STORAGE_SIZE_CODE} ${HDF_PREFIX}_FORTRAN_HAVE_S
|
||||
check_fortran_source_compiles (${ISO_FORTRAN_ENV_CODE} ${HDF_PREFIX}_HAVE_ISO_FORTRAN_ENV SRC_EXT f90)
|
||||
check_fortran_source_compiles (${REALISNOTDOUBLE_CODE} ${HDF_PREFIX}_FORTRAN_DEFAULT_REAL_NOT_DOUBLE SRC_EXT f90)
|
||||
check_fortran_source_compiles (${ISO_C_BINDING_CODE} ${HDF_PREFIX}_FORTRAN_HAVE_ISO_C_BINDING SRC_EXT f90)
|
||||
check_fortran_source_compiles (${CHAR_ALLOC} ${HDF_PREFIX}_FORTRAN_HAVE_CHAR_ALLOC SRC_EXT f90)
|
||||
|
||||
#-----------------------------------------------------------------------------
|
||||
# Add debug information (intel Fortran : JB)
|
||||
|
||||
@ -652,6 +652,8 @@ if test "X$HDF_FORTRAN" = "Xyes"; then
|
||||
if test "X$HAVE_F2003_REQUIREMENTS" = "Xno"; then
|
||||
AC_MSG_ERROR([Fortran compiler lacks required Fortran 2003 features; unsupported Fortran 2003 compiler, remove --enable-fortran])
|
||||
fi
|
||||
## Checking if the compiler supports fortran character being allocatable
|
||||
PAC_HAVE_CHAR_ALLOC
|
||||
|
||||
## --------------------------------------------------------------------
|
||||
## Define wrappers for the C compiler to use Fortran function names
|
||||
@ -741,6 +743,10 @@ if test "X$HDF_FORTRAN" = "Xyes"; then
|
||||
AC_DEFINE([FORTRAN_HAVE_SIZEOF], [1], [Define if we have Fortran intrinsic SIZEOF])
|
||||
fi
|
||||
|
||||
if test "X$HAVE_CHAR_ALLOC_FORTRAN" = "Xyes"; then
|
||||
AC_DEFINE([FORTRAN_HAVE_CHAR_ALLOC], [1], [Define if Fortran supports allocatable character])
|
||||
fi
|
||||
|
||||
## See if C_LONG_DOUBLE is available
|
||||
PAC_PROG_FC_HAVE_C_LONG_DOUBLE
|
||||
|
||||
|
||||
@ -6,6 +6,9 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
#define RESET "\x1b[0m"
|
||||
#define RED "\x1b[31m"
|
||||
|
||||
int
|
||||
main(void)
|
||||
{
|
||||
@ -34,8 +37,8 @@ main(void)
|
||||
}
|
||||
|
||||
// push a custom error message onto the default stack
|
||||
if (H5Epush2(H5E_DEFAULT, __FILE__, __FUNCTION__, __LINE__, cls, major, minor, "Hello, Error!\n") <
|
||||
0) {
|
||||
if (H5Epush2(H5E_DEFAULT, __FILE__, __FUNCTION__, __LINE__, cls, major, minor, "%s Hello, error %s\n",
|
||||
RED, RESET) < 0) {
|
||||
ret_val = EXIT_FAILURE;
|
||||
goto fail_push;
|
||||
}
|
||||
|
||||
@ -63,6 +63,11 @@ if (H5_FORTRAN_HAVE_C_SIZEOF)
|
||||
set (CMAKE_H5_FORTRAN_HAVE_C_SIZEOF 1)
|
||||
endif ()
|
||||
|
||||
set (CMAKE_H5_FORTRAN_HAVE_CHAR_ALLOC 0)
|
||||
if (H5_FORTRAN_HAVE_CHAR_ALLOC)
|
||||
set (CMAKE_H5_FORTRAN_HAVE_CHAR_ALLOC 1)
|
||||
endif ()
|
||||
|
||||
configure_file (${HDF5_F90_SRC_SOURCE_DIR}/H5config_f.inc.cmake ${HDF5_F90_BINARY_DIR}/H5config_f.inc @ONLY)
|
||||
configure_file (${HDF5_F90_SRC_SOURCE_DIR}/H5fort_type_defines.h.cmake ${HDF5_F90_BINARY_DIR}/H5fort_type_defines.h @ONLY)
|
||||
|
||||
|
||||
@ -591,8 +591,8 @@ CONTAINS
|
||||
INTEGER, INTENT(OUT) :: hdferr
|
||||
|
||||
INTERFACE
|
||||
INTEGER FUNCTION H5Aclose(attr_id) BIND(C, NAME='H5Aclose')
|
||||
IMPORT :: HID_T
|
||||
INTEGER(C_INT) FUNCTION H5Aclose(attr_id) BIND(C, NAME='H5Aclose')
|
||||
IMPORT :: HID_T, C_INT
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), INTENT(IN), VALUE :: attr_id
|
||||
END FUNCTION H5Aclose
|
||||
|
||||
@ -20,43 +20,15 @@
|
||||
#include "H5f90.h"
|
||||
#include "H5Eprivate.h"
|
||||
|
||||
/****if* H5Ef/h5eclear_c
|
||||
/****if* H5Ef/h5eprint_c
|
||||
* NAME
|
||||
* h5eclear_c
|
||||
* PURPOSE
|
||||
* Call H5Eclear to clear the error stack for the current thread
|
||||
* INPUTS
|
||||
*
|
||||
* OUTPUTS
|
||||
*
|
||||
* RETURNS
|
||||
* 0 on success, -1 on failure
|
||||
* SOURCE
|
||||
*/
|
||||
int_f
|
||||
h5eclear_c(hid_t_f *estack_id)
|
||||
/******/
|
||||
{
|
||||
int_f ret_value = 0;
|
||||
|
||||
/*
|
||||
* Call H5Eclear function.
|
||||
*/
|
||||
if (H5Eclear2((hid_t)*estack_id) < 0)
|
||||
HGOTO_DONE(FAIL);
|
||||
|
||||
done:
|
||||
return ret_value;
|
||||
}
|
||||
|
||||
/****if* H5Ef/h5eprint_c1
|
||||
* NAME
|
||||
* h5eprint_c1
|
||||
* h5eprint_c
|
||||
* PURPOSE
|
||||
* Call H5Eprint to print the error stack in a default manner.
|
||||
* INPUTS
|
||||
* name - file name
|
||||
* namelen - length of name
|
||||
* err_stack - error stack identifier
|
||||
* name - file name
|
||||
* namelen - length of name
|
||||
* OUTPUTS
|
||||
*
|
||||
* RETURNS
|
||||
@ -64,22 +36,24 @@ done:
|
||||
* SOURCE
|
||||
*/
|
||||
int_f
|
||||
h5eprint_c1(_fcd name, int_f *namelen)
|
||||
h5eprint_c(hid_t_f *err_stack, _fcd name, size_t_f *namelen)
|
||||
/******/
|
||||
{
|
||||
FILE *file = NULL;
|
||||
char *c_name = NULL;
|
||||
int_f ret_value = 0;
|
||||
|
||||
if (NULL == (c_name = (char *)HD5f2cstring(name, (size_t)*namelen)))
|
||||
HGOTO_DONE(FAIL);
|
||||
if (NULL == (file = fopen(c_name, "a")))
|
||||
HGOTO_DONE(FAIL);
|
||||
if (namelen) {
|
||||
if (NULL == (c_name = (char *)HD5f2cstring(name, (size_t)*namelen)))
|
||||
HGOTO_DONE(FAIL);
|
||||
if (NULL == (file = fopen(c_name, "a")))
|
||||
HGOTO_DONE(FAIL);
|
||||
}
|
||||
|
||||
/*
|
||||
* Call H5Eprint2 function.
|
||||
*/
|
||||
if (H5Eprint2(H5E_DEFAULT, file) < 0)
|
||||
if (H5Eprint2((hid_t)*err_stack, file) < 0)
|
||||
HGOTO_DONE(FAIL);
|
||||
|
||||
done:
|
||||
@ -91,122 +65,6 @@ done:
|
||||
return ret_value;
|
||||
}
|
||||
|
||||
/****if* H5Ef/h5eprint_c2
|
||||
* NAME
|
||||
* h5eprint_c2
|
||||
* PURPOSE
|
||||
* Call H5Eprint to print the error stack to stderr
|
||||
* in a default manner.
|
||||
* INPUTS
|
||||
*
|
||||
* OUTPUTS
|
||||
*
|
||||
* RETURNS
|
||||
* 0 on success, -1 on failure
|
||||
* SOURCE
|
||||
*/
|
||||
int_f
|
||||
h5eprint_c2(void)
|
||||
/******/
|
||||
{
|
||||
int_f ret_value = 0;
|
||||
|
||||
/*
|
||||
* Call H5Eprint2 function.
|
||||
*/
|
||||
if (H5Eprint2(H5E_DEFAULT, NULL) < 0)
|
||||
HGOTO_DONE(FAIL);
|
||||
|
||||
done:
|
||||
return ret_value;
|
||||
}
|
||||
|
||||
/****if* H5Ef/h5eget_major_c
|
||||
* NAME
|
||||
* h5eget_major_c
|
||||
* PURPOSE
|
||||
* Get a character string describing an error specified by a
|
||||
* major error number.
|
||||
* INPUTS
|
||||
* error_no - Major error number
|
||||
* OUTPUTS
|
||||
* name - character string describing the error
|
||||
* RETURNS
|
||||
* 0 on success, -1 on failure
|
||||
* SOURCE
|
||||
*/
|
||||
int_f
|
||||
h5eget_major_c(int_f *error_no, _fcd name, size_t_f *namelen)
|
||||
/******/
|
||||
{
|
||||
char *c_name = NULL;
|
||||
size_t c_namelen = (size_t)*namelen;
|
||||
int_f ret_value = 0;
|
||||
|
||||
if (c_namelen > 0)
|
||||
c_name = (char *)malloc(c_namelen + 1);
|
||||
|
||||
if (!c_name)
|
||||
HGOTO_DONE(FAIL);
|
||||
|
||||
/*
|
||||
* Call H5Eget_msg function.
|
||||
*/
|
||||
H5Eget_msg((hid_t)*error_no, NULL, c_name, c_namelen);
|
||||
HD5packFstring((char *)c_name, _fcdtocp(name), c_namelen);
|
||||
if (!strcmp(c_name, "Invalid major error number"))
|
||||
HGOTO_DONE(FAIL);
|
||||
|
||||
done:
|
||||
if (c_name)
|
||||
free(c_name);
|
||||
|
||||
return ret_value;
|
||||
}
|
||||
|
||||
/****if* H5Ef/h5eget_minor_c
|
||||
* NAME
|
||||
* h5eget_minor_c
|
||||
* PURPOSE
|
||||
* Get a character string describing an error specified by a
|
||||
* minor error number.
|
||||
* INPUTS
|
||||
* error_no - Major error number
|
||||
* OUTPUTS
|
||||
* name - character string describing the error
|
||||
* RETURNS
|
||||
* 0 on success, -1 on failure
|
||||
* SOURCE
|
||||
*/
|
||||
int_f
|
||||
h5eget_minor_c(int_f *error_no, _fcd name, size_t_f *namelen)
|
||||
/******/
|
||||
{
|
||||
char *c_name = NULL;
|
||||
size_t c_namelen = (size_t)*namelen;
|
||||
int_f ret_value = 0;
|
||||
|
||||
if (c_namelen > 0)
|
||||
c_name = (char *)malloc(c_namelen + 1);
|
||||
|
||||
if (!c_name)
|
||||
HGOTO_DONE(FAIL);
|
||||
|
||||
/*
|
||||
* Call H5Eget_msg function.
|
||||
*/
|
||||
H5Eget_msg((hid_t)*error_no, NULL, c_name, c_namelen);
|
||||
HD5packFstring((char *)c_name, _fcdtocp(name), c_namelen);
|
||||
if (!strcmp(c_name, "Invalid minor error number"))
|
||||
HGOTO_DONE(FAIL);
|
||||
|
||||
done:
|
||||
if (c_name)
|
||||
free(c_name);
|
||||
|
||||
return ret_value;
|
||||
}
|
||||
|
||||
/****if* H5Ef/h5eset_auto2_c
|
||||
* NAME
|
||||
* h5eset_auto2_c
|
||||
@ -221,18 +79,6 @@ done:
|
||||
* 0 on success, -1 on failure
|
||||
* SOURCE
|
||||
*/
|
||||
/* int_f */
|
||||
/* h5eset_auto2_c(hid_t_f *estack_id, H5E_auto2_t *func, void *client_data) */
|
||||
/* /\******\/ */
|
||||
/* { */
|
||||
/* int ret_val = -1; */
|
||||
/* herr_t status = -1; */
|
||||
|
||||
/* status = H5Eset_auto2((hid_t)*estack_id, *func, client_data); */
|
||||
/* if (status >= 0) ret_val = 0; */
|
||||
/* return ret_val; */
|
||||
/* } */
|
||||
|
||||
int_f
|
||||
h5eset_auto2_c(int_f *printflag, hid_t_f *estack_id, H5E_auto2_t func, void *client_data)
|
||||
/******/
|
||||
@ -251,3 +97,34 @@ h5eset_auto2_c(int_f *printflag, hid_t_f *estack_id, H5E_auto2_t func, void *cli
|
||||
|
||||
return ret_val;
|
||||
}
|
||||
|
||||
int_f
|
||||
h5epush_c(hid_t_f *err_stack, hid_t_f *cls_id, hid_t_f *maj_id, hid_t_f *min_id, _fcd msg, size_t_f *msg_len,
|
||||
char *file, char *func, int *line, const char *arg1, const char *arg2, const char *arg3,
|
||||
const char *arg4, const char *arg5, const char *arg6, const char *arg7, const char *arg8,
|
||||
const char *arg9, const char *arg10, const char *arg11, const char *arg12, const char *arg13,
|
||||
const char *arg14, const char *arg15, const char *arg16, const char *arg17, const char *arg18,
|
||||
const char *arg19, const char *arg20)
|
||||
/******/
|
||||
{
|
||||
|
||||
char *c_msg = NULL; /* Buffer to hold C string */
|
||||
int_f ret_value = 0; /* Return value */
|
||||
|
||||
/*
|
||||
* Convert FORTRAN name to C name
|
||||
*/
|
||||
|
||||
if (NULL == (c_msg = HD5f2cstring(msg, (size_t)*msg_len)))
|
||||
HGOTO_DONE(FAIL);
|
||||
|
||||
if (H5Epush2((hid_t)*err_stack, file, func, (unsigned int)*line, (hid_t)*cls_id, (hid_t)*maj_id,
|
||||
(hid_t)*min_id, c_msg, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11,
|
||||
arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19, arg20) < 0)
|
||||
HGOTO_DONE(FAIL);
|
||||
|
||||
done:
|
||||
if (c_msg)
|
||||
free(c_msg);
|
||||
return ret_value;
|
||||
}
|
||||
|
||||
@ -34,15 +34,43 @@
|
||||
! to the Windows dll file 'hdf5_fortrandll.def.in' in the fortran/src directory.
|
||||
! This is needed for Windows based operating systems.
|
||||
!
|
||||
! MISSING: H5Eauto_is_v2, H5Eget_auto2
|
||||
|
||||
MODULE H5E
|
||||
|
||||
USE H5GLOBAL
|
||||
USE H5fortkit
|
||||
IMPLICIT NONE
|
||||
|
||||
INTEGER, PARAMETER :: PRINTON = 1 !< Turn on automatic printing of errors
|
||||
INTEGER, PARAMETER :: PRINTOFF = 0 !< Turn off automatic printing of errors
|
||||
|
||||
!> @brief h5e_error_t derived type
|
||||
TYPE, BIND(C) :: h5e_error_t
|
||||
INTEGER(HID_T) :: cls_id !< Class ID
|
||||
INTEGER(HID_T) :: maj_num !< Major error ID
|
||||
INTEGER(HID_T) :: min_num !< Minor error number
|
||||
INTEGER(C_INT) :: line !< Line in file where error occurs
|
||||
TYPE(C_PTR) :: func_name !< Function in which error occurred
|
||||
TYPE(C_PTR) :: file_name !< File in which error occurred
|
||||
TYPE(C_PTR) :: desc !< Optional supplied description
|
||||
END TYPE h5e_error_t
|
||||
|
||||
INTERFACE h5eprint_f
|
||||
MODULE PROCEDURE h5eprint1_f
|
||||
MODULE PROCEDURE h5eprint2_f
|
||||
END INTERFACE h5eprint_f
|
||||
|
||||
INTERFACE
|
||||
INTEGER FUNCTION h5eprint_c(err_stack, name, namelen) BIND(C,NAME='h5eprint_c')
|
||||
IMPORT :: C_CHAR, HID_T, C_PTR
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T) :: err_stack
|
||||
CHARACTER(KIND=C_CHAR), DIMENSION(*) :: name
|
||||
TYPE(C_PTR), VALUE :: namelen
|
||||
END FUNCTION h5eprint_c
|
||||
END INTERFACE
|
||||
|
||||
CONTAINS
|
||||
|
||||
!>
|
||||
@ -62,19 +90,20 @@ CONTAINS
|
||||
INTEGER(HID_T) :: estack_id_default
|
||||
|
||||
INTERFACE
|
||||
INTEGER FUNCTION h5eclear_c(estack_id_default) BIND(C,NAME='h5eclear_c')
|
||||
IMPORT :: HID_T
|
||||
INTEGER(C_INT) FUNCTION H5Eclear(err_stack) BIND(C,NAME='H5Eclear2')
|
||||
IMPORT :: C_INT, HID_T
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T) :: estack_id_default
|
||||
END FUNCTION h5eclear_c
|
||||
INTEGER(HID_T), VALUE :: err_stack
|
||||
END FUNCTION H5Eclear
|
||||
END INTERFACE
|
||||
|
||||
estack_id_default = H5E_DEFAULT_F
|
||||
IF(PRESENT(estack_id)) estack_id_default = estack_id
|
||||
|
||||
hdferr = h5eclear_c(estack_id_default)
|
||||
hdferr = INT(H5Eclear(estack_id_default))
|
||||
END SUBROUTINE h5eclear_f
|
||||
|
||||
#ifdef H5_DOXYGEN
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
@ -83,34 +112,66 @@ CONTAINS
|
||||
!! \param hdferr \fortran_error
|
||||
!! \param name Name of the file that contains print output
|
||||
!!
|
||||
!! See C API: @ref H5Eprint2()
|
||||
!! \note If \p name is not specified, the output will be sent to
|
||||
!! the standard error (stderr).
|
||||
!!
|
||||
!! \attention Deprecated.
|
||||
!!
|
||||
!! See C API: @ref H5Eprint1()
|
||||
!!
|
||||
SUBROUTINE h5eprint_f(hdferr, name)
|
||||
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name
|
||||
INTEGER, INTENT(OUT) :: hdferr
|
||||
INTEGER :: namelen
|
||||
END SUBROUTINE h5eprint_f
|
||||
|
||||
INTERFACE
|
||||
INTEGER FUNCTION h5eprint_c1(name, namelen) BIND(C,NAME='h5eprint_c1')
|
||||
IMPORT :: C_CHAR
|
||||
IMPLICIT NONE
|
||||
INTEGER :: namelen
|
||||
CHARACTER(KIND=C_CHAR), DIMENSION(*), INTENT(IN) :: name
|
||||
END FUNCTION h5eprint_c1
|
||||
END INTERFACE
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Prints the error stack in a default manner.
|
||||
!!
|
||||
!! \param err_stack Error stack identifier
|
||||
!! \param hdferr \fortran_error
|
||||
!! \param name Name of the file that contains print output
|
||||
!!
|
||||
!! \note If \p name is not specified, the output will be sent to
|
||||
!! the standard error (stderr).
|
||||
!!
|
||||
!! See C API: @ref H5Eprint2()
|
||||
!!
|
||||
SUBROUTINE h5eprint_f(err_stack, hdferr, name)
|
||||
INTEGER(HID_T) , INTENT(IN) :: err_stack
|
||||
INTEGER , INTENT(OUT) :: hdferr
|
||||
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name
|
||||
END SUBROUTINE h5eprint_f
|
||||
|
||||
INTERFACE
|
||||
INTEGER FUNCTION h5eprint_c2() BIND(C,NAME='h5eprint_c2')
|
||||
END FUNCTION h5eprint_c2
|
||||
END INTERFACE
|
||||
#else
|
||||
|
||||
SUBROUTINE h5eprint1_f(hdferr, name)
|
||||
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name
|
||||
INTEGER, INTENT(OUT) :: hdferr
|
||||
|
||||
CALL h5eprint2_f(H5E_DEFAULT_F, hdferr, name)
|
||||
|
||||
END SUBROUTINE h5eprint1_f
|
||||
|
||||
SUBROUTINE h5eprint2_f(err_stack, hdferr, name)
|
||||
INTEGER(HID_T), INTENT(IN) :: err_stack
|
||||
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: name
|
||||
INTEGER, INTENT(OUT) :: hdferr
|
||||
|
||||
INTEGER(SIZE_T), TARGET :: namelen
|
||||
TYPE(C_PTR) :: c_namelen
|
||||
|
||||
IF (PRESENT(name)) THEN
|
||||
namelen = LEN(NAME)
|
||||
hdferr = h5eprint_c1(name, namelen)
|
||||
namelen = LEN(NAME, SIZE_T)
|
||||
c_namelen = C_LOC(namelen)
|
||||
hdferr = h5eprint_c(err_stack, name, c_namelen)
|
||||
ELSE
|
||||
hdferr = h5eprint_c2()
|
||||
hdferr = h5eprint_c(err_stack, C_NULL_CHAR, C_NULL_PTR)
|
||||
ENDIF
|
||||
END SUBROUTINE h5eprint_f
|
||||
END SUBROUTINE h5eprint2_f
|
||||
|
||||
#endif
|
||||
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
@ -121,25 +182,23 @@ CONTAINS
|
||||
!! \param namelen Number of characters in the name buffer.
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! \attention Deprecated: use H5Eget_msg_f() instead.
|
||||
!!
|
||||
!! See C API: @ref H5Eget_major()
|
||||
!!
|
||||
SUBROUTINE h5eget_major_f(error_no, name, namelen, hdferr)
|
||||
INTEGER, INTENT(IN) :: error_no
|
||||
CHARACTER(LEN=*), INTENT(OUT) :: name
|
||||
INTEGER(SIZE_T), INTENT(IN) :: namelen
|
||||
INTEGER(HID_T) , INTENT(IN) :: error_no
|
||||
CHARACTER(LEN=*), INTENT(OUT) :: name
|
||||
INTEGER(SIZE_T) , INTENT(INOUT) :: namelen
|
||||
INTEGER, INTENT(OUT) :: hdferr
|
||||
INTERFACE
|
||||
INTEGER FUNCTION h5eget_major_c(error_no, name, namelen) BIND(C,NAME='h5eget_major_c')
|
||||
IMPORT :: C_CHAR
|
||||
IMPORT :: SIZE_T
|
||||
IMPLICIT NONE
|
||||
INTEGER :: error_no
|
||||
CHARACTER(KIND=C_CHAR), DIMENSION(*) :: name
|
||||
INTEGER(SIZE_T), INTENT(IN) :: namelen
|
||||
END FUNCTION h5eget_major_c
|
||||
END INTERFACE
|
||||
|
||||
hdferr = h5eget_major_c(error_no, name, namelen)
|
||||
INTEGER :: msg_type
|
||||
INTEGER(SIZE_T) :: namelen2
|
||||
|
||||
namelen2 = namelen
|
||||
|
||||
CALL H5Eget_msg_f(error_no, msg_type, name, hdferr, namelen2)
|
||||
|
||||
END SUBROUTINE h5eget_major_f
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
@ -150,23 +209,20 @@ CONTAINS
|
||||
!! \param name Character string describing the error.
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! \attention Deprecated: use H5Eget_msg_f() instead.
|
||||
!!
|
||||
!! See C API: @ref H5Eget_minor()
|
||||
!!
|
||||
SUBROUTINE h5eget_minor_f(error_no, name, hdferr)
|
||||
INTEGER, INTENT(IN) :: error_no
|
||||
INTEGER(HID_T) , INTENT(IN) :: error_no
|
||||
CHARACTER(LEN=*), INTENT(OUT) :: name
|
||||
INTEGER, INTENT(OUT) :: hdferr
|
||||
INTERFACE
|
||||
INTEGER FUNCTION h5eget_minor_c(error_no, name) BIND(C,NAME='h5eget_minor_c')
|
||||
IMPORT :: C_CHAR
|
||||
INTEGER :: error_no
|
||||
CHARACTER(KIND=C_CHAR), DIMENSION(*), INTENT(OUT) :: name
|
||||
END FUNCTION h5eget_minor_c
|
||||
END INTERFACE
|
||||
|
||||
hdferr = h5eget_minor_c(error_no, name)
|
||||
INTEGER :: msg_type
|
||||
|
||||
CALL H5Eget_msg_f(error_no, msg_type, name, hdferr)
|
||||
|
||||
END SUBROUTINE h5eget_minor_f
|
||||
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
@ -214,6 +270,705 @@ CONTAINS
|
||||
|
||||
hdferr = h5eset_auto2_c(printflag, estack_id_default, func_default, client_data_default)
|
||||
END SUBROUTINE h5eset_auto_f
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Pushes a new error record onto an error stack.
|
||||
!!
|
||||
!! \param err_stack Error stack identifier. If the identifier is H5E_DEFAULT_F, the error
|
||||
!! record will be pushed to the current stack.
|
||||
!! \param cls_id Error class identifier
|
||||
!! \param maj_id Major error identifier
|
||||
!! \param min_id Minor error identifier
|
||||
!! \param msg Error description string
|
||||
!! \param hdferr \fortran_error
|
||||
!! \param file Name of the file in which the error was detected
|
||||
!! \param func Name of the function in which the error was detected
|
||||
!! \param line Line number in the file where the error was detected
|
||||
!! \param arg1 C style format control strings
|
||||
!! \param arg2 C style format control strings
|
||||
!! \param arg3 C style format control strings
|
||||
!! \param arg4 C style format control strings
|
||||
!! \param arg5 C style format control strings
|
||||
!! \param arg6 C style format control strings
|
||||
!! \param arg7 C style format control strings
|
||||
!! \param arg8 C style format control strings
|
||||
!! \param arg9 C style format control strings
|
||||
!! \param arg10 C style format control strings
|
||||
!! \param arg11 C style format control strings
|
||||
!! \param arg12 C style format control strings
|
||||
!! \param arg13 C style format control strings
|
||||
!! \param arg14 C style format control strings
|
||||
!! \param arg15 C style format control strings
|
||||
!! \param arg16 C style format control strings
|
||||
!! \param arg17 C style format control strings
|
||||
!! \param arg18 C style format control strings
|
||||
!! \param arg19 C style format control strings
|
||||
!! \param arg20 C style format control strings
|
||||
!!
|
||||
!! \note \p arg[1-20] expects C-style format strings, similar to the
|
||||
!! system and C functions printf() and fprintf().
|
||||
!! Furthermore, special characters, such as ANSI escapes,
|
||||
!! will only be interpreted correctly if the Fortran equivalent
|
||||
!! is used. For example, to print \p msg "TEXT" in red and has
|
||||
!! a space after the text would be:
|
||||
!! <br /><br />
|
||||
!! \code
|
||||
!! (..., "%s TEXT %s"//C_NEW_LINE, hdferr, ..., arg1=ACHAR(27)//"[31m", arg2=ACHAR(27)//"[0m" )
|
||||
!! \endcode
|
||||
!! <br />Using "\n" instead of C_NEW_LINE will not be interpereted correctly, and similarly,
|
||||
!! using "\x1B" instead of ACHAR(27)
|
||||
!!
|
||||
!!
|
||||
!! See C API: @ref H5Epush2()
|
||||
!!
|
||||
SUBROUTINE h5epush_f(err_stack, cls_id, maj_id, min_id, msg, hdferr, &
|
||||
file, func, line, &
|
||||
arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, &
|
||||
arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19, arg20)
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), INTENT(IN) :: err_stack
|
||||
INTEGER(HID_T), INTENT(IN) :: cls_id
|
||||
INTEGER(HID_T), INTENT(IN) :: maj_id
|
||||
INTEGER(HID_T), INTENT(IN) :: min_id
|
||||
CHARACTER(LEN=*), INTENT(IN) :: msg
|
||||
INTEGER, INTENT(OUT) :: hdferr
|
||||
|
||||
TYPE(C_PTR), OPTIONAL :: file
|
||||
TYPE(C_PTR), OPTIONAL :: func
|
||||
TYPE(C_PTR), OPTIONAL :: line
|
||||
CHARACTER(LEN=*), OPTIONAL, TARGET :: arg1, arg2, arg3, arg4, arg5, &
|
||||
arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, &
|
||||
arg16, arg17, arg18, arg19, arg20
|
||||
|
||||
TYPE(C_PTR) :: file_def = C_NULL_PTR
|
||||
TYPE(C_PTR) :: func_def = C_NULL_PTR
|
||||
TYPE(C_PTR) :: line_def = C_NULL_PTR
|
||||
TYPE(C_PTR) :: arg1_def = C_NULL_PTR, arg2_def = C_NULL_PTR, &
|
||||
arg3_def = C_NULL_PTR, arg4_def = C_NULL_PTR, &
|
||||
arg5_def = C_NULL_PTR, arg6_def = C_NULL_PTR, &
|
||||
arg7_def = C_NULL_PTR, arg8_def = C_NULL_PTR, &
|
||||
arg9_def = C_NULL_PTR, arg10_def = C_NULL_PTR, &
|
||||
arg11_def = C_NULL_PTR, arg12_def = C_NULL_PTR, &
|
||||
arg13_def = C_NULL_PTR, arg14_def = C_NULL_PTR, &
|
||||
arg15_def = C_NULL_PTR, arg16_def = C_NULL_PTR, &
|
||||
arg17_def = C_NULL_PTR, arg18_def = C_NULL_PTR, &
|
||||
arg19_def = C_NULL_PTR, arg20_def = C_NULL_PTR
|
||||
|
||||
INTERFACE
|
||||
INTEGER FUNCTION h5epush_c(err_stack, cls_id, maj_id, min_id, msg, msg_len, file, func, line, &
|
||||
arg1, arg2, arg3, arg4, arg5, &
|
||||
arg6, arg7, arg8, arg9, arg10, &
|
||||
arg11, arg12, arg13, arg14, arg15, &
|
||||
arg16, arg17, arg18, arg19, arg20) BIND(C, NAME='h5epush_c')
|
||||
|
||||
IMPORT :: C_CHAR, C_INT, C_PTR
|
||||
IMPORT :: HID_T
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T) :: err_stack
|
||||
INTEGER(HID_T) :: cls_id
|
||||
INTEGER(HID_T) :: maj_id
|
||||
INTEGER(HID_T) :: min_id
|
||||
CHARACTER(KIND=C_CHAR), DIMENSION(*) :: msg
|
||||
INTEGER :: msg_len
|
||||
|
||||
TYPE(C_PTR), VALUE :: file
|
||||
TYPE(C_PTR), VALUE :: func
|
||||
TYPE(C_PTR), VALUE :: line
|
||||
TYPE(C_PTR), VALUE :: arg1, arg2, arg3, arg4, &
|
||||
arg5, arg6, arg7, arg8, &
|
||||
arg9, arg10, arg11, arg12, &
|
||||
arg13, arg14, arg15, arg16, &
|
||||
arg17, arg18, arg19, arg20
|
||||
|
||||
END FUNCTION h5epush_c
|
||||
END INTERFACE
|
||||
|
||||
IF (PRESENT(file)) file_def = file
|
||||
IF (PRESENT(func)) func_def = func
|
||||
IF (PRESENT(line)) line_def = line
|
||||
|
||||
IF (PRESENT(arg1)) arg1_def = C_LOC(arg1)
|
||||
IF (PRESENT(arg2)) arg2_def = C_LOC(arg2)
|
||||
IF (PRESENT(arg3)) arg3_def = C_LOC(arg3)
|
||||
IF (PRESENT(arg4)) arg4_def = C_LOC(arg4)
|
||||
IF (PRESENT(arg5)) arg5_def = C_LOC(arg5)
|
||||
IF (PRESENT(arg6)) arg6_def = C_LOC(arg6)
|
||||
IF (PRESENT(arg7)) arg7_def = C_LOC(arg7)
|
||||
IF (PRESENT(arg8)) arg8_def = C_LOC(arg8)
|
||||
IF (PRESENT(arg9)) arg9_def = C_LOC(arg9)
|
||||
IF (PRESENT(arg10)) arg10_def = C_LOC(arg10)
|
||||
IF (PRESENT(arg11)) arg11_def = C_LOC(arg11)
|
||||
IF (PRESENT(arg12)) arg12_def = C_LOC(arg12)
|
||||
IF (PRESENT(arg13)) arg13_def = C_LOC(arg13)
|
||||
IF (PRESENT(arg14)) arg14_def = C_LOC(arg14)
|
||||
IF (PRESENT(arg15)) arg15_def = C_LOC(arg15)
|
||||
IF (PRESENT(arg16)) arg16_def = C_LOC(arg16)
|
||||
IF (PRESENT(arg17)) arg17_def = C_LOC(arg17)
|
||||
IF (PRESENT(arg18)) arg18_def = C_LOC(arg18)
|
||||
IF (PRESENT(arg19)) arg19_def = C_LOC(arg19)
|
||||
IF (PRESENT(arg20)) arg20_def = C_LOC(arg20)
|
||||
|
||||
hdferr = h5epush_c(err_stack, cls_id, maj_id, min_id, msg, LEN(msg), &
|
||||
file_def, func_def, line_def, &
|
||||
arg1_def, arg2_def, arg3_def, arg4_def, arg5_def, &
|
||||
arg6_def, arg7_def, arg8_def, arg9_def, arg10_def, &
|
||||
arg11_def, arg12_def, arg13_def, arg14_def, arg15_def, &
|
||||
arg16_def, arg17_def, arg18_def, arg19_def, arg20_def)
|
||||
|
||||
END SUBROUTINE h5epush_f
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Registers a client library or application program to the HDF5 error API.
|
||||
!!
|
||||
!! \param cls_name Name of the error class
|
||||
!! \param lib_name Name of the client library or application to which the error class belongs
|
||||
!! \param version Version of the client library or application to which the error class belongs. It can be NULL.
|
||||
!! \param class_id Class identifier
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Eregister_class()
|
||||
!!
|
||||
SUBROUTINE h5eregister_class_f(cls_name, lib_name, version, class_id, hdferr)
|
||||
IMPLICIT NONE
|
||||
CHARACTER(LEN=*), INTENT(IN) :: cls_name
|
||||
CHARACTER(LEN=*), INTENT(IN) :: lib_name
|
||||
CHARACTER(LEN=*), INTENT(IN) :: version
|
||||
INTEGER(HID_T) , INTENT(OUT) :: class_id
|
||||
INTEGER, INTENT(OUT) :: hdferr
|
||||
|
||||
CHARACTER(LEN=LEN_TRIM(cls_name)+1,KIND=C_CHAR) :: c_cls_name
|
||||
CHARACTER(LEN=LEN_TRIM(lib_name)+1,KIND=C_CHAR) :: c_lib_name
|
||||
CHARACTER(LEN=LEN_TRIM(version)+1,KIND=C_CHAR) :: c_version
|
||||
INTERFACE
|
||||
INTEGER(HID_T) FUNCTION H5Eregister_class(cls_name, lib_name, version) &
|
||||
BIND(C,NAME='H5Eregister_class')
|
||||
IMPORT :: C_CHAR
|
||||
IMPORT :: HID_T
|
||||
IMPLICIT NONE
|
||||
CHARACTER(KIND=C_CHAR), DIMENSION(*) :: cls_name
|
||||
CHARACTER(KIND=C_CHAR), DIMENSION(*) :: lib_name
|
||||
CHARACTER(KIND=C_CHAR), DIMENSION(*) :: version
|
||||
|
||||
END FUNCTION H5Eregister_class
|
||||
END INTERFACE
|
||||
|
||||
c_cls_name = TRIM(cls_name)//C_NULL_CHAR
|
||||
c_lib_name = TRIM(lib_name)//C_NULL_CHAR
|
||||
c_version = TRIM(version)//C_NULL_CHAR
|
||||
|
||||
class_id = H5Eregister_class(c_cls_name, c_lib_name, c_version)
|
||||
|
||||
hdferr = 0
|
||||
IF(class_id.LT.0) hdferr = -1
|
||||
|
||||
END SUBROUTINE h5eregister_class_f
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Removes an error class.
|
||||
!!
|
||||
!! \param class_id Class identifier
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Eunregister_class()
|
||||
!!
|
||||
SUBROUTINE h5eunregister_class_f(class_id, hdferr)
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), INTENT(IN) :: class_id
|
||||
INTEGER, INTENT(OUT) :: hdferr
|
||||
|
||||
INTERFACE
|
||||
INTEGER(C_INT) FUNCTION H5Eunregister_class(class_id) BIND(C, NAME='H5Eunregister_class')
|
||||
IMPORT :: HID_T, C_INT
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), INTENT(IN), VALUE :: class_id
|
||||
END FUNCTION H5Eunregister_class
|
||||
END INTERFACE
|
||||
|
||||
hdferr = INT(H5Eunregister_class(class_id))
|
||||
|
||||
END SUBROUTINE h5eunregister_class_f
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Adds a major or minor error message to an error class.
|
||||
!!
|
||||
!! \param class_id An error class identifier
|
||||
!! \param msg_type The type of the error message
|
||||
!! \param msg Error message
|
||||
!! \param err_id Error identifier
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Ecreate_msg()
|
||||
!!
|
||||
SUBROUTINE h5ecreate_msg_f(class_id, msg_type, msg, err_id, hdferr)
|
||||
IMPLICIT NONE
|
||||
|
||||
INTEGER(HID_T) , INTENT(IN) :: class_id
|
||||
INTEGER , INTENT(IN) :: msg_type
|
||||
CHARACTER(LEN=*), INTENT(IN) :: msg
|
||||
INTEGER(HID_T) , INTENT(OUT) :: err_id
|
||||
INTEGER, INTENT(OUT) :: hdferr
|
||||
|
||||
CHARACTER(LEN=LEN_TRIM(msg)+1,KIND=C_CHAR) :: c_msg
|
||||
|
||||
INTERFACE
|
||||
INTEGER(HID_T) FUNCTION H5Ecreate_msg(class_id, msg_type, msg) &
|
||||
BIND(C,NAME='H5Ecreate_msg')
|
||||
IMPORT :: C_CHAR, C_INT
|
||||
IMPORT :: HID_T
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), VALUE :: class_id
|
||||
INTEGER(C_INT), VALUE :: msg_type
|
||||
CHARACTER(KIND=C_CHAR), DIMENSION(*) :: msg
|
||||
END FUNCTION H5Ecreate_msg
|
||||
END INTERFACE
|
||||
|
||||
c_msg = TRIM(msg)//C_NULL_CHAR
|
||||
|
||||
err_id = H5Ecreate_msg(class_id, INT(msg_type, C_INT), c_msg)
|
||||
|
||||
hdferr = 0
|
||||
IF(err_id.LT.0) hdferr = -1
|
||||
|
||||
END SUBROUTINE h5ecreate_msg_f
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Closes an error message.
|
||||
!!
|
||||
!! \param err_id An error message identifier
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Eclose_msg()
|
||||
!!
|
||||
SUBROUTINE h5eclose_msg_f(err_id, hdferr)
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), INTENT(IN) :: err_id
|
||||
INTEGER, INTENT(OUT) :: hdferr
|
||||
|
||||
INTERFACE
|
||||
INTEGER(C_INT) FUNCTION H5Eclose_msg(err_id) BIND(C, NAME='H5Eclose_msg')
|
||||
IMPORT :: HID_T, C_INT
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), VALUE :: err_id
|
||||
END FUNCTION H5Eclose_msg
|
||||
END INTERFACE
|
||||
|
||||
hdferr = INT(H5Eclose_msg(err_id))
|
||||
|
||||
END SUBROUTINE h5eclose_msg_f
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Retrieves an error message.
|
||||
!!
|
||||
!! \param msg_id Error message identifier
|
||||
!! \param msg_type The type of the error message. Valid values are H5E_MAJOR_F and H5E_MINOR_F.
|
||||
!! \param msg Error message buffer
|
||||
!! \param hdferr \fortran_error
|
||||
!! \param msg_size The length of error message to be returned by this function
|
||||
!!
|
||||
!! If \p msg_size is omitted, the API will copy up to the length of \p msg, and it
|
||||
!! is the application's responsibility to provide a large enough buffer. If \p msg_size
|
||||
!! is zero, the required buffer size will be returned, and \p msg is not accessed.
|
||||
!! If \p msg_size is greater than zero, the function will copy up to the length
|
||||
!! of \p msg_size info \p msg.
|
||||
!!
|
||||
!! See C API: @ref H5Eget_msg()
|
||||
!!
|
||||
SUBROUTINE H5Eget_msg_f(msg_id, msg_type, msg, hdferr, msg_size)
|
||||
IMPLICIT NONE
|
||||
|
||||
INTEGER(HID_T) , INTENT(IN) :: msg_id
|
||||
INTEGER , INTENT(OUT) :: msg_type
|
||||
CHARACTER(LEN=*) :: msg
|
||||
INTEGER , INTENT(OUT) :: hdferr
|
||||
INTEGER(SIZE_T) , INTENT(INOUT), OPTIONAL :: msg_size
|
||||
|
||||
CHARACTER(LEN=1,KIND=C_CHAR), DIMENSION(:), ALLOCATABLE, TARGET :: c_msg
|
||||
INTEGER(C_INT) :: c_msg_type
|
||||
TYPE(C_PTR) :: f_ptr
|
||||
INTEGER(SIZE_T) :: msg_cp_sz
|
||||
INTEGER(SIZE_T) :: c_msg_size
|
||||
|
||||
INTERFACE
|
||||
INTEGER(SIZE_T) FUNCTION H5Eget_msg(msg_id, msg_type, msg, size) &
|
||||
BIND(C,NAME='H5Eget_msg')
|
||||
IMPORT :: C_CHAR, C_PTR, C_INT
|
||||
IMPORT :: HID_T, SIZE_T
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), VALUE :: msg_id
|
||||
INTEGER(C_INT) :: msg_type
|
||||
TYPE(C_PTR) , VALUE :: msg
|
||||
INTEGER(SIZE_T), VALUE :: size
|
||||
END FUNCTION H5Eget_msg
|
||||
END INTERFACE
|
||||
|
||||
hdferr = 0
|
||||
msg_cp_sz = 0
|
||||
IF(PRESENT(msg_size))THEN
|
||||
IF(msg_size .EQ. 0)THEN
|
||||
c_msg_size = H5Eget_msg(msg_id, c_msg_type, C_NULL_PTR, 0_SIZE_T)
|
||||
|
||||
IF(PRESENT(msg_size)) msg_size = c_msg_size
|
||||
msg_type = INT(c_msg_type)
|
||||
|
||||
IF(c_msg_size.LT.0) hdferr = -1
|
||||
RETURN
|
||||
ELSE
|
||||
msg_cp_sz = msg_size
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
IF(msg_cp_sz.EQ.0) msg_cp_sz = LEN(msg)
|
||||
|
||||
ALLOCATE(c_msg(1:msg_cp_sz+1), stat=hdferr)
|
||||
IF (hdferr .NE. 0) THEN
|
||||
hdferr = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
f_ptr = C_LOC(c_msg(1)(1:1))
|
||||
c_msg_size = H5Eget_msg(msg_id, c_msg_type, f_ptr, msg_cp_sz+1)
|
||||
|
||||
CALL HD5c2fstring(msg, c_msg, msg_cp_sz, msg_cp_sz+1_SIZE_T)
|
||||
|
||||
DEALLOCATE(c_msg)
|
||||
|
||||
IF(PRESENT(msg_size))THEN
|
||||
msg_size = c_msg_size
|
||||
ENDIF
|
||||
|
||||
msg_type = INT(c_msg_type)
|
||||
|
||||
IF(c_msg_size.LT.0) hdferr = -1
|
||||
|
||||
END SUBROUTINE H5Eget_msg_f
|
||||
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Retrieves the number of error messages in an error stack.
|
||||
!!
|
||||
!! \param error_stack_id An error message identifier
|
||||
!! \param count Number of error messages in \p err_id
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Eget_num()
|
||||
!!
|
||||
SUBROUTINE h5eget_num_f(error_stack_id, count, hdferr)
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T) , INTENT(IN) :: error_stack_id
|
||||
INTEGER(SIZE_T), INTENT(OUT) :: count
|
||||
INTEGER , INTENT(OUT) :: hdferr
|
||||
|
||||
INTERFACE
|
||||
INTEGER(SIZE_T) FUNCTION H5Eget_num(error_stack_id) BIND(C, NAME='H5Eget_num')
|
||||
IMPORT :: HID_T, SIZE_T
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), VALUE :: error_stack_id
|
||||
END FUNCTION H5Eget_num
|
||||
END INTERFACE
|
||||
|
||||
count = H5Eget_num(error_stack_id)
|
||||
|
||||
hdferr = 0
|
||||
IF(count.LT.0) hdferr = -1
|
||||
|
||||
END SUBROUTINE h5eget_num_f
|
||||
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Walks the specified error stack, calling the specified function.
|
||||
!!
|
||||
!! \param err_stack Error stack identifier
|
||||
!! \param direction Direction in which the error stack is to be walked
|
||||
!! \param op Function to be called for each error encountered
|
||||
!! \param op_data Data to be passed to func
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Ewalk2()
|
||||
!!
|
||||
SUBROUTINE h5ewalk_f(err_stack, direction, op, op_data, hdferr)
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T) , INTENT(IN) :: err_stack
|
||||
INTEGER , INTENT(IN) :: direction
|
||||
TYPE(C_FUNPTR) , INTENT(IN) :: op
|
||||
TYPE(C_PTR) , INTENT(INOUT) :: op_data ! Declare INOUT to bypass gfortran 4.8.5 issue
|
||||
INTEGER , INTENT(OUT) :: hdferr
|
||||
|
||||
INTERFACE
|
||||
INTEGER(C_INT) FUNCTION H5Ewalk(err_stack, direction, op, op_data) &
|
||||
BIND(C, NAME='H5Ewalk2')
|
||||
IMPORT :: HID_T, C_FUNPTR, C_PTR, C_INT
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), VALUE :: err_stack
|
||||
INTEGER(C_INT), VALUE :: direction
|
||||
TYPE(C_FUNPTR), VALUE :: op
|
||||
TYPE(C_PTR) , VALUE :: op_data
|
||||
END FUNCTION H5Ewalk
|
||||
END INTERFACE
|
||||
|
||||
hdferr = INT(H5Ewalk(err_stack, direction, op, op_data))
|
||||
|
||||
END SUBROUTINE h5ewalk_f
|
||||
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Retrieves an error message.
|
||||
!!
|
||||
!! \param class_id Error class identifier
|
||||
!! \param name Buffer for the error class name
|
||||
!! \param hdferr \fortran_error
|
||||
!! \param size The maximum number of characters of the class name to be returned by this function in \p name.
|
||||
!!
|
||||
!! If \p size is omitted, the API will copy up to the length of \p name, and it
|
||||
!! is the application's responsibility to provide a large enough buffer. If \p size
|
||||
!! is zero, the required buffer size will be returned, and \p name is not accessed.
|
||||
!! If \p size is greater than zero, the function will copy up to the length
|
||||
!! of \p size info \p name.
|
||||
!!
|
||||
!! See C API: @ref H5Eget_class_name()
|
||||
!!
|
||||
SUBROUTINE H5Eget_class_name_f(class_id, name, hdferr, size)
|
||||
IMPLICIT NONE
|
||||
|
||||
INTEGER(HID_T) , INTENT(IN) :: class_id
|
||||
CHARACTER(LEN=*) :: name
|
||||
INTEGER , INTENT(OUT) :: hdferr
|
||||
INTEGER(SIZE_T) , INTENT(INOUT), OPTIONAL :: size
|
||||
|
||||
CHARACTER(LEN=1,KIND=C_CHAR), DIMENSION(:), ALLOCATABLE, TARGET :: c_name
|
||||
TYPE(C_PTR) :: f_ptr
|
||||
INTEGER(SIZE_T) :: name_cp_sz
|
||||
INTEGER(SIZE_T) :: c_size
|
||||
|
||||
INTERFACE
|
||||
INTEGER(SIZE_T) FUNCTION H5Eget_class_name(class_id, name, size) &
|
||||
BIND(C,NAME='H5Eget_class_name')
|
||||
IMPORT :: C_PTR, C_CHAR
|
||||
IMPORT :: HID_T, SIZE_T
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T) , VALUE :: class_id
|
||||
TYPE(C_PTR) , VALUE :: name
|
||||
INTEGER(SIZE_T), VALUE :: size
|
||||
END FUNCTION H5Eget_class_name
|
||||
END INTERFACE
|
||||
|
||||
hdferr = 0
|
||||
name_cp_sz = 0
|
||||
IF(PRESENT(size))THEN
|
||||
IF(size .EQ. 0)THEN
|
||||
c_size = H5Eget_class_name(class_id, C_NULL_PTR, 0_SIZE_T)
|
||||
|
||||
IF(PRESENT(size)) size = c_size
|
||||
IF(c_size.LT.0) hdferr = -1
|
||||
RETURN
|
||||
ELSE
|
||||
name_cp_sz = size
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
IF(name_cp_sz.EQ.0) name_cp_sz = LEN(name)
|
||||
|
||||
ALLOCATE(c_name(1:name_cp_sz+1), stat=hdferr)
|
||||
IF (hdferr .NE. 0) THEN
|
||||
hdferr = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
f_ptr = C_LOC(c_name)
|
||||
c_size = H5Eget_class_name(class_id, f_ptr, name_cp_sz+1_SIZE_T)
|
||||
|
||||
CALL HD5c2fstring(name, c_name, name_cp_sz, name_cp_sz+1_SIZE_T)
|
||||
DEALLOCATE(c_name)
|
||||
|
||||
IF(PRESENT(size))THEN
|
||||
size = c_size
|
||||
ENDIF
|
||||
|
||||
IF(c_size.LT.0) hdferr = -1
|
||||
|
||||
END SUBROUTINE H5Eget_class_name_f
|
||||
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Appends one error stack to another, optionally closing the source stack.
|
||||
!!
|
||||
!! \param dst_stack_id Error stack identifier
|
||||
!! \param src_stack_id Error stack identifier
|
||||
!! \param close_source_stack Flag to indicate whether to close the source stack
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Eappend_stack()
|
||||
!!
|
||||
SUBROUTINE H5Eappend_stack_f(dst_stack_id, src_stack_id, close_source_stack, hdferr)
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), INTENT(IN) :: dst_stack_id
|
||||
INTEGER(HID_T), INTENT(IN) :: src_stack_id
|
||||
LOGICAL , INTENT(IN) :: close_source_stack
|
||||
INTEGER , INTENT(OUT) :: hdferr
|
||||
|
||||
INTERFACE
|
||||
INTEGER(C_INT) FUNCTION H5Eappend_stack(dst_stack_id, src_stack_id, close_source_stack) &
|
||||
BIND(C, NAME='H5Eappend_stack')
|
||||
IMPORT :: HID_T, C_BOOL, C_INT
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T) , VALUE :: dst_stack_id
|
||||
INTEGER(HID_T) , VALUE :: src_stack_id
|
||||
LOGICAL(C_BOOL), VALUE :: close_source_stack
|
||||
END FUNCTION H5Eappend_stack
|
||||
END INTERFACE
|
||||
|
||||
hdferr = INT(H5Eappend_stack(dst_stack_id, src_stack_id, LOGICAL(close_source_stack, C_BOOL)))
|
||||
|
||||
END SUBROUTINE H5Eappend_stack_f
|
||||
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Returns a copy of the current error stack.
|
||||
!!
|
||||
!! \param err_stack_id Error stack identifier
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Eget_current_stack()
|
||||
!!
|
||||
SUBROUTINE H5Eget_current_stack_f(err_stack_id, hdferr)
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), INTENT(OUT) :: err_stack_id
|
||||
INTEGER , INTENT(OUT) :: hdferr
|
||||
|
||||
INTERFACE
|
||||
INTEGER(HID_T) FUNCTION H5Eget_current_stack() BIND(C, NAME='H5Eget_current_stack')
|
||||
IMPORT :: HID_T
|
||||
IMPLICIT NONE
|
||||
END FUNCTION H5Eget_current_stack
|
||||
END INTERFACE
|
||||
|
||||
err_stack_id = H5Eget_current_stack()
|
||||
|
||||
hdferr = 0
|
||||
IF(err_stack_id.LT.0) hdferr = -1
|
||||
|
||||
END SUBROUTINE H5Eget_current_stack_f
|
||||
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Replaces the current error stack.
|
||||
!!
|
||||
!! \param err_stack_id Error stack identifier
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Eset_current_stack()
|
||||
!!
|
||||
SUBROUTINE H5Eset_current_stack_f(err_stack_id, hdferr)
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), INTENT(IN ) :: err_stack_id
|
||||
INTEGER , INTENT(OUT) :: hdferr
|
||||
|
||||
INTERFACE
|
||||
INTEGER(C_INT) FUNCTION H5Eset_current_stack(err_stack_id) BIND(C, NAME='H5Eset_current_stack')
|
||||
IMPORT :: C_INT, HID_T
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), VALUE :: err_stack_id
|
||||
END FUNCTION H5Eset_current_stack
|
||||
END INTERFACE
|
||||
|
||||
hdferr = INT(H5Eset_current_stack(err_stack_id))
|
||||
|
||||
END SUBROUTINE H5Eset_current_stack_f
|
||||
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Closes an error stack handle.
|
||||
!!
|
||||
!! \param err_stack_id Error stack identifier
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Eclose_stack()
|
||||
!!
|
||||
SUBROUTINE H5Eclose_stack_f(err_stack_id, hdferr)
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), INTENT(IN ) :: err_stack_id
|
||||
INTEGER , INTENT(OUT) :: hdferr
|
||||
|
||||
INTERFACE
|
||||
INTEGER(C_INT) FUNCTION H5Eclose_stack(err_stack_id) BIND(C, NAME='H5Eclose_stack')
|
||||
IMPORT :: C_INT, HID_T
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), VALUE :: err_stack_id
|
||||
END FUNCTION H5Eclose_stack
|
||||
END INTERFACE
|
||||
|
||||
hdferr = INT(H5Eclose_stack(err_stack_id))
|
||||
|
||||
END SUBROUTINE H5Eclose_stack_f
|
||||
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Creates a new, empty error stack.
|
||||
!!
|
||||
!! \param err_stack_id Error stack identifier
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Ecreate_stack()
|
||||
!!
|
||||
SUBROUTINE H5Ecreate_stack_f(err_stack_id, hdferr)
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T), INTENT(OUT) :: err_stack_id
|
||||
INTEGER , INTENT(OUT) :: hdferr
|
||||
|
||||
INTERFACE
|
||||
INTEGER(HID_T) FUNCTION H5Ecreate_stack() BIND(C, NAME='H5Ecreate_stack')
|
||||
IMPORT :: HID_T
|
||||
IMPLICIT NONE
|
||||
END FUNCTION H5Ecreate_stack
|
||||
END INTERFACE
|
||||
|
||||
err_stack_id = H5Ecreate_stack()
|
||||
|
||||
hdferr = 0
|
||||
IF(err_stack_id.LT.0) hdferr = -1
|
||||
|
||||
END SUBROUTINE H5Ecreate_stack_f
|
||||
|
||||
!>
|
||||
!! \ingroup FH5E
|
||||
!!
|
||||
!! \brief Deletes specified number of error messages from the error stack.
|
||||
!!
|
||||
!! \param err_stack_id Error stack identifier
|
||||
!! \param count The number of error messages to be deleted from the top of error stack
|
||||
!! \param hdferr \fortran_error
|
||||
!!
|
||||
!! See C API: @ref H5Epop()
|
||||
!!
|
||||
SUBROUTINE H5Epop_f(err_stack_id, count, hdferr)
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T) , INTENT(IN ) :: err_stack_id
|
||||
INTEGER(SIZE_T), INTENT(IN ) :: count
|
||||
INTEGER , INTENT(OUT) :: hdferr
|
||||
|
||||
INTERFACE
|
||||
INTEGER(C_INT) FUNCTION H5Epop(err_stack_id, count) BIND(C, NAME='H5Epop')
|
||||
IMPORT :: C_INT, HID_T, SIZE_T
|
||||
IMPLICIT NONE
|
||||
INTEGER(HID_T) , VALUE :: err_stack_id
|
||||
INTEGER(SIZE_T), VALUE :: count
|
||||
END FUNCTION H5Epop
|
||||
END INTERFACE
|
||||
|
||||
hdferr = INT(H5Epop(err_stack_id, count))
|
||||
|
||||
END SUBROUTINE H5Epop_f
|
||||
|
||||
END MODULE H5E
|
||||
|
||||
|
||||
@ -6250,7 +6250,7 @@ SUBROUTINE h5pget_virtual_filename_f(dcpl_id, index, name, hdferr, name_len)
|
||||
IF(INT(h5pget_virtual_filename(dcpl_id, index, f_ptr, INT(LEN(name)+1,SIZE_T)), SIZE_T).LT.0)THEN
|
||||
hdferr = -1
|
||||
ELSE
|
||||
CALL HD5c2fstring(name,c_name,LEN(name))
|
||||
CALL HD5c2fstring(name, c_name, LEN(name,KIND=SIZE_T), LEN(name,KIND=SIZE_T)+1_SIZE_T )
|
||||
ENDIF
|
||||
|
||||
ENDIF
|
||||
@ -6304,7 +6304,7 @@ SUBROUTINE h5pget_virtual_dsetname_f(dcpl_id, index, name, hdferr, name_len)
|
||||
IF(INT(h5pget_virtual_dsetname(dcpl_id, index, f_ptr, INT(LEN(name)+1,SIZE_T)), SIZE_T).LT.0)THEN
|
||||
hdferr = -1
|
||||
ELSE
|
||||
CALL HD5c2fstring(name,c_name,LEN(name))
|
||||
CALL HD5c2fstring(name, c_name, LEN(name,KIND=SIZE_T), LEN(name,KIND=SIZE_T)+1_SIZE_T )
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
|
||||
@ -343,7 +343,7 @@ CONTAINS
|
||||
IF(INT(H5VLget_connector_name(obj_id, c_name, l), SIZE_T).LT.0)THEN
|
||||
hdferr = H5I_INVALID_HID_F
|
||||
ELSE
|
||||
CALL HD5c2fstring(name,c_name,LEN(name))
|
||||
CALL HD5c2fstring(name, c_name, LEN(name,KIND=SIZE_T), LEN(name,KIND=SIZE_T)+1_SIZE_T )
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
|
||||
@ -67,6 +67,9 @@
|
||||
#define H5_FORTRAN_HAVE_C_SIZEOF
|
||||
#endif
|
||||
|
||||
! Define if allocatable character is supported
|
||||
#define H5_FORTRAN_HAVE_CHAR_ALLOC @H5_FORTRAN_HAVE_CHAR_ALLOC@
|
||||
|
||||
! Define if the intrinsic function C_LONG_DOUBLE exists
|
||||
#define H5_FORTRAN_HAVE_C_LONG_DOUBLE @H5_FORTRAN_HAVE_C_LONG_DOUBLE@
|
||||
|
||||
|
||||
@ -35,6 +35,9 @@
|
||||
! Define if the intrinsic function C_SIZEOF exists
|
||||
#undef FORTRAN_HAVE_C_SIZEOF
|
||||
|
||||
! Define if Fortran supports allocatable character
|
||||
#undef FORTRAN_HAVE_CHAR_ALLOC
|
||||
|
||||
! Define if the intrinsic function C_LONG_DOUBLE exists
|
||||
#undef FORTRAN_HAVE_C_LONG_DOUBLE
|
||||
|
||||
|
||||
@ -553,12 +553,15 @@ H5_FCDLL int_f h5iis_valid_c(hid_t_f *obj_id, int_f *c_valid);
|
||||
* Functions from H5Ef.c
|
||||
*/
|
||||
|
||||
H5_FCDLL int_f h5eclear_c(hid_t_f *estack_id);
|
||||
H5_FCDLL int_f h5eprint_c1(_fcd name, int_f *namelen);
|
||||
H5_FCDLL int_f h5eprint_c2(void);
|
||||
H5_FCDLL int_f h5eget_major_c(int_f *error_no, _fcd name, size_t_f *namelen);
|
||||
H5_FCDLL int_f h5eget_minor_c(int_f *error_no, _fcd name, size_t_f *namelen);
|
||||
H5_FCDLL int_f h5eprint_c(hid_t_f *err_stack, _fcd name, size_t_f *namelen);
|
||||
H5_FCDLL int_f h5eset_auto2_c(int_f *printflag, hid_t_f *estack_id, H5E_auto2_t func, void *client_data);
|
||||
H5_FCDLL int_f h5epush_c(hid_t_f *err_stack, hid_t_f *cls_id, hid_t_f *maj_id, hid_t_f *min_id, _fcd msg,
|
||||
size_t_f *msg_len, char *file, char *func, int *line, const char *arg1,
|
||||
const char *arg2, const char *arg3, const char *arg4, const char *arg5,
|
||||
const char *arg6, const char *arg7, const char *arg8, const char *arg9,
|
||||
const char *arg10, const char *arg11, const char *arg12, const char *arg13,
|
||||
const char *arg14, const char *arg15, const char *arg16, const char *arg17,
|
||||
const char *arg18, const char *arg19, const char *arg20);
|
||||
|
||||
/*
|
||||
* Functions from H5f.c
|
||||
|
||||
@ -25,6 +25,8 @@
|
||||
!*****
|
||||
MODULE H5fortkit
|
||||
|
||||
USE H5FORTRAN_TYPES, ONLY : SIZE_T
|
||||
|
||||
CONTAINS
|
||||
|
||||
!****if* H5fortkit/HD5c2fstring
|
||||
@ -32,28 +34,35 @@ CONTAINS
|
||||
! HD5c2fstring
|
||||
! INPUTS
|
||||
! cstring - C string stored as a string array of size 'len' of string size LEN=1
|
||||
! len - length of Fortran string
|
||||
! f_len - length of Fortran string
|
||||
! c_len - length of C array
|
||||
! OUTPUT
|
||||
! fstring - Fortran string array of LEN=1
|
||||
! fstring - Fortran string LEN=1
|
||||
! PURPOSE
|
||||
! Copies a Fortran array of strings having a length of one to a fortran string and removes the C Null
|
||||
! Copies a C array of strings having a length of one to a fortran string and removes the C Null
|
||||
! terminator. The Null terminator is returned from C when calling the C APIs directly.
|
||||
!
|
||||
! The fortran standard does not allow C_LOC to be used on a character string of
|
||||
! length greater than one, which is why we use the array of characters instead.
|
||||
!
|
||||
! SOURCE
|
||||
SUBROUTINE HD5c2fstring(fstring,cstring,len)
|
||||
SUBROUTINE HD5c2fstring(fstring,cstring,f_len,c_len)
|
||||
!*****
|
||||
IMPLICIT NONE
|
||||
|
||||
INTEGER :: i
|
||||
INTEGER :: len
|
||||
CHARACTER(LEN=len) :: fstring
|
||||
CHARACTER(LEN=1), DIMENSION(1:len) :: cstring
|
||||
INTEGER(SIZE_T) :: i
|
||||
INTEGER(SIZE_T) :: f_len
|
||||
INTEGER(SIZE_T) :: c_len
|
||||
CHARACTER(*) :: fstring
|
||||
CHARACTER(LEN=1), DIMENSION(1:c_len) :: cstring
|
||||
|
||||
INTEGER(SIZE_T) :: f_len_max
|
||||
|
||||
fstring = ''
|
||||
DO i = 1, len
|
||||
f_len_max = LEN(fstring, KIND=SIZE_T)
|
||||
DO i = 1, c_len
|
||||
IF (i .GT. f_len_max) EXIT
|
||||
IF (i .GT. f_len) EXIT
|
||||
IF (cstring(i)(1:1)==CHAR(0)) EXIT
|
||||
fstring(i:i) = cstring(i)(1:1)
|
||||
END DO
|
||||
|
||||
@ -143,10 +143,11 @@ FORTRAN_API=yes
|
||||
# modules they depend upon are actually made. *sigh*
|
||||
H5f90global.lo: $(srcdir)/H5f90global.F90 H5fortran_types.lo
|
||||
H5_buildiface.lo: $(srcdir)/H5_buildiface.F90
|
||||
H5fortkit.lo: $(srcdir)/H5fortkit.F90 H5fortran_types.lo
|
||||
H5_ff.lo: $(srcdir)/H5_ff.F90 H5Fff.lo H5f90global.lo
|
||||
H5Aff.lo: $(srcdir)/H5Aff.F90 H5f90global.lo
|
||||
H5Dff.lo: $(srcdir)/H5Dff.F90 H5f90global.lo H5_ff.lo H5Sff.lo
|
||||
H5Eff.lo: $(srcdir)/H5Eff.F90 H5f90global.lo
|
||||
H5Eff.lo: $(srcdir)/H5Eff.F90 H5f90global.lo H5fortkit.lo
|
||||
H5ESff.lo: $(srcdir)/H5ESff.F90 H5f90global.lo
|
||||
H5Fff.lo: $(srcdir)/H5Fff.F90 H5f90global.lo
|
||||
H5Gff.lo: $(srcdir)/H5Gff.F90 H5f90global.lo H5Pff.lo
|
||||
|
||||
@ -106,10 +106,26 @@ H5D_mp_H5DWRITE_CHUNK_F
|
||||
H5D_mp_H5DREAD_CHUNK_F
|
||||
; H5E
|
||||
H5E_mp_H5ECLEAR_F
|
||||
H5E_mp_H5EPRINT_F
|
||||
H5E_mp_H5EPRINT1_F
|
||||
H5E_mp_H5EPRINT2_F
|
||||
H5E_mp_H5EGET_MAJOR_F
|
||||
H5E_mp_H5EGET_MINOR_F
|
||||
H5E_mp_H5ESET_AUTO_F
|
||||
H5E_mp_H5EREGISTER_CLASS_F
|
||||
H5E_mp_H5EUNREGISTER_CLASS_F
|
||||
H5E_mp_H5ECREATE_MSG_F
|
||||
H5E_mp_H5ECLOSE_MSG_F
|
||||
H5E_mp_H5EGET_MSG_F
|
||||
H5E_mp_H5EPUSH_F
|
||||
H5E_mp_H5EGET_NUM_F
|
||||
H5E_mp_H5EWALK_F
|
||||
H5E_mp_H5EGET_CLASS_NAME_F
|
||||
H5E_mp_H5EAPPEND_STACK_F
|
||||
H5E_mp_H5EGET_CURRENT_STACK_F
|
||||
H5E_mp_H5ESET_CURRENT_STACK_F
|
||||
H5E_mp_H5ECREATE_STACK_F
|
||||
H5E_mp_H5ECLOSE_STACK_F
|
||||
H5E_mp_H5EPOP_F
|
||||
; H5ES
|
||||
H5ES_mp_H5ESCREATE_F
|
||||
H5ES_mp_H5ESGET_COUNT_F
|
||||
|
||||
@ -55,13 +55,12 @@ PROGRAM fortranlibtest_F03
|
||||
total_error = total_error + 1
|
||||
ENDIF
|
||||
|
||||
ret_total_error = 0
|
||||
! PROBLEMS with C
|
||||
! CALL test_error(ret_total_error)
|
||||
! CALL write_test_status(ret_total_error, ' Test error API based on data I/O', total_error)
|
||||
|
||||
WRITE(*,*)
|
||||
|
||||
ret_total_error = 0
|
||||
CALL test_error(ret_total_error)
|
||||
CALL write_test_status(ret_total_error, ' Test error API based on data I/O', total_error)
|
||||
|
||||
ret_total_error = 0
|
||||
CALL test_array_compound_atomic(ret_total_error)
|
||||
CALL write_test_status(ret_total_error, ' Testing 1-D Array of Compound Datatypes Functionality', total_error)
|
||||
@ -175,6 +174,10 @@ PROGRAM fortranlibtest_F03
|
||||
CALL test_obj_info(ret_total_error)
|
||||
CALL write_test_status(ret_total_error, ' Testing object info functions ', total_error)
|
||||
|
||||
ret_total_error = 0
|
||||
CALL test_error_stack(ret_total_error)
|
||||
CALL write_test_status(ret_total_error, ' Test error H5E API stack operations', total_error)
|
||||
|
||||
! write(*,*)
|
||||
! write(*,*) '========================================='
|
||||
! write(*,*) 'Testing VDS '
|
||||
|
||||
@ -48,8 +48,6 @@ CONTAINS
|
||||
CHARACTER(LEN=8), PARAMETER :: err_filename = "err_file"! Error output file
|
||||
CHARACTER(LEN=80) :: fix_err_filename
|
||||
|
||||
|
||||
|
||||
INTEGER(HID_T) :: file_id ! File identifier
|
||||
INTEGER(HID_T) :: grp_id ! Group identifier
|
||||
INTEGER :: error, tmp_error, err_flag
|
||||
|
||||
@ -55,40 +55,116 @@ CONTAINS
|
||||
|
||||
! estack_id is always passed from C as: H5E_DEFAULT
|
||||
INTEGER(HID_T) :: estack_id
|
||||
|
||||
! data that was registered with H5Eset_auto_f
|
||||
INTEGER :: data_inout
|
||||
! INTEGER :: data_inout ! another option
|
||||
! or
|
||||
TYPE(C_PTR), VALUE :: data_inout
|
||||
|
||||
PRINT*, " "
|
||||
PRINT*, " Subtest: H5Eset_auto_f custom error message with callback, WITH DATA"
|
||||
PRINT*, " -This message should be written to standard out- "
|
||||
PRINT*, " Data Values Passed In =", data_inout
|
||||
PRINT*, " "
|
||||
INTEGER, POINTER :: iunit
|
||||
|
||||
data_inout = 10*data_inout
|
||||
CALL C_F_POINTER(data_inout, iunit)
|
||||
|
||||
! iunit = data_inout
|
||||
|
||||
WRITE(iunit,'(A)') "H5Eset_auto_f_msg"
|
||||
WRITE(iunit,'(I0)') iunit
|
||||
|
||||
iunit = 10*iunit
|
||||
|
||||
my_hdf5_error_handler = 1 ! this is not used by the C routine
|
||||
|
||||
END FUNCTION my_hdf5_error_handler
|
||||
|
||||
INTEGER FUNCTION my_hdf5_error_handler_nodata(estack_id, data_inout) bind(C)
|
||||
|
||||
! This error function handle works with only version 2 error stack
|
||||
!-------------------------------------------------------------------------
|
||||
! Function: custom_print_cb
|
||||
!
|
||||
! Purpose: Callback function to print error stack in customized way.
|
||||
!
|
||||
!-------------------------------------------------------------------------
|
||||
!
|
||||
INTEGER(C_INT) FUNCTION custom_print_cb(n, err_desc, op_data) BIND(C)
|
||||
|
||||
IMPLICIT NONE
|
||||
|
||||
! estack_id is always passed from C as: H5E_DEFAULT
|
||||
INTEGER(HID_T) :: estack_id
|
||||
! data that was registered with H5Eset_auto_f
|
||||
TYPE(C_PTR) :: data_inout
|
||||
INTEGER(SIZE_T), PARAMETER :: MSG_SIZE = 64
|
||||
|
||||
PRINT*, " "
|
||||
PRINT*, " Subtest: H5Eset_auto_f custom error message with callback, NO DATA"
|
||||
PRINT*, " -This message should be written to standard out- "
|
||||
PRINT*, " "
|
||||
INTEGER(C_INT) :: n
|
||||
TYPE(h5e_error_t) :: err_desc
|
||||
TYPE(C_PTR) :: op_data
|
||||
|
||||
my_hdf5_error_handler_nodata = 1 ! this is not used by the C routine
|
||||
CHARACTER(LEN=MSG_SIZE) :: maj
|
||||
CHARACTER(LEN=MSG_SIZE) :: minn
|
||||
CHARACTER(LEN=MSG_SIZE) :: cls
|
||||
INTEGER(SIZE_T) :: size
|
||||
INTEGER :: msg_type
|
||||
|
||||
END FUNCTION my_hdf5_error_handler_nodata
|
||||
INTEGER :: error
|
||||
|
||||
CALL H5Eget_class_name_f(err_desc%cls_id, cls, error)
|
||||
IF(error .LT.0)THEN
|
||||
custom_print_cb = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
IF(TRIM(cls).NE."Custom error class")THEN
|
||||
custom_print_cb = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
size = 3
|
||||
CALL H5Eget_class_name_f(err_desc%cls_id, cls, error, size)
|
||||
IF(error .LT.0)THEN
|
||||
custom_print_cb = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(TRIM(cls).NE."Cus")THEN
|
||||
custom_print_cb = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
size = 0
|
||||
CALL H5Eget_class_name_f(err_desc%cls_id, "", error, size)
|
||||
IF(error .LT.0)THEN
|
||||
custom_print_cb = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(size.NE.18)THEN
|
||||
custom_print_cb = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
size = MSG_SIZE
|
||||
CALL H5Eget_msg_f(err_desc%maj_num, msg_type, maj, error, size)
|
||||
IF(error .LT.0)THEN
|
||||
custom_print_cb = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
CALL h5eget_major_f(err_desc%maj_num, maj, size, error)
|
||||
IF("MAJOR MSG".NE.TRIM(maj))THEN
|
||||
custom_print_cb = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
IF(error .LT. 0)THEN
|
||||
custom_print_cb = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
CALL h5eget_minor_f(err_desc%min_num, minn, error)
|
||||
IF(error .LT. 0)THEN
|
||||
custom_print_cb = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
IF("MIN MSG".NE.TRIM(minn))THEN
|
||||
custom_print_cb = -1
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
custom_print_cb = 0
|
||||
|
||||
END FUNCTION custom_print_cb
|
||||
|
||||
END MODULE test_my_hdf5_error_handler
|
||||
|
||||
@ -103,30 +179,24 @@ SUBROUTINE test_error(total_error)
|
||||
|
||||
IMPLICIT NONE
|
||||
|
||||
INTEGER(hid_t), PARAMETER :: FAKE_ID = -1
|
||||
INTEGER :: total_error
|
||||
INTEGER(hid_t) :: file
|
||||
INTEGER(hid_t) :: dataset, space
|
||||
INTEGER(hsize_t), DIMENSION(1:2) :: dims
|
||||
INTEGER :: error
|
||||
INTEGER, DIMENSION(:), POINTER :: ptr_data
|
||||
INTEGER, TARGET :: my_hdf5_error_handler_data
|
||||
INTEGER, TARGET :: iunit
|
||||
TYPE(C_PTR) :: f_ptr
|
||||
TYPE(C_FUNPTR) :: func
|
||||
CHARACTER(LEN=180) :: chr180
|
||||
INTEGER :: idx
|
||||
|
||||
TYPE(C_PTR), TARGET :: f_ptr1
|
||||
LOGICAL :: status
|
||||
|
||||
INTEGER, DIMENSION(1:1) :: array_shape
|
||||
! set the error stack to the customized routine
|
||||
|
||||
my_hdf5_error_handler_data = 99
|
||||
CALL h5fcreate_f("terror.h5", H5F_ACC_TRUNC_F, file, error)
|
||||
CALL check("h5fcreate_f", error, total_error)
|
||||
iunit = 12
|
||||
OPEN(iunit, FILE="stderr.txt")
|
||||
|
||||
! Create the data space
|
||||
dims(1) = 10
|
||||
dims(2) = 20
|
||||
CALL H5Screate_simple_f(2, dims, space, error)
|
||||
CALL check("h5screate_simple_f", error, total_error)
|
||||
my_hdf5_error_handler_data = iunit
|
||||
|
||||
! ** SET THE CUSTOMIZED PRINTING OF ERROR STACK **
|
||||
|
||||
@ -136,65 +206,277 @@ SUBROUTINE test_error(total_error)
|
||||
! set the data sent to the customized routine
|
||||
f_ptr = c_loc(my_hdf5_error_handler_data)
|
||||
|
||||
! turn on automatic printing, and use a custom error routine with input data
|
||||
CALL H5Eset_auto_f(1, error, H5E_DEFAULT_F, func, f_ptr)
|
||||
CALL check("H5Eset_auto_f", error, total_error)
|
||||
|
||||
! Create the erring dataset
|
||||
CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error)
|
||||
CALL verify("h5dcreate_f", error, -1, total_error)
|
||||
CALL h5fopen_f("DOESNOTEXIST", H5F_ACC_RDONLY_F, file, error)
|
||||
CALL VERIFY("h5fopen_f", error, -1, total_error)
|
||||
|
||||
!!$ CALL verify("H5Eset_auto_f",my_hdf5_error_handler_data(1),10, total_error)
|
||||
!!$ CALL verify("H5Eset_auto_f",my_hdf5_error_handler_data(2),20, total_error)
|
||||
CLOSE(iunit)
|
||||
|
||||
!!$ ! Test enabling and disabling default printing
|
||||
!!$
|
||||
!!$ CALL H5Eget_auto_f(H5E_DEFAULT_F, func1, f_ptr1, error)
|
||||
!!$ CALL verify("H5Eget_auto_f", error, 0, total_error)
|
||||
OPEN(iunit, FILE="stderr.txt")
|
||||
|
||||
! PRINT*,c_associated(f_ptr1)
|
||||
READ(iunit,'(A)') chr180
|
||||
idx = INDEX(string=chr180,substring="H5Eset_auto_f_msg")
|
||||
IF(idx.EQ.0) CALL check("H5Eset_auto_f", -1, total_error)
|
||||
READ(iunit, *) idx
|
||||
CALL VERIFY("H5Eset_auto_f", idx, iunit, total_error)
|
||||
CALL VERIFY("H5Eset_auto_f", my_hdf5_error_handler_data, 10*iunit, total_error)
|
||||
|
||||
ALLOCATE(ptr_data(1:2))
|
||||
ptr_data = 0
|
||||
array_shape(1) = 2
|
||||
CALL C_F_POINTER(f_ptr1, ptr_data, array_shape)
|
||||
|
||||
! ptr_data => f_ptr1(1)
|
||||
|
||||
! PRINT*,ptr_data(1)
|
||||
|
||||
!!$ if(old_data != NULL)
|
||||
!!$ TEST_ERROR;
|
||||
!!$#ifdef H5_USE_16_API
|
||||
!!$ if (old_func != (H5E_auto_t)H5Eprint)
|
||||
!!$ TEST_ERROR;
|
||||
!!$#else H5_USE_16_API
|
||||
!!$ if (old_func != (H5E_auto2_t)H5Eprint2)
|
||||
!!$ TEST_ERROR;
|
||||
!!$#endif H5_USE_16_API
|
||||
|
||||
|
||||
! set the customized error handling routine
|
||||
func = c_funloc(my_hdf5_error_handler_nodata)
|
||||
! set the data sent to the customized routine as null
|
||||
f_ptr = C_NULL_PTR
|
||||
! turn on automatic printing, and use a custom error routine with no input data
|
||||
CALL H5Eset_auto_f(1, error, H5E_DEFAULT_F, func, f_ptr)
|
||||
|
||||
CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error)
|
||||
CALL verify("h5dcreate_f", error, -1, total_error)
|
||||
|
||||
|
||||
! turn on automatic printing with h5eprint_f which prints an error stack in the default manner.
|
||||
|
||||
! func = c_funloc(h5eprint_f)
|
||||
! CALL H5Eset_auto_f(0, error, H5E_DEFAULT_F, func, C_NULL_PTR)
|
||||
CLOSE(iunit, STATUS='delete')
|
||||
|
||||
CALL H5Eset_auto_f(0, error)
|
||||
CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error)
|
||||
CALL check("H5Eset_auto_f", error, total_error)
|
||||
|
||||
CALL H5Eset_auto_f(1, error)
|
||||
CALL h5dcreate_f(FAKE_ID,"a_dataset",H5T_NATIVE_INTEGER, space, dataset, error)
|
||||
CALL h5fopen_f("DOESNOTEXIST", H5F_ACC_RDONLY_F, file, error)
|
||||
CALL VERIFY("h5fopen_f", error, -1, total_error)
|
||||
|
||||
INQUIRE(file="H5Etest.txt", EXIST=status)
|
||||
IF(status)THEN
|
||||
CALL VERIFY("H5Eset_auto_f", error, -1, total_error)
|
||||
ENDIF
|
||||
|
||||
END SUBROUTINE test_error
|
||||
|
||||
SUBROUTINE test_error_stack(total_error)
|
||||
|
||||
IMPLICIT NONE
|
||||
|
||||
INTEGER :: total_error
|
||||
INTEGER :: error
|
||||
INTEGER(HID_T) :: cls_id, major, minor, estack_id, estack_id1, estack_id2
|
||||
CHARACTER(LEN=18), TARGET :: file
|
||||
CHARACTER(LEN=18), TARGET :: func
|
||||
INTEGER , TARGET :: line
|
||||
TYPE(C_PTR) :: ptr1, ptr2, ptr3, ptr4
|
||||
|
||||
INTEGER :: msg_type
|
||||
CHARACTER(LEN=9) :: maj_mesg = "MAJOR MSG"
|
||||
CHARACTER(LEN=7) :: min_mesg = "MIN MSG"
|
||||
!file status
|
||||
LOGICAL :: status
|
||||
CHARACTER(LEN=180) :: chr180
|
||||
INTEGER :: idx
|
||||
INTEGER(SIZE_T) :: count
|
||||
CHARACTER(LEN=64), TARGET :: stderr
|
||||
TYPE(C_FUNPTR) :: func_ptr
|
||||
|
||||
#ifdef H5_FORTRAN_HAVE_CHAR_ALLOC
|
||||
CHARACTER(:), ALLOCATABLE :: msg_alloc
|
||||
#endif
|
||||
|
||||
CHARACTER(LEN=9) :: chr9
|
||||
INTEGER(SIZE_T) :: msg_size
|
||||
|
||||
CALL h5eregister_class_f("Custom error class", "H5E_F03", "0.1", cls_id, error)
|
||||
CALL check("H5Eregister_class_f", error, total_error)
|
||||
|
||||
CALL H5Ecreate_msg_f(cls_id, H5E_MAJOR_F, maj_mesg, major, error)
|
||||
CALL check("H5Ecreate_msg_f", error, total_error)
|
||||
CALL H5Ecreate_msg_f(cls_id, H5E_MINOR_F, min_mesg, minor, error)
|
||||
CALL check("H5Ecreate_msg_f", error, total_error)
|
||||
|
||||
file = "FILE"//C_NULL_CHAR
|
||||
func = "FUNC"//C_NULL_CHAR
|
||||
line = 99
|
||||
|
||||
ptr1 = C_LOC(file)
|
||||
ptr2 = C_LOC(func)
|
||||
ptr3 = C_LOC(line)
|
||||
|
||||
CALL h5ecreate_stack_f(estack_id, error)
|
||||
CALL check("h5ecreate_stack_f", error, total_error)
|
||||
|
||||
! push a custom error message onto the stack
|
||||
CALL H5Epush_f(estack_id, cls_id, major, minor, "%s ERROR TEXT %s"//C_NEW_LINE, error, &
|
||||
ptr1, ptr2, ptr3, &
|
||||
arg1=ACHAR(27)//"[31m", arg2=ACHAR(27)//"[0m" )
|
||||
CALL check("H5Epush_f", error, total_error)
|
||||
|
||||
CALL h5eget_num_f(estack_id, count, error)
|
||||
CALL check("h5eget_num_f", error, total_error)
|
||||
CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error)
|
||||
|
||||
msg_size = 0
|
||||
CALL H5Eget_msg_f(major, msg_type, chr9, error, msg_size)
|
||||
CALL check("H5Eget_msg_f", error, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MAJOR_F, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_size, 9_SIZE_T, total_error)
|
||||
|
||||
! Check when a shorter buffer length is passed as the msg_size
|
||||
msg_size = 3
|
||||
CALL H5Eget_msg_f(major, msg_type, chr9, error, msg_size)
|
||||
CALL check("H5Eget_msg_f", error, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MAJOR_F, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_size, 9_SIZE_T, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", TRIM(chr9), maj_mesg(1:3), total_error)
|
||||
|
||||
! Check when a exact size buffer length is passed as the msg_size
|
||||
msg_size = 9
|
||||
CALL H5Eget_msg_f(major, msg_type, chr9, error, msg_size)
|
||||
CALL check("H5Eget_msg_f", error, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MAJOR_F, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_size, 9_SIZE_T, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", TRIM(chr9), maj_mesg(1:9), total_error)
|
||||
|
||||
msg_size = 0
|
||||
CALL H5Eget_msg_f(minor, msg_type, chr9, error, msg_size)
|
||||
CALL check("H5Eget_msg_f", error, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error)
|
||||
|
||||
! Check when a shorter buffer length is passed as the msg_size
|
||||
msg_size = 3
|
||||
CALL H5Eget_msg_f(minor, msg_type, chr9, error, msg_size)
|
||||
CALL check("H5Eget_msg_f", error, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", TRIM(chr9), min_mesg(1:3), total_error)
|
||||
|
||||
! Check when a larger buffer length is passed as the msg_size
|
||||
msg_size = 9
|
||||
CALL H5Eget_msg_f(minor, msg_type, chr9, error, msg_size)
|
||||
CALL check("H5Eget_msg_f", error, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", TRIM(chr9), min_mesg(1:7), total_error)
|
||||
|
||||
! Check with an allocatable character of the exact size
|
||||
#ifdef H5_FORTRAN_HAVE_CHAR_ALLOC
|
||||
msg_size = 0
|
||||
CALL H5Eget_msg_f(minor, msg_type, "", error, msg_size)
|
||||
CALL check("H5Eget_msg_f", error, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error)
|
||||
|
||||
ALLOCATE(CHARACTER(LEN=msg_size) :: msg_alloc)
|
||||
CALL H5Eget_msg_f(minor, msg_type, msg_alloc, error)
|
||||
CALL check("H5Eget_msg_f", error, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error)
|
||||
CALL VERIFY("H5Eget_msg_f", msg_alloc, min_mesg, total_error)
|
||||
#endif
|
||||
|
||||
CALL h5eprint_f(H5E_DEFAULT_F, error)
|
||||
CALL check("h5eprint_f", error, total_error)
|
||||
CALL h5eprint_f(error)
|
||||
CALL check("h5eprint_f", error, total_error)
|
||||
|
||||
INQUIRE(file="H5Etest.txt", EXIST=status)
|
||||
IF(status)THEN
|
||||
OPEN(UNIT=12, FILE="H5Etest.txt", status='old')
|
||||
CLOSE(12, STATUS='delete')
|
||||
ENDIF
|
||||
|
||||
CALL h5eprint_f(estack_id, error, "H5Etest.txt")
|
||||
CALL check("h5eprint_f", error, total_error)
|
||||
|
||||
INQUIRE(file="H5Etest.txt", EXIST=status)
|
||||
IF(.NOT.status)THEN
|
||||
CALL check("h5eprint_f", -1, total_error)
|
||||
ELSE
|
||||
OPEN(UNIT=12, FILE="H5Etest.txt", status='old')
|
||||
|
||||
READ(12,'(A)') chr180
|
||||
idx = INDEX(string=chr180,substring="Custom error class")
|
||||
IF(idx.EQ.0) CALL check("h5eprint_f1", -1, total_error)
|
||||
idx = INDEX(string=chr180,substring="H5E_F03")
|
||||
IF(idx.EQ.0) CALL check("h5eprint_f2", -1, total_error)
|
||||
idx = INDEX(string=chr180,substring="0.1")
|
||||
IF(idx.EQ.0) CALL check("h5eprint_f3", -1, total_error)
|
||||
|
||||
READ(12,'(A)') chr180
|
||||
idx = INDEX(string=chr180,substring="FILE")
|
||||
IF(idx.EQ.0) CALL check("h5eprint_f4", -1, total_error)
|
||||
idx = INDEX(string=chr180,substring="99")
|
||||
IF(idx.EQ.0) CALL check("h5eprint_f5", -1, total_error)
|
||||
idx = INDEX(string=chr180,substring="FUNC")
|
||||
IF(idx.EQ.0) CALL check("h5eprint_f6", -1, total_error)
|
||||
idx = INDEX(string=chr180,substring="ERROR TEXT")
|
||||
IF(idx.EQ.0) CALL check("h5eprint_f7", -1, total_error)
|
||||
|
||||
READ(12,'()')
|
||||
|
||||
READ(12,"(A)") chr180
|
||||
idx = INDEX(string=chr180,substring=maj_mesg)
|
||||
IF(idx.EQ.0) CALL check("h5eprint_f", -1, total_error)
|
||||
|
||||
READ(12,"(A)") chr180
|
||||
idx = INDEX(string=chr180,substring=min_mesg)
|
||||
IF(idx.EQ.0) CALL check("h5eprint_f", -1, total_error)
|
||||
|
||||
CLOSE(12, STATUS='delete')
|
||||
ENDIF
|
||||
|
||||
stderr = "** Print error stack in customized way **"//C_NULL_CHAR
|
||||
ptr4 = C_LOC(stderr(1:1))
|
||||
func_ptr = C_FUNLOC(custom_print_cb)
|
||||
|
||||
CALL h5ewalk_f(estack_id, H5E_WALK_UPWARD_F, func_ptr, ptr4, error)
|
||||
CALL check("h5ewalk_f", error, total_error)
|
||||
|
||||
CALL h5eget_num_f(estack_id, count, error)
|
||||
CALL check("h5eget_num_f", error, total_error)
|
||||
CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error)
|
||||
|
||||
CALL H5Ecreate_stack_f(estack_id2, error)
|
||||
CALL check("H5Ecreate_stack_f", error, total_error)
|
||||
|
||||
CALL H5Eappend_stack_f(estack_id2, estack_id, .FALSE., error)
|
||||
CALL check("H5Eappend_stack_f", error, total_error)
|
||||
|
||||
CALL h5eget_num_f(estack_id2, count, error)
|
||||
CALL check("h5eget_num_f", error, total_error)
|
||||
CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error)
|
||||
|
||||
! Copy error stack, which clears the original
|
||||
CALL H5Eget_current_stack_f(estack_id1, error)
|
||||
CALL check("H5Eget_current_stack_f", error, total_error)
|
||||
|
||||
CALL h5eget_num_f(estack_id1, count, error)
|
||||
CALL check("h5eget_num_f", error, total_error)
|
||||
CALL VERIFY("h5eget_num_f", count, 0_SIZE_T, total_error)
|
||||
|
||||
CALL H5Eclose_stack_f(estack_id2, error)
|
||||
CALL check(" H5Eclose_stack_f", error, total_error)
|
||||
|
||||
CALL H5Eclose_stack_f(estack_id, error)
|
||||
CALL check("H5Eclose_stack_f", error, total_error)
|
||||
|
||||
CALL H5Eclose_stack_f(estack_id1, error)
|
||||
CALL check("H5Eclose_stack_f", error, total_error)
|
||||
|
||||
CALL h5ecreate_stack_f(estack_id1, error)
|
||||
CALL check("h5ecreate_stack_f", error, total_error)
|
||||
|
||||
! push a custom error message onto the stack
|
||||
CALL H5Epush_f(estack_id1, cls_id, major, minor, "%s ERROR TEXT %s"//C_NEW_LINE, error, &
|
||||
ptr1, ptr2, ptr3, &
|
||||
arg1=ACHAR(27)//"[31m", arg2=ACHAR(27)//"[0m" )
|
||||
CALL check("H5Epush_f", error, total_error)
|
||||
|
||||
CALL H5Eset_current_stack_f(estack_id1, error) ! API will also close estack_id1
|
||||
CALL check("H5Eset_current_stack_f", error, total_error)
|
||||
|
||||
CALL h5eget_num_f(H5E_DEFAULT_F, count, error)
|
||||
CALL check("h5eget_num_f", error, total_error)
|
||||
CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error)
|
||||
|
||||
CALL h5epop_f(H5E_DEFAULT_F, 1_size_t, total_error)
|
||||
CALL check("h5epop_f", error, total_error)
|
||||
|
||||
CALL h5eget_num_f(H5E_DEFAULT_F, count, error)
|
||||
CALL check("h5eget_num_f", error, total_error)
|
||||
CALL VERIFY("h5eget_num_f", count, 0_SIZE_T, total_error)
|
||||
|
||||
CALL H5Eclose_msg_f(major, error)
|
||||
CALL check("H5Eclose_msg_f", error, total_error)
|
||||
|
||||
CALL H5Eclose_msg_f(minor, error)
|
||||
CALL check("H5Eclose_msg_f", error, total_error)
|
||||
|
||||
CALL h5eunregister_class_f(cls_id, error)
|
||||
CALL check("H5Eunregister_class_f", error, total_error)
|
||||
|
||||
END SUBROUTINE test_error_stack
|
||||
|
||||
END MODULE TH5E_F03
|
||||
|
||||
@ -308,9 +308,12 @@ CONTAINS
|
||||
! Clear the error stack from the file close failure
|
||||
CALL h5eset_auto_f(1, error)
|
||||
CALL h5eclear_f(error)
|
||||
CALL check("h5eclear_f",error,total_error)
|
||||
CALL h5eclear_f(error, H5P_DEFAULT_F)
|
||||
CALL check("h5eclear_f",error,total_error)
|
||||
|
||||
if(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error)
|
||||
CALL check("h5_cleanup_f", error, total_error)
|
||||
IF(cleanup) CALL h5_cleanup_f(filename, H5P_DEFAULT_F, error)
|
||||
CALL check("h5_cleanup_f", error, total_error)
|
||||
|
||||
RETURN
|
||||
END SUBROUTINE identifier_test
|
||||
|
||||
@ -55,6 +55,10 @@ PROGRAM PROG_FC_HAVE_F2003_REQUIREMENTS
|
||||
ptr = C_LOC(ichr(1:1))
|
||||
END PROGRAM PROG_FC_HAVE_F2003_REQUIREMENTS
|
||||
|
||||
PROGRAM PROG_CHAR_ALLOC
|
||||
CHARACTER(:), ALLOCATABLE :: str
|
||||
END PROGRAM PROG_CHAR_ALLOC
|
||||
|
||||
!---- START ----- Check to see C_BOOL is different from LOGICAL
|
||||
MODULE l_type_mod
|
||||
USE ISO_C_BINDING
|
||||
|
||||
@ -106,6 +106,18 @@ AC_DEFUN([PAC_PROG_FC_STORAGE_SIZE],[
|
||||
|
||||
])
|
||||
|
||||
dnl See if the fortran compiler supports allocatable character
|
||||
|
||||
AC_DEFUN([PAC_HAVE_CHAR_ALLOC],[
|
||||
HAVE_CHAR_ALLOC_FORTRAN="no"
|
||||
AC_MSG_CHECKING([if Fortran compiler supports allocatable character])
|
||||
TEST_SRC="`sed -ne '/PROGRAM PROG_CHAR_ALLOC/,/END PROGRAM PROG_CHAR_ALLOC/p' $srcdir/m4/aclocal_fc.f90`"
|
||||
AC_LINK_IFELSE([$TEST_SRC], [AC_MSG_RESULT([yes])
|
||||
HAVE_CHAR_ALLOC_FORTRAN="yes"],
|
||||
[AC_MSG_RESULT([no])])
|
||||
|
||||
])
|
||||
|
||||
dnl Check to see C_LONG_DOUBLE is available
|
||||
|
||||
AC_DEFUN([PAC_PROG_FC_HAVE_C_LONG_DOUBLE],[
|
||||
|
||||
@ -406,7 +406,13 @@ New Features
|
||||
Fortran Library:
|
||||
----------------
|
||||
|
||||
- Add API support for Fortran MPI_F08 module definitions:
|
||||
- Added Fortran H5E APIs:
|
||||
h5eregister_class_f, h5eunregister_class_f, h5ecreate_msg_f, h5eclose_msg_f
|
||||
h5eget_msg_f, h5epush_f, h5eget_num_f, h5ewalk_f, h5eget_class_name_f,
|
||||
h5eappend_stack_f, h5eget_current_stack_f, h5eset_current_stack_f, h5ecreate_stack_f,
|
||||
h5eclose_stack_f, h5epop_f, h5eprint_f (C h5eprint v2 signature)
|
||||
|
||||
- Added API support for Fortran MPI_F08 module definitions:
|
||||
Adds support for MPI's MPI_F08 module datatypes: type(MPI_COMM) and type(MPI_INFO) for HDF5 APIs:
|
||||
H5PSET_FAPL_MPIO_F, H5PGET_FAPL_MPIO_F, H5PSET_MPI_PARAMS_F, H5PGET_MPI_PARAMS_F
|
||||
Ref. #3951
|
||||
@ -1168,7 +1174,11 @@ Bug Fixes since HDF5-1.14.0 release
|
||||
|
||||
Fortran API
|
||||
-----------
|
||||
-
|
||||
- Fixed: HDF5 fails to compile with -Werror=lto-type-mismatch
|
||||
|
||||
Removed the use of the offending C stub wrapper.
|
||||
|
||||
Fixes GitHub issue #3987
|
||||
|
||||
|
||||
High-Level Library
|
||||
@ -1405,6 +1415,10 @@ Known Problems
|
||||
The subsetting option in ph5diff currently will fail and should be avoided.
|
||||
The subsetting option works correctly in serial h5diff.
|
||||
|
||||
Flang Fortran compilation will fail (last check version 17) due to not yet
|
||||
implemented: (1) derived type argument passed by value (H5VLff.F90),
|
||||
and (2) support for REAL with KIND = 2 in intrinsic SPACING used in testing.
|
||||
|
||||
Several tests currently fail on certain platforms:
|
||||
MPI_TEST-t_bigio fails with spectrum-mpi on ppc64le platforms.
|
||||
|
||||
|
||||
@ -250,12 +250,12 @@ H5_DLL herr_t H5Eclose_msg(hid_t err_id);
|
||||
* --------------------------------------------------------------------------
|
||||
* \ingroup H5E
|
||||
*
|
||||
* \brief Adds a major error message to an error class
|
||||
* \brief Adds a major or minor error message to an error class
|
||||
*
|
||||
* \param[in] cls An error class identifier
|
||||
* \param[in] msg_type The type of the error message
|
||||
* \param[in] msg Major error message
|
||||
* \return \herr_t
|
||||
* \param[in] msg Error message
|
||||
* \return An error ID (success), H5I_INVALID_HID (failure)
|
||||
*
|
||||
* \details H5Ecreate_msg() adds an error message to an error class defined by
|
||||
* client library or application program. The error message can be
|
||||
@ -625,7 +625,7 @@ H5_DLL herr_t H5Eauto_is_v2(hid_t err_stack, unsigned *is_stack);
|
||||
* \brief Retrieves an error message
|
||||
*
|
||||
* \param[in] msg_id Error message identifier
|
||||
* \param[out] type The type of the error message Valid values are #H5E_MAJOR
|
||||
* \param[out] type The type of the error message. Valid values are #H5E_MAJOR
|
||||
* and #H5E_MINOR.
|
||||
* \param[out] msg Error message buffer
|
||||
* \param[in] size The length of error message to be returned by this function
|
||||
@ -651,7 +651,8 @@ H5_DLL ssize_t H5Eget_msg(hid_t msg_id, H5E_type_t *type, char *msg, size_t size
|
||||
* \brief Retrieves the number of error messages in an error stack
|
||||
*
|
||||
* \estack_id{error_stack_id}
|
||||
* \return Returns a non-negative value on success; otherwise returns a negative value.
|
||||
* \return Returns number of error messages in an error stack on
|
||||
* success; otherwise returns a negative value.
|
||||
*
|
||||
* \details H5Eget_num() retrieves the number of error records in the error
|
||||
* stack specified by \p error_stack_id (including major, minor
|
||||
@ -916,7 +917,7 @@ H5_DLL herr_t H5Ewalk1(H5E_direction_t direction, H5E_walk1_t func, void *client
|
||||
* error number
|
||||
*
|
||||
* \param[in] maj Major error number
|
||||
* \return \herr_t
|
||||
* \return Pointer to the message (success), or NULL (failure)
|
||||
*
|
||||
* \deprecated 1.8.0 Function deprecated in this release.
|
||||
*
|
||||
@ -939,7 +940,7 @@ H5_DLL char *H5Eget_major(H5E_major_t maj);
|
||||
* error number
|
||||
*
|
||||
* \param[in] min Minor error number
|
||||
* \return \herr_t
|
||||
* \return Pointer to the message (success), or NULL (failure)
|
||||
*
|
||||
* \deprecated 1.8.0 Function deprecated and return type changed in this release.
|
||||
*
|
||||
|
||||
Loading…
Reference in New Issue
Block a user