scnc
/
quantum-espresso
mirror of https://gitlab.com/QEF/q-e.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
quantum-espresso/Modules/qeh5_module.f90

1163 lines
50 KiB
Fortran
Raw Permalink Blame History

!
! Copyright (C) 2016-2017 Quantum ESPRESSO Foundation
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!------------------------------------------------------
MODULE qeh5_base_module
!---------------------------------------------------
!! This module contains the basic interface for basic operation for
!! serial I/O in HDF5 format. The parallel interface remains in file
!! hdf5_qe.f90 file.
!
!! author N. Varini, P. Delugas.
!! Last revision June 2017
!
#if defined(__HDF5)
USE KINDS, ONLY: DP, sgl
USE hdf5
USE ISO_C_BINDING
IMPLICIT NONE
TYPE qeh5_hid
INTEGER(HID_T) :: id
END TYPE qeh5_hid
TYPE qeh5_file ! this one is also good for groups
INTEGER(HID_T) :: id
CHARACTER(LEN=256) :: name
END TYPE qeh5_file
!
TYPE qeh5_datatype
INTEGER(HID_T) :: id
INTEGER :: rank
INTEGER,ALLOCATABLE :: dims(:)
END TYPE qeh5_datatype
!
TYPE qeh5_dataspace
INTEGER(HID_T) :: id
INTEGER :: rank
INTEGER(HSIZE_T),ALLOCATABLE :: dims(:),maxdims(:)
INTEGER(HSIZE_T),ALLOCATABLE :: offset(:), count(:), stride(:), block(:)
END TYPE qeh5_dataspace
!
TYPE qeh5_dataset
INTEGER(HID_T) :: id
CHARACTER(LEN=256) :: name
TYPE(qeh5_datatype) :: datatype
TYPE(qeh5_dataspace) :: filespace
LOGICAL :: memspace_ispresent = .FALSE.
TYPE(qeh5_dataspace) :: memspace
END TYPE qeh5_dataset
INTERFACE qeh5_set_space
MODULE PROCEDURE qeh5_wplan_real, qeh5_wplan_complex, qeh5_wplan_complex_sp, qeh5_wplan_integer
END INTERFACE
INTERFACE qeh5_write_dataset
MODULE PROCEDURE qeh5_write_real, qeh5_write_real_2, qeh5_write_real_3, &
qeh5_write_complex, qeh5_write_complex_2,qeh5_write_complex_3, &
qeh5_write_complex_sp, &
qeh5_write_integer,qeh5_write_integer_2,qeh5_write_integer_3
END INTERFACE
INTERFACE qeh5_read_dataset
MODULE PROCEDURE qeh5_read_real, qeh5_read_complex, qeh5_read_complex_sp, qeh5_read_integer,&
qeh5_read_real_2, qeh5_read_complex_2, qeh5_read_integer_2,&
qeh5_read_real_3, qeh5_read_complex_3, qeh5_read_integer_3
END INTERFACE
INTERFACE qeh5_add_attribute
MODULE PROCEDURE add_attribute_i, add_array_attribute_i, add_attribute_r, add_array_attribute_r, &
add_attribute_string
END INTERFACE
INTERFACE qeh5_read_attribute
MODULE PROCEDURE read_real_attribute, read_real_array_attribute, read_string_attribute,&
read_integer_attribute, read_integer_array_attribute
END INTERFACE
INTERFACE qeh5_to_h5id
MODULE PROCEDURE get_dataset_hid, get_file_hid
END INTERFACE
INTERFACE qeh5_close
MODULE PROCEDURE qeh5_closefile, close_dataset
END INTERFACE
!
INTEGER(HID_T) :: H5_REALDP_TYPE
INTEGER(HID_T) :: H5_REALSP_TYPE
PRIVATE
PUBLIC :: qeh5_file, qeh5_dataset
PUBLIC :: initialize_hdf5, finalize_hdf5, qeh5_openfile, qeh5_close, qeh5_open_group, &
qeh5_open_dataset, qeh5_write_dataset, qeh5_read_dataset, qeh5_set_space , &
qeh5_add_attribute, qeh5_read_attribute, qeh5_set_file_hyperslab, &
qeh5_set_memory_hyperslab, qeh5_to_h5id
CONTAINS
!
!----------------------------------------------------------
SUBROUTINE initialize_hdf5()
!--------------------------------------------------------
IMPLICIT NONE
INTEGER :: ierr
CALL h5open_f(ierr)
H5_REALDP_TYPE = h5kind_to_type( DP, H5_REAL_KIND)
H5_REALSP_TYPE = h5kind_to_type( sgl, H5_REAL_KIND)
END SUBROUTINE initialize_hdf5
!-------------------------------
SUBROUTINE finalize_hdf5()
!------------------------------
IMPLICIT NONE
INTEGER :: ierr
CALL h5close_f(ierr )
END SUBROUTINE finalize_hdf5
!---------------------------------------------------
FUNCTION get_dataset_hid( h5_dataset ) RESULT (hid)
!-------------------------------------------------
IMPLICIT NONE
TYPE( qeh5_dataset ) :: h5_dataset
INTEGER (HID_T) :: hid
hid = h5_dataset%id
END FUNCTION get_dataset_hid
!---------------------------------------------------
FUNCTION get_file_hid( h5_file ) RESULT (hid)
!-------------------------------------------------
IMPLICIT NONE
TYPE( qeh5_file ) :: h5_file
INTEGER (HID_T) :: hid
hid = h5_file%id
END FUNCTION get_file_hid
!-------------------------------------------------------
SUBROUTINE qeh5_openfile(h5file, file, action , error)
!-----------------------------------------------------
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: file, action
INTEGER,OPTIONAL,INTENT(OUT) :: error
TYPE(qeh5_file), INTENT(OUT) :: h5file
!
INTEGER :: ierr, jerr
!
h5file%name=TRIM(file)
IF (PRESENT(error)) THEN
CALL H5Eset_auto_f( 0, ierr )
END IF
SELECT CASE(TRIM(action))
CASE ('write')
CALL H5Fcreate_f( TRIM(file), H5F_ACC_TRUNC_F, h5file%id , ierr )
CASE ('read' )
CALL H5Fopen_f ( TRIM (file), H5F_ACC_RDONLY_F, h5file%id, ierr )
CASE ( 'read-write')
CALL H5Fopen_f ( TRIM (file), H5F_ACC_RDWR_F, h5file%id, ierr)
CASE default
ierr =1
END SELECT
IF (present (error)) then
! success=0, fail=-1. QE error handling needs a positive error code.
error = abs(ierr)
ELSE IF ( ierr /=0 ) THEN
CALL H5Eprint_f( jerr )
stop
END IF
! //' with action '// trim(action), 1 )
END SUBROUTINE qeh5_openfile
!--------------------------------------------
SUBROUTINE qeh5_closefile ( h5file )
!-----------------------------------------
IMPLICIT NONE
TYPE( qeh5_file ),INTENT(INOUT) :: h5file
INTEGER :: h5type, ierr
!
CALL H5Iget_type_f(h5file%id, h5type, ierr )
IF ( h5type == H5I_FILE_F) THEN
CALL H5Fclose_f( h5file%id, ierr )
ELSE IF ( h5type == H5I_GROUP_F ) THEN
CALL H5Gclose_f( h5file%id, ierr )
ELSE
ierr = 1
END IF
h5file%name=""
END SUBROUTINE qeh5_closefile
!-------------------------------------------------
SUBROUTINE set_dataset_name(name, h5_dataset)
!-----------------------------------------------
IMPLICIT NONE
CHARACTER(LEN=256) :: name
TYPE (qeh5_dataset) :: h5_dataset
h5_dataset%name = TRIM(name)
END SUBROUTINE set_dataset_name
!-------------------------------------------------
SUBROUTINE close_dataset( h5_dataset )
!-----------------------------------------------
IMPLICIT NONE
TYPE ( qeh5_dataset ),INTENT(INOUT) :: h5_dataset
!
INTEGER :: ierr
!
!
IF ( ALLOCATED(h5_dataset%filespace%dims) ) DEALLOCATE (h5_dataset%filespace%dims)
IF ( ALLOCATED(h5_dataset%filespace%maxdims)) DEALLOCATE (h5_dataset%filespace%maxdims)
IF ( ALLOCATED(h5_dataset%filespace%offset)) DEALLOCATE (h5_dataset%filespace%offset)
IF ( ALLOCATED(h5_dataset%filespace%count) ) DEALLOCATE (h5_dataset%filespace%count)
IF ( ALLOCATED(h5_dataset%filespace%stride)) DEALLOCATE (h5_dataset%filespace%stride)
IF ( ALLOCATED(h5_dataset%filespace%block) ) DEALLOCATE (h5_dataset%filespace%block)
h5_dataset%filespace%rank=0
CALL H5Sclose_f(h5_dataset%filespace%id, ierr )
h5_dataset%filespace%id = -1_HID_T
IF (h5_dataset%memspace_ispresent) THEN
IF ( ALLOCATED(h5_dataset%memspace%dims) ) DEALLOCATE (h5_dataset%memspace%dims)
IF ( ALLOCATED(h5_dataset%memspace%maxdims)) DEALLOCATE (h5_dataset%memspace%maxdims)
IF ( ALLOCATED(h5_dataset%memspace%offset) ) DEALLOCATE (h5_dataset%memspace%offset)
IF ( ALLOCATED(h5_dataset%memspace%count) ) DEALLOCATE (h5_dataset%memspace%count)
IF ( ALLOCATED(h5_dataset%memspace%stride) ) DEALLOCATE (h5_dataset%memspace%stride)
IF ( ALLOCATED(h5_dataset%memspace%block) ) DEALLOCATE (h5_dataset%memspace%block)
h5_dataset%memspace_ispresent = .FALSE.
CALL H5Sclose_f(h5_dataset%memspace%id, ierr )
!!print '(A, " memspace closer returned ierr =" ,I4)', TRIM(h5_dataset%name) , ierr
h5_dataset%memspace%id = -1_HID_T
END IF
CALL H5Tclose_f( h5_dataset%datatype%id, ierr )
CALL H5Dclose_f( h5_dataset%id, ierr )
h5_dataset%name = ""
h5_dataset%datatype%id = -1_HID_T
END SUBROUTINE close_dataset
!-------------------------------------------------------------------
SUBROUTINE qeh5_open_group( h5_parent , group_name, h5_group)
!-----------------------------------------------------------------
IMPLICIT NONE
TYPE(qeh5_file),INTENT(IN) :: h5_parent
CHARACTER(LEN=*),INTENT(IN) :: group_name
TYPE(qeh5_file),INTENT(OUT) :: h5_group
!
INTEGER :: ierr, jerr
INTEGER(HID_T) :: loc_id, group_id
loc_id = h5_parent%id
CALL h5eset_auto_f(0, jerr )
CALL h5gopen_f ( loc_id, trim(group_name), group_id, ierr )
CALL h5eset_auto_f(1, jerr)
if (ierr /= 0 ) CALL h5gcreate_f ( loc_id, trim(group_name), group_id, ierr )
!
h5_group%name = trim(group_name)
h5_group%id = group_id
END SUBROUTINE qeh5_open_group
!----------------------------------------------------------------------------
SUBROUTINE qeh5_open_dataset ( h5_parent, h5_dataset, action , name, error )
!--------------------------------------------------------------------------
IMPLICIT NONE
TYPE(qeh5_file), INTENT(IN) :: h5_parent
CHARACTER(LEN=*),INTENT(IN) :: action
CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: name
INTEGER,OPTIONAL,INTENT(OUT) :: error
TYPE(qeh5_dataset) ,INTENT(INOUT) :: h5_dataset
!
INTEGER :: ierr, jerr, rank_
LOGICAL :: exists
IF (PRESENT(name) ) h5_dataset%name = TRIM(name)
SELECT CASE ( TRIM(action) )
CASE ('write')
CALL H5Lexists_f (h5_parent%id, TRIM(h5_dataset%name), exists, ierr )
IF ( exists ) CALL H5Ldelete_f ( h5_parent%id, TRIM(h5_dataset%name), ierr )
CALL H5Dcreate_f ( h5_parent%id, TRIM(h5_dataset%name) , h5_dataset%datatype%id, &
h5_dataset%filespace%id, h5_dataset%id, ierr )
!
!
CASE ( 'read', 'get_hid' )
CALL H5Lexists_f (h5_parent%id, TRIM(h5_dataset%name), exists, ierr )
IF ( exists ) THEN
CALL H5Dopen_f ( h5_parent%id, TRIM(h5_dataset%name), h5_dataset%id, ierr )
CALL H5Dget_space_f(h5_dataset%id, h5_dataset%filespace%id, ierr )
CALL H5Sget_simple_extent_ndims_f( h5_dataset%filespace%id, rank_ , ierr )
ALLOCATE( h5_dataset%filespace%dims( rank_ ) , h5_dataset%filespace%maxdims(rank_) )
h5_dataset%filespace%rank = rank_
CALL H5Sget_simple_extent_dims_f( h5_dataset%filespace%id, h5_dataset%filespace%dims, &
h5_dataset%filespace%maxdims, ierr )
CALL H5Dget_type_f(h5_dataset%id, h5_dataset%datatype%id, ierr )
ELSE
ierr = -1
END IF
CASE default
ierr = -1
END SELECT
IF ( PRESENT (error) )THEN
error = ierr
ELSE
CALL errore ( 'qeh5_open_datase', 'error opening dataset ' // &
h5_parent%name // '/'// name // ' with action= ' //TRIM(action), ierr )
END IF
END SUBROUTINE qeh5_open_dataset
!-------------------------------------------------------------------
SUBROUTINE prepare_dataspace( h5_dataset, rank, dimensions, mode )
!-----------------------------------------------------------------
IMPLICIT NONE
INTEGER,INTENT(IN) :: rank
INTEGER,INTENT(IN) :: dimensions(rank)
TYPE(qeh5_dataset),INTENT(INOUT) :: h5_dataset
CHARACTER(1),OPTIONAL,INTENT(IN) :: mode
!
INTEGER :: ierr
INTEGER(HID_T) :: dtype_hid
CHARACTER(1) :: what_data_space
!
what_data_space = 'f'
IF (PRESENT ( mode ) ) what_data_space = mode
SELECT CASE (what_data_space)
CASE ('m','M')
CALL block ( h5_dataset%memspace )
h5_dataset%memspace_ispresent = .true.
CASE DEFAULT
CALL block ( h5_dataset%filespace )
END SELECT
!
CONTAINS
!------------------------------------
SUBROUTINE block ( dataspace )
IMPLICIT NONE
TYPE(qeh5_dataspace ) :: dataspace
IF (ALLOCATED (dataspace%dims) ) DEALLOCATE ( dataspace%dims )
ALLOCATE(dataspace%dims(rank) )
dataspace%rank = rank
dataspace%dims(1:rank) = dimensions(1:rank)*1_HSIZE_T
CALL H5Screate_simple_f( rank, dataspace%dims, dataspace%id, ierr )
END SUBROUTINE block
!
END SUBROUTINE prepare_dataspace
!----------------------------------------------------------------------------
SUBROUTINE qeh5_wplan_real( h5_dataset, real_data, rank, dimensions, mode )
!--------------------------------------------------------------------------
IMPLICIT NONE
REAL(DP),INTENT(IN) :: real_data
INTEGER,INTENT(IN) :: rank
INTEGER,INTENT(IN) :: dimensions(rank)
TYPE(qeh5_dataset),INTENT(INOUT) :: h5_dataset
CHARACTER(1),OPTIONAL,INTENT(IN) :: mode
!
INTEGER :: ierr
!
CALL H5Tcopy_f ( H5T_IEEE_F64LE , h5_dataset%datatype%id , ierr )
!
IF ( PRESENT(mode) ) THEN
CALL prepare_dataspace( h5_dataset, rank, dimensions, mode )
ELSE
CALL prepare_dataspace( h5_dataset, rank, dimensions )
END IF
END SUBROUTINE qeh5_wplan_real
!-----------------------------------------------------------------------------------
SUBROUTINE qeh5_wplan_complex ( h5_dataset, complex_data, rank, dimensions, mode )
!---------------------------------------------------------------------------------
IMPLICIT NONE
COMPLEX(DP),INTENT(IN) :: complex_data
INTEGER,INTENT(IN) :: rank
INTEGER,INTENT(IN) :: dimensions(rank)
TYPE(qeh5_dataset),INTENT(INOUT) :: h5_dataset
CHARACTER(1),OPTIONAL,INTENT(IN) :: mode
!
INTEGER :: ierr
INTEGER,DIMENSION(24) :: dims
!
CALL H5Tcopy_f ( H5T_IEEE_F64LE , h5_dataset%datatype%id , ierr )
dims(1:rank) = dimensions(1:rank)
dims(1) = dims(1)*2
IF ( PRESENT( mode ) ) THEN
CALL prepare_dataspace( h5_dataset, rank, dims(1:rank), mode )
ELSE
CALL prepare_dataspace( h5_dataset, rank, dims(1:rank) )
END IF
END SUBROUTINE qeh5_wplan_complex
! NsC >>>
!-----------------------------------------------------------------------------------
SUBROUTINE qeh5_wplan_complex_sp ( h5_dataset, complex_data, rank, dimensions, mode )
!---------------------------------------------------------------------------------
IMPLICIT NONE
COMPLEX(sgl),INTENT(IN) :: complex_data
INTEGER,INTENT(IN) :: rank
INTEGER,INTENT(IN) :: dimensions(rank)
TYPE(qeh5_dataset),INTENT(INOUT) :: h5_dataset
CHARACTER(1),OPTIONAL,INTENT(IN) :: mode
!
INTEGER :: ierr
INTEGER,DIMENSION(24) :: dims
!
CALL H5Tcopy_f ( H5T_IEEE_F32LE , h5_dataset%datatype%id , ierr )
dims(1:rank) = dimensions(1:rank)
dims(1) = dims(1)*2
IF ( PRESENT( mode ) ) THEN
CALL prepare_dataspace( h5_dataset, rank, dims(1:rank), mode )
ELSE
CALL prepare_dataspace( h5_dataset, rank, dims(1:rank) )
END IF
END SUBROUTINE qeh5_wplan_complex_sp
! NsC <<<
!------------------------------------------------------------------------------------
SUBROUTINE qeh5_wplan_integer ( h5_dataset, integer_data, rank, dimensions, mode )
!----------------------------------------------------------------------------------
IMPLICIT NONE
INTEGER,TARGET,INTENT(IN) :: integer_data
INTEGER,INTENT(IN) :: rank
INTEGER,INTENT(IN) :: dimensions(rank)
TYPE( qeh5_dataset ),INTENT(INOUT) :: h5_dataset
CHARACTER(1),OPTIONAL,INTENT(IN) :: mode
!
INTEGER :: ierr
!
CALL H5Tcopy_f ( H5T_STD_I32LE, h5_dataset%datatype%id , ierr )
IF ( PRESENT (mode ) ) THEN
CALL prepare_dataspace( h5_dataset, rank, dimensions, mode )
ELSE
CALL prepare_dataspace( h5_dataset, rank, dimensions)
END IF
END SUBROUTINE qeh5_wplan_integer
!----------------------------------------------------------
SUBROUTINE qeh5_read_real ( real_data, h5_dataset)
!--------------------------------------------------------
IMPLICIT NONE
REAL(DP), TARGET, INTENT(INOUT) :: real_data(1)
TYPE (qeh5_dataset),INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: ptr
INTEGER(HID_T) :: mem_hid, file_hid
INTEGER :: ierr
ptr = C_LOC(real_data)
mem_hid = H5S_ALL_F
file_hid = H5S_ALL_F
IF (ALLOCATED(h5_dataset%filespace%offset)) file_hid = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent ) mem_hid = h5_dataset%memspace%id
CALL H5Dread_f( h5_dataset%id, h5_realdp_type, ptr, ierr, mem_hid, file_hid, H5P_DEFAULT_F )
!IF ( ierr /=0) CALL errore( 'qeh5_read_dataset', 'error reading '//TRIM(h5_descriptor%filename), ierr)
END SUBROUTINE qeh5_read_real
!----------------------------------------------------------
SUBROUTINE qeh5_read_real_2 ( real_data, h5_dataset)
!--------------------------------------------------------
IMPLICIT NONE
REAL(DP), TARGET, INTENT(INOUT) :: real_data(1,1)
TYPE (qeh5_dataset),INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: ptr
INTEGER(HID_T) :: mem_hid, file_hid
INTEGER :: ierr
ptr = C_LOC(real_data)
mem_hid = H5S_ALL_F
file_hid = H5S_ALL_F
IF (ALLOCATED(h5_dataset%filespace%offset)) file_hid = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent ) mem_hid = h5_dataset%memspace%id
CALL H5Dread_f( h5_dataset%id, h5_realdp_type, ptr, ierr, mem_hid, file_hid, H5P_DEFAULT_F )
!IF ( ierr /=0) CALL errore( 'qeh5_read_dataset', 'error reading '//TRIM(h5_descriptor%filename), ierr)
END SUBROUTINE qeh5_read_real_2
!----------------------------------------------------------
SUBROUTINE qeh5_read_real_3 ( real_data, h5_dataset)
!--------------------------------------------------------
IMPLICIT NONE
REAL(DP), TARGET, INTENT(INOUT) :: real_data(1,1,1)
TYPE (qeh5_dataset),INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: ptr
INTEGER(HID_T) :: mem_hid, file_hid
INTEGER :: ierr
ptr = C_LOC(real_data)
mem_hid = H5S_ALL_F
file_hid = H5S_ALL_F
IF (ALLOCATED(h5_dataset%filespace%offset)) file_hid = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent ) mem_hid = h5_dataset%memspace%id
CALL H5Dread_f( h5_dataset%id, h5_realdp_type, ptr, ierr, mem_hid, file_hid, H5P_DEFAULT_F )
!IF ( ierr /=0) CALL errore( 'qeh5_read_dataset', 'error reading '//TRIM(h5_descriptor%filename), ierr)
END SUBROUTINE qeh5_read_real_3
!----------------------------------------------------------
SUBROUTINE qeh5_read_complex ( complex_data, h5_dataset)
!--------------------------------------------------------
IMPLICIT NONE
COMPLEX(DP), TARGET, INTENT(INOUT) :: complex_data(1)
TYPE (qeh5_dataset),INTENT(IN) :: h5_dataset
INTEGER(HID_T) :: mem_hid, file_hid
!
TYPE(C_PTR) :: ptr
INTEGER :: ierr
ptr = C_LOC(complex_data)
file_hid = H5S_ALL_F
mem_hid = H5S_ALL_F
IF (ALLOCATED(h5_dataset%filespace%offset)) file_hid = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent ) mem_hid = h5_dataset%memspace%id
CALL H5Dread_f( h5_dataset%id, H5_REALDP_TYPE, ptr, ierr, mem_hid, file_hid, H5P_DEFAULT_F )
!IF ( ierr /=0) CALL errore( 'qeh5_read_dataset', 'error reading '//TRIM(h5_descriptor%filename), ierr)
END SUBROUTINE qeh5_read_complex
! NsC >>>
!----------------------------------------------------------
SUBROUTINE qeh5_read_complex_sp ( complex_data, h5_dataset)
!--------------------------------------------------------
IMPLICIT NONE
COMPLEX(sgl), TARGET, INTENT(INOUT) :: complex_data(1)
TYPE (qeh5_dataset),INTENT(IN) :: h5_dataset
INTEGER(HID_T) :: mem_hid, file_hid
!
TYPE(C_PTR) :: ptr
INTEGER :: ierr
ptr = C_LOC(complex_data)
file_hid = H5S_ALL_F
mem_hid = H5S_ALL_F
IF (ALLOCATED(h5_dataset%filespace%offset)) file_hid = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent ) mem_hid = h5_dataset%memspace%id
CALL H5Dread_f( h5_dataset%id, H5_REALSP_TYPE, ptr, ierr, mem_hid, file_hid, H5P_DEFAULT_F )
!IF ( ierr /=0) CALL errore( 'qeh5_read_dataset', 'error reading '//TRIM(h5_descriptor%filename), ierr)
END SUBROUTINE qeh5_read_complex_sp
! NsC <<<
!----------------------------------------------------------
SUBROUTINE qeh5_read_complex_2 ( complex_data, h5_dataset)
!--------------------------------------------------------
IMPLICIT NONE
COMPLEX(DP), TARGET, INTENT(INOUT) :: complex_data(1,1)
TYPE (qeh5_dataset),INTENT(IN) :: h5_dataset
INTEGER(HID_T) :: mem_hid, file_hid
!
TYPE(C_PTR) :: ptr
INTEGER :: ierr
ptr = C_LOC(complex_data)
file_hid = H5S_ALL_F
mem_hid = H5S_ALL_F
IF (ALLOCATED(h5_dataset%filespace%offset)) file_hid = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent ) mem_hid = h5_dataset%memspace%id
CALL H5Dread_f( h5_dataset%id, H5_REALDP_TYPE, ptr, ierr, mem_hid, file_hid, H5P_DEFAULT_F )
!IF ( ierr /=0) CALL errore( 'qeh5_read_dataset', 'error reading '//TRIM(h5_descriptor%filename), ierr)
END SUBROUTINE qeh5_read_complex_2
!----------------------------------------------------------
SUBROUTINE qeh5_read_complex_3 ( complex_data, h5_dataset)
!--------------------------------------------------------
IMPLICIT NONE
COMPLEX(DP), TARGET, INTENT(INOUT) :: complex_data(1,1,1)
TYPE (qeh5_dataset),INTENT(IN) :: h5_dataset
INTEGER(HID_T) :: mem_hid, file_hid
!
TYPE(C_PTR) :: ptr
INTEGER :: ierr
ptr = C_LOC(complex_data)
file_hid = H5S_ALL_F
mem_hid = H5S_ALL_F
IF (ALLOCATED(h5_dataset%filespace%offset)) file_hid = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent ) mem_hid = h5_dataset%memspace%id
CALL H5Dread_f( h5_dataset%id, H5_REALDP_TYPE, ptr, ierr, mem_hid, file_hid, H5P_DEFAULT_F )
!IF ( ierr /=0) CALL errore( 'qeh5_read_dataset', 'error reading '//TRIM(h5_descriptor%filename), ierr)
END SUBROUTINE qeh5_read_complex_3
!-----------------------------------------------------------
SUBROUTINE qeh5_read_integer ( integer_data, h5_dataset)
!---------------------------------------------------------
IMPLICIT NONE
INTEGER, TARGET, INTENT(INOUT) :: integer_data(1)
TYPE (qeh5_dataset),INTENT(IN) :: h5_dataset
INTEGER(HID_T) :: mem_hid, file_hid
!
TYPE(C_PTR) :: ptr
INTEGER :: ierr
LOGICAL :: is_valid
ptr = C_LOC(integer_data)
!
file_hid = H5S_ALL_F
mem_hid = H5S_ALL_F
IF (ALLOCATED(h5_dataset%filespace%offset)) file_hid = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent ) mem_hid = h5_dataset%memspace%id
CALL H5Dread_f( h5_dataset%id, H5T_NATIVE_INTEGER , ptr, ierr, mem_hid, file_hid, H5P_DEFAULT_F )
!IF ( ierr /=0) CALL errore( 'qeh5_read_dataset', 'error reading '//TRIM(h5_descriptor%filename), ierr)
END SUBROUTINE qeh5_read_integer
!-----------------------------------------------------------
SUBROUTINE qeh5_read_integer_2 ( integer_data, h5_dataset)
!---------------------------------------------------------
IMPLICIT NONE
INTEGER, TARGET, INTENT(INOUT) :: integer_data(1,1)
TYPE (qeh5_dataset),INTENT(IN) :: h5_dataset
INTEGER(HID_T) :: mem_hid, file_hid
!
TYPE(C_PTR) :: ptr
INTEGER :: ierr
LOGICAL :: is_valid
ptr = C_LOC(integer_data)
!
file_hid = H5S_ALL_F
mem_hid = H5S_ALL_F
IF (ALLOCATED(h5_dataset%filespace%offset)) file_hid = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent ) mem_hid = h5_dataset%memspace%id
CALL H5Dread_f( h5_dataset%id, H5T_NATIVE_INTEGER , ptr, ierr, mem_hid, file_hid, H5P_DEFAULT_F )
!IF ( ierr /=0) CALL errore( 'qeh5_read_dataset', 'error reading '//TRIM(h5_descriptor%filename), ierr)
END SUBROUTINE qeh5_read_integer_2
!-----------------------------------------------------------
SUBROUTINE qeh5_read_integer_3 ( integer_data, h5_dataset)
!---------------------------------------------------------
IMPLICIT NONE
INTEGER, TARGET, INTENT(INOUT) :: integer_data(1,1,1)
TYPE (qeh5_dataset),INTENT(IN) :: h5_dataset
INTEGER(HID_T) :: mem_hid, file_hid
!
TYPE(C_PTR) :: ptr
INTEGER :: ierr
LOGICAL :: is_valid
ptr = C_LOC(integer_data)
!
file_hid = H5S_ALL_F
mem_hid = H5S_ALL_F
IF (ALLOCATED(h5_dataset%filespace%offset)) file_hid = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent ) mem_hid = h5_dataset%memspace%id
CALL H5Dread_f( h5_dataset%id, H5T_NATIVE_INTEGER , ptr, ierr, mem_hid, file_hid, H5P_DEFAULT_F )
!IF ( ierr /=0) CALL errore( 'qeh5_read_dataset', 'error reading '//TRIM(h5_descriptor%filename), ierr)
END SUBROUTINE qeh5_read_integer_3
!--------------------------------------------------------
SUBROUTINE qeh5_write_real( real_data, h5_dataset )
!------------------------------------------------------
IMPLICIT NONE
REAL(DP), TARGET, INTENT(INOUT) :: real_data(1)
TYPE(qeh5_dataset),INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: buf
INTEGER :: ierr, jerr
INTEGER(HID_T) :: memspace_, filespace_
!
buf = C_LOC(real_data)
filespace_ = H5S_ALL_F
memspace_ = H5S_ALL_F
IF ( ALLOCATED (h5_dataset%filespace%offset) ) filespace_ = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent) memspace_ = h5_dataset%memspace%id
CALL H5Dwrite_f ( h5_dataset%id, H5_REALDP_TYPE, buf , ierr, memspace_,&
filespace_, H5P_DEFAULT_F )
END SUBROUTINE qeh5_write_real
!-------------------------------------------------------
SUBROUTINE qeh5_write_real_2( real_data, h5_dataset )
!-----------------------------------------------------
IMPLICIT NONE
REAL(DP), TARGET, INTENT(INOUT) :: real_data(1,1)
TYPE(qeh5_dataset),INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: buf
INTEGER :: ierr, jerr
INTEGER(HID_T) :: memspace_, filespace_
!
buf = C_LOC(real_data)
filespace_ = H5S_ALL_F
memspace_ = H5S_ALL_F
IF( ALLOCATED (h5_dataset%filespace%offset)) filespace_ = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent) memspace_ = h5_dataset%memspace%id
CALL H5Dwrite_f ( h5_dataset%id, H5_REALDP_TYPE, buf , ierr, memspace_,&
filespace_, H5P_DEFAULT_F )
END SUBROUTINE qeh5_write_real_2
SUBROUTINE qeh5_write_real_3( real_data, h5_dataset )
IMPLICIT NONE
REAL(DP), TARGET, INTENT(INOUT) :: real_data(1,1,1)
TYPE(qeh5_dataset),INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: buf
INTEGER :: ierr, jerr
INTEGER(HID_T) :: memspace_, filespace_
!
buf = C_LOC(real_data)
filespace_ = H5S_ALL_F
memspace_ = H5S_ALL_F
IF( ALLOCATED (h5_dataset%filespace%offset)) filespace_ = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent) memspace_ = h5_dataset%memspace%id
CALL H5Dwrite_f ( h5_dataset%id, H5_REALDP_TYPE, buf , ierr, memspace_,&
filespace_, H5P_DEFAULT_F )
END SUBROUTINE qeh5_write_real_3
!--------------------------------------------------------------
SUBROUTINE qeh5_write_complex( complex_data, h5_dataset )
!-------------------------------------------------------------
IMPLICIT NONE
COMPLEX(DP), TARGET, INTENT(IN) :: complex_data(1)
TYPE(qeh5_dataset),INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: buf
INTEGER :: ierr, jerr
INTEGER(HID_T) :: memspace_, filespace_
!
buf = C_LOC(complex_data)
memspace_ = H5S_ALL_F
filespace_ = H5S_ALL_F
IF ( ALLOCATED (h5_dataset%filespace%offset) ) filespace_ = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent) memspace_ = h5_dataset%memspace%id
CALL H5Dwrite_f ( h5_dataset%id, H5_REALDP_TYPE, buf , ierr, memspace_,&
filespace_, H5P_DEFAULT_F )
END SUBROUTINE qeh5_write_complex
! NsC >>>
!--------------------------------------------------------------
SUBROUTINE qeh5_write_complex_sp( complex_data, h5_dataset )
!-------------------------------------------------------------
IMPLICIT NONE
COMPLEX(sgl), TARGET, INTENT(IN) :: complex_data(1)
TYPE(qeh5_dataset),INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: buf
INTEGER :: ierr, jerr
INTEGER(HID_T) :: memspace_, filespace_
!
buf = C_LOC(complex_data)
memspace_ = H5S_ALL_F
filespace_ = H5S_ALL_F
IF ( ALLOCATED (h5_dataset%filespace%offset) ) filespace_ = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent) memspace_ = h5_dataset%memspace%id
CALL H5Dwrite_f ( h5_dataset%id, H5_REALSP_TYPE, buf , ierr, memspace_,&
filespace_, H5P_DEFAULT_F )
END SUBROUTINE qeh5_write_complex_sp
! NsC <<<
!------------------------------------------------------------
SUBROUTINE qeh5_write_complex_2( complex_data, h5_dataset )
!-----------------------------------------------------------
IMPLICIT NONE
COMPLEX(DP), TARGET, INTENT(INOUT) :: complex_data(1,1)
TYPE(qeh5_dataset),INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: buf
INTEGER :: ierr, jerr
INTEGER(HID_T) :: memspace_, filespace_
!
buf = C_LOC(complex_data)
memspace_ = H5S_ALL_F
filespace_ = H5S_ALL_F
IF (ALLOCATED (h5_dataset%filespace%offset)) filespace_ = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent) memspace_ = h5_dataset%memspace%id
CALL H5Dwrite_f ( h5_dataset%id, H5_REALDP_TYPE, buf , ierr, memspace_,&
filespace_ , H5P_DEFAULT_F )
END SUBROUTINE qeh5_write_complex_2
SUBROUTINE qeh5_write_complex_3( complex_data, h5_dataset )
IMPLICIT NONE
COMPLEX(DP), TARGET, INTENT(INOUT) :: complex_data(1,1,1)
TYPE(qeh5_dataset),INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: buf
INTEGER :: ierr, jerr
INTEGER(HID_T) :: memspace_, filespace_
!
buf = C_LOC(complex_data)
memspace_ = H5S_ALL_F
filespace_ = H5S_ALL_F
IF (ALLOCATED (h5_dataset%filespace%offset) ) filespace_ = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent) memspace_ = h5_dataset%memspace%id
CALL H5Dwrite_f ( h5_dataset%id, h5_realdp_type, buf , ierr, memspace_,&
filespace_ , H5P_DEFAULT_F )
END SUBROUTINE qeh5_write_complex_3
!----------------------------------------------------------
SUBROUTINE qeh5_write_integer( integer_data, h5_dataset )
!---------------------------------------------------------
IMPLICIT NONE
INTEGER, TARGET , INTENT(INOUT) :: integer_data(1)
TYPE(qeh5_dataset), INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: buf
INTEGER :: ierr, jerr
INTEGER(HID_T) :: memspace_, filespace_
!
buf = C_LOC(integer_data)
memspace_ = H5S_ALL_F
filespace_ = H5S_ALL_F
IF (ALLOCATED (h5_dataset%filespace%offset)) filespace_ = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent) memspace_ = h5_dataset%memspace%id
CALL H5Dwrite_f ( h5_dataset%id, H5T_NATIVE_INTEGER , buf , ierr, memspace_,&
filespace_ , H5P_DEFAULT_F )
END SUBROUTINE qeh5_write_integer
!-------------------------------------------------------------
SUBROUTINE qeh5_write_integer_2( integer_data, h5_dataset )
!------------------------------------------------------------
IMPLICIT NONE
INTEGER, TARGET , INTENT(INOUT) :: integer_data(1,1)
TYPE(qeh5_dataset), INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: buf
INTEGER :: ierr, jerr
INTEGER(HID_T) :: memspace_, filespace_
!
buf = C_LOC(integer_data)
memspace_ = H5S_ALL_F
filespace_ = H5S_ALL_F
IF (ALLOCATED (h5_dataset%filespace%offset)) filespace_ = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent) memspace_ = h5_dataset%memspace%id
CALL H5Dwrite_f ( h5_dataset%id, H5T_NATIVE_INTEGER , buf , ierr, memspace_,&
filespace_ , H5P_DEFAULT_F )
END SUBROUTINE qeh5_write_integer_2
!--------------------------------------------------------------
SUBROUTINE qeh5_write_integer_3( integer_data, h5_dataset )
!------------------------------------------------------------
IMPLICIT NONE
INTEGER, TARGET , INTENT(INOUT) :: integer_data(1,1,1)
TYPE(qeh5_dataset), INTENT(IN) :: h5_dataset
!
TYPE(C_PTR) :: buf
INTEGER :: ierr, jerr
INTEGER(HID_T) :: memspace_, filespace_
!
buf = C_LOC(integer_data)
memspace_ = H5S_ALL_F
filespace_ = H5S_ALL_F
IF (ALLOCATED (h5_dataset%filespace%offset)) filespace_ = h5_dataset%filespace%id
IF ( h5_dataset%memspace_ispresent) memspace_ = h5_dataset%memspace%id
CALL H5Dwrite_f ( h5_dataset%id, H5T_NATIVE_INTEGER , buf , ierr, memspace_,&
filespace_ , H5P_DEFAULT_F )
END SUBROUTINE qeh5_write_integer_3
!
!-------------------------------------------------------
SUBROUTINE add_attribute_string ( h5_hid, name, text)
!------------------------------------------------------
IMPLICIT NONE
INTEGER(HID_T),INTENT(IN) :: h5_hid
CHARACTER(LEN=*) :: name, text
TARGET :: text
!
INTEGER(HSIZE_T) :: text_length
INTEGER(HID_T) :: sp_id, attr_id, string_type
LOGICAL :: exists
INTEGER :: ierr
TYPE(C_PTR) :: buf
!
text_length = LEN(TRIM(text))*1_HSIZE_T
buf = c_loc(text)
CALL H5Screate_f( H5S_SCALAR_F, sp_id, ierr )
CALL H5Tcopy_f(H5T_FORTRAN_S1, string_type, ierr )
CALL H5Tset_size_f( string_type,text_length, ierr )
CALL H5Aexists_by_name_f(h5_hid, '.', trim(name), exists, ierr )
if (exists ) call H5Adelete_by_name_f( h5_hid, '.', trim(name), ierr )
!
call H5Acreate_f( h5_hid, trim(name), string_type, sp_id, attr_id, ierr)
call H5Awrite_f (attr_id, string_type, buf, ierr )
CALL H5Sclose_f(sp_id, ierr )
CALL H5Aclose_f(attr_id, ierr )
!
END SUBROUTINE add_attribute_string
!---------------------------------------------------------------------
SUBROUTINE add_array_attribute_i ( h5_hid, name, value, rank, dims )
!--------------------------------------------------------------------
IMPLICIT NONE
INTEGER(HID_T) ,INTENT(IN) :: h5_hid
CHARACTER(LEN=*),INTENT(IN) :: name
INTEGER,TARGET, INTENT(IN) :: value(:)
INTEGER,INTENT(IN) :: rank, dims(:)
CALL add_attribute_i ( h5_hid, name, value(1), rank, dims)
END SUBROUTINE add_array_attribute_i
!---------------------------------------------------------------
SUBROUTINE add_attribute_i ( h5_hid, name, value, rank, dims )
!------------------------------------------------------------
IMPLICIT NONE
INTEGER(HID_T) ,INTENT(IN) :: h5_hid
CHARACTER(LEN=*),INTENT(IN) :: name
INTEGER,TARGET, INTENT(IN) :: value
INTEGER,OPTIONAL, INTENT(IN) :: rank, dims(:)
INTEGER(HID_T) :: loc_id, sp_id, attr_id, data_type, mem_type
INTEGER(HSIZE_T),ALLOCATABLE :: hdims(:)
INTEGER :: ierr
LOGICAL :: exists
TYPE(C_PTR) :: buf
INTEGER :: i
!
buf = C_LOC(value)
IF (PRESENT(rank)) THEN
ALLOCATE(hdims(rank))
DO i =1, rank
hdims(i) =dims(i)*1_HSIZE_T
END DO
CALL H5Tarray_create_f( H5T_STD_I32LE , rank, hdims, data_type, ierr )
CALL H5Tarray_create_f( H5T_NATIVE_INTEGER, rank, hdims, mem_type, ierr )
ELSE
CALL H5Tcopy_f( H5T_STD_I32LE,data_type, ierr)
CALL H5Tcopy_f( H5T_NATIVE_INTEGER, mem_type, ierr )
END IF
loc_id = h5_hid
CALL H5Screate_f ( H5S_SCALAR_F, sp_id, ierr )
CALL H5Aexists_by_name_f(loc_id, '.', trim(name), exists, ierr )
if (exists ) call H5Adelete_by_name_f( loc_id, '.', trim(name), ierr )
!
CALL H5Acreate_f( loc_id, TRIM(name), data_type, sp_id, attr_id, ierr )
CALL H5Awrite_f (attr_id, mem_type, buf , ierr )
CALL H5Tclose_f(data_type, ierr)
CALL H5Tclose_f(mem_type, ierr)
CALL H5Sclose_f(sp_id, ierr )
CALL H5Aclose_f(attr_id, ierr )
END SUBROUTINE add_attribute_i
!-------------------------------------------------------------------
SUBROUTINE add_array_attribute_r ( h5_hid, name, value, rank, dims)
!---------------------------------------------------------------
IMPLICIT NONE
INTEGER(HID_T),INTENT(IN) :: h5_hid
CHARACTER(LEN=*),INTENT(IN) :: name
REAL(8),TARGET, INTENT(IN) :: value(:)
INTEGER,INTENT(IN) :: rank, dims(:)
CALL add_attribute_r( h5_hid, name, value(1), rank, dims )
END SUBROUTINE add_array_attribute_r
!---------------------------------------------------------------
SUBROUTINE add_attribute_r ( h5_hid, name, value, rank, dims )
!-----------------------------------------------------------
IMPLICIT NONE
INTEGER(HID_T),INTENT(IN) :: h5_hid
CHARACTER(LEN=*),INTENT(IN) :: name
REAL(8),TARGET, INTENT(IN) :: value
INTEGER,OPTIONAL,INTENT(IN) :: rank, dims(:)
!
INTEGER(HID_T) :: loc_id, sp_id, attr_id, data_type, real8_type, mem_type
LOGICAL :: exists
INTEGER(HSIZE_T),ALLOCATABLE :: hdims(:)
INTEGER :: ierr
TYPE(C_PTR) :: buf
INTEGER :: i
!
loc_id = h5_hid
buf = C_LOC(value)
IF (PRESENT(rank) ) THEN
ALLOCATE(hdims(rank))
DO i =1, rank
hdims(i) =dims(i)*1_HSIZE_T
END DO
CALL H5Tarray_create_f(H5T_IEEE_F64LE, rank, hdims, data_type, ierr)
CALL H5Tarray_create_f(H5_REALDP_TYPE, rank, hdims, mem_type, ierr )
ELSE
CALL H5Tcopy_f(H5T_IEEE_F64LE, data_type, ierr)
CALL H5Tcopy_f(H5_REALDP_TYPE, mem_type, ierr)
END IF
CALL H5Screate_f( H5S_SCALAR_F, sp_id, ierr )
CALL H5Aexists_by_name_f(loc_id, '.', trim(name), exists, ierr )
if (exists ) call H5Adelete_by_name_f( loc_id, '.', trim(name), ierr )
CALL H5Acreate_f( loc_id, TRIM(name), data_type, sp_id, attr_id, ierr )
!
!
CALL H5Awrite_f (attr_id, mem_type, buf , ierr )
!
CALL H5Tclose_f(mem_type, ierr)
CALL H5Tclose_f(data_type, ierr)
CALL H5Sclose_f(sp_id, ierr)
CALL H5Aclose_f(attr_id, ierr)
END SUBROUTINE add_attribute_r
!-------------------------------------------------------------------------------------
SUBROUTINE read_integer_array_attribute ( h5_hid, attribute, value, rank, dimensions)
!----------------------------------------------------------------------------------
IMPLICIT NONE
INTEGER(HID_T) , INTENT(IN) :: h5_hid
CHARACTER(LEN=*),INTENT(IN) :: attribute
INTEGER,TARGET,INTENT(OUT) :: value(:)
INTEGER, TARGET,INTENT(IN) :: rank, dimensions(:)
!
!
CALL read_integer_attribute( h5_hid, attribute, value(1), rank, dimensions)
END SUBROUTINE read_integer_array_attribute
!-------------------------------------------------------------------------------
SUBROUTINE read_integer_attribute ( h5_hid, attribute, value, rank, dimensions)
!----------------------------------------------------------------------------
IMPLICIT NONE
INTEGER(HID_T) , INTENT(IN) :: h5_hid
CHARACTER(LEN=*),INTENT(IN) :: attribute
INTEGER,TARGET,INTENT(OUT) :: value
INTEGER,OPTIONAL, INTENT(IN) :: rank, dimensions(:)
!
INTEGER(HID_T) :: loc_id, attr_id, data_type, mem_type
INTEGER(HSIZE_T),ALLOCATABLE :: hdims(:)
INTEGER :: i, ierr
TYPE(C_PTR) :: buf
!
loc_id = h5_hid
buf = C_LOC(value)
IF (PRESENT (rank ) ) THEN
ALLOCATE(hdims(rank))
DO i =1, rank
hdims(i) =dimensions(i)*1_HSIZE_T
END DO
CALL H5Tarray_create_f(H5T_NATIVE_INTEGER, rank, hdims, mem_type, ierr )
ELSE
CALL H5Tcopy_f( H5T_NATIVE_INTEGER, mem_type, ierr )
END IF
!
!
CALL H5Aopen_by_name_f( loc_id, '.', TRIM(attribute), attr_id, ierr)
CALL H5Aread_f( attr_id, mem_type, buf, ierr )
!
CALL H5Tclose_f( mem_type, ierr)
CALL H5Aclose_f( attr_id, ierr)
!
END SUBROUTINE read_integer_attribute
!------------------------------------------------------------------------------------
SUBROUTINE read_real_array_attribute ( h5_hid, attribute, value, rank, dimensions )
!---------------------------------------------------------------------------------
IMPLICIT NONE
INTEGER(HID_T), INTENT(IN) :: h5_hid
CHARACTER(LEN=*),INTENT(IN) :: attribute
REAL(8),TARGET,INTENT(OUT) :: value(:)
INTEGER, INTENT(IN) :: rank, dimensions(:)
!
CALL read_real_attribute ( h5_hid, attribute, value(1), rank, dimensions)
END SUBROUTINE read_real_array_attribute
!------------------------------------------------------------------------------
SUBROUTINE read_real_attribute ( h5_hid, attribute, value, rank, dimensions)
!--------------------------------------------------------------------------
IMPLICIT NONE
INTEGER(HID_T), INTENT(IN) :: h5_hid
CHARACTER(LEN=*),INTENT(IN) :: attribute
REAL(8),TARGET,INTENT(OUT) :: value
INTEGER,OPTIONAL, INTENT(IN) :: rank, dimensions(:)
!
INTEGER(HID_T) :: loc_id, attr_id, data_type, mem_type
INTEGER(HSIZE_T),ALLOCATABLE :: hdims(:)
INTEGER :: i, ierr
TYPE(C_PTR) :: buf
!
loc_id = h5_hid
buf = C_LOC(value)
IF (PRESENT(rank) ) THEN
ALLOCATE(hdims(rank))
DO i =1, rank
hdims(i) =dimensions(i)*1_HSIZE_T
END DO
CALL H5Tarray_create_f( H5_REALDP_TYPE, rank, hdims, mem_type, ierr )
ELSE
CALL H5Tcopy_f(H5_REALDP_TYPE , mem_type, ierr)
END IF
!
!
CALL H5Aopen_by_name_f( loc_id, '.', TRIM(attribute), attr_id, ierr)
CALL H5Aread_f( attr_id, mem_type, buf, ierr )
!
CALL H5Tclose_f( mem_type, ierr)
CALL H5Aclose_f( attr_id, ierr)
!
END SUBROUTINE read_real_attribute
!-----------------------------------------------------------------
SUBROUTINE read_string_attribute(h5_hid, attribute, text, maxlen)
!--------------------------------------------------------------
IMPLICIT NONE
INTEGER(HID_T), INTENT(IN) :: h5_hid
CHARACTER(LEN=*),INTENT(IN) :: attribute
INTEGER,INTENT(IN) :: maxlen
CHARACTER(LEN=*),INTENT(OUT) :: text
!
INTEGER(HID_T) :: loc_id, attr_id, data_type
INTEGER(HSIZE_T) :: text_length
INTEGER :: i, ierr
TYPE(C_PTR) :: buf
CHARACTER,TARGET,ALLOCATABLE :: chars(:)
!
!
!
loc_id = h5_hid
text=""
ALLOCATE(chars(maxlen))
buf = C_LOC(chars)
CALL H5Aopen_by_name_f( loc_id, '.', trim(attribute), attr_id, ierr)
CALL H5Aget_type_f( attr_id, data_type, ierr)
CALL H5Tget_size_f( data_type, text_length, ierr)
IF ( text_length > maxlen*1_HSIZE_T) &
CALL infomsg (TRIM (attribute) // ' text too long will be truncated on reading')
CALL H5Aread_f( attr_id, data_type, buf, ierr )
DO I = 1, maxlen
IF (i > text_length) EXIT
text(i:i) = chars(i)
END DO
!
DEALLOCATE(chars)
buf = C_NULL_PTR
CALL H5Tclose_f( data_type, ierr)
CALL H5Aclose_f( attr_id, ierr)
!
END SUBROUTINE read_string_attribute
!--------------------------------------------------------------------
SUBROUTINE set_hyperslab (dataspace, offset, count, stride, block )
!-----------------------------------------------------------------
IMPLICIT NONE
TYPE(qeh5_dataspace),INTENT(INOUT) :: dataspace
INTEGER,DIMENSION(:),INTENT(IN) :: offset, count
INTEGER,DIMENSION(:),OPTIONAL, INTENT(IN) :: stride, block
!
INTEGER :: rank, ierr
rank = dataspace%rank
!
IF (ALLOCATED(dataspace%offset) ) DEALLOCATE (dataspace%offset)
IF (ALLOCATED(dataspace%count ) ) DEALLOCATE (dataspace%count)
IF (ALLOCATED(dataspace%stride) ) DEALLOCATE (dataspace%stride)
IF (ALLOCATED(dataspace%block ) ) DEALLOCATE (dataspace%block)
ALLOCATE ( dataspace%offset(rank), dataspace%count(rank))
IF (PRESENT(block) ) ALLOCATE ( dataspace%block(rank))
IF (PRESENT(stride)) ALLOCATE ( dataspace%stride(rank))
!
dataspace%offset(1:rank) = offset(1:rank) * 1_HSIZE_T
dataspace%count (1:rank) = count (1:rank) * 1_HSIZE_T
IF (PRESENT(stride) ) dataspace%stride(1:rank) = stride(1:rank) * 1_HSIZE_T
IF (PRESENT( block ) ) dataspace%block (1:rank) = block (1:rank) * 1_HSIZE_T
CALL H5Sselect_hyperslab_f( dataspace%id, H5S_SELECT_SET_F, dataspace%offset, dataspace%count, &
ierr, dataspace%stride, dataspace%block )
END SUBROUTINE set_hyperslab
!-------------------------------------------------------------------------------
SUBROUTINE qeh5_set_memory_hyperslab (dataset, offset, count, stride, block )
!----------------------------------------------------------------------------
IMPLICIT NONE
TYPE(qeh5_dataset),INTENT(INOUT) :: dataset
INTEGER,DIMENSION(:),INTENT(IN) :: offset, count
INTEGER,DIMENSION(:),OPTIONAL, INTENT(IN) :: stride, block
CALL set_hyperslab (dataset%memspace, offset, count, stride, block )
END SUBROUTINE qeh5_set_memory_hyperslab
!
SUBROUTINE qeh5_set_file_hyperslab (dataset, offset, count, stride, block )
IMPLICIT NONE
TYPE(qeh5_dataset),INTENT(INOUT) :: dataset
INTEGER,DIMENSION(:),INTENT(IN) :: offset, count
INTEGER,DIMENSION(:),OPTIONAL, INTENT(IN) :: stride, block
CALL set_hyperslab (dataset%filespace, offset, count, stride, block )
END SUBROUTINE qeh5_set_file_hyperslab
#endif
END MODULE qeh5_base_module
Reference in New Issue View Git Blame Copy Permalink