From efc837e88f998aa33045a54d33a871597505a28f Mon Sep 17 00:00:00 2001 From: Christopher Albert Date: Fri, 27 Mar 2026 21:13:47 +0100 Subject: [PATCH] Wrap libneo hdf5_tools in KAMEL --- CMakeLists.txt | 14 + PreProc/fourier/CMakeLists.txt | 8 +- QL-Balance/CMakeLists.txt | 2 +- common/equil/CMakeLists.txt | 2 +- common/hdf5_tools/CMakeLists.txt | 16 +- common/hdf5_tools/hdf5_tools.f90 | 1708 +----------------------------- 6 files changed, 54 insertions(+), 1696 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 7d1daed0..edcec408 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -99,6 +99,20 @@ endif() list(APPEND CMAKE_MODULE_PATH ${CMAKE_SOURCE_DIR}/cmake) +# Fetch libneo once at the top level so every KAMEL subproject uses the same +# build tree and module directory. +set(LIBNEO_BUILD_TESTING OFF CACHE BOOL "Disable libneo tests" FORCE) +set(LIBNEO_ENABLE_TESTS OFF CACHE BOOL "Disable libneo tests" FORCE) +set(LIBNEO_ENABLE_GOLDEN_TESTS OFF CACHE BOOL "Disable libneo golden tests" FORCE) +set(_KAMEL_BUILD_TESTING_SAVED ${BUILD_TESTING}) +set(BUILD_TESTING OFF) +if(NOT TARGET LIBNEO::magfie) + find_or_fetch(libneo) +endif() +set(BUILD_TESTING ${_KAMEL_BUILD_TESTING_SAVED}) +set(KAMEL_LIBNEO_BINARY_DIR "${CMAKE_CURRENT_BINARY_DIR}/libneo" CACHE INTERNAL + "Binary dir for the shared libneo subproject") + # Unified build: add subprojects for KiLCA, KIM, and QL-Balance add_subdirectory(common/math) add_subdirectory(common/logger) diff --git a/PreProc/fourier/CMakeLists.txt b/PreProc/fourier/CMakeLists.txt index 6e6337f6..7dd53121 100644 --- a/PreProc/fourier/CMakeLists.txt +++ b/PreProc/fourier/CMakeLists.txt @@ -20,11 +20,11 @@ include(Util) # Only fetch libneo if not already available (prevents duplicate targets) if(NOT TARGET LIBNEO::magfie) find_or_fetch(libneo) - include_directories(${CMAKE_CURRENT_BINARY_DIR}/libneo/include) + set(_FOURIER_LIBNEO_BINARY_DIR "${CMAKE_CURRENT_BINARY_DIR}/libneo") else() - # Use libneo from common/equil when building as part of KAMEL - include_directories(${CMAKE_BINARY_DIR}/common/equil/libneo/include) + set(_FOURIER_LIBNEO_BINARY_DIR "${KAMEL_LIBNEO_BINARY_DIR}") endif() +include_directories(${_FOURIER_LIBNEO_BINARY_DIR}/include) # Add netcdf library paths (needed because libneo's link_directories doesn't propagate) find_program(NF_CONFIG "nf-config") @@ -62,7 +62,7 @@ if(TARGET kamel_equil) LIBNEO::magfie ) target_include_directories(fouriermodes PUBLIC - ${CMAKE_BINARY_DIR}/common/equil/libneo/include + ${_FOURIER_LIBNEO_BINARY_DIR}/include ${KAMEL_EQUIL_INCLUDE_DIRS} ) else() diff --git a/QL-Balance/CMakeLists.txt b/QL-Balance/CMakeLists.txt index e42b5212..88b2485d 100644 --- a/QL-Balance/CMakeLists.txt +++ b/QL-Balance/CMakeLists.txt @@ -137,7 +137,7 @@ set(LIBNEO_BUILD_TESTING OFF CACHE BOOL "Disable libneo tests" FORCE) if(NOT TARGET LIBNEO::neo) find_or_fetch(libneo) endif() -include_directories(${CMAKE_CURRENT_BINARY_DIR}/../libneo/include) +include_directories(${KAMEL_LIBNEO_BINARY_DIR}/include) add_dependencies(ql-balance_lib sparse) diff --git a/common/equil/CMakeLists.txt b/common/equil/CMakeLists.txt index 287b26d8..65373e8f 100644 --- a/common/equil/CMakeLists.txt +++ b/common/equil/CMakeLists.txt @@ -67,7 +67,7 @@ set_target_properties(kamel_equil PROPERTIES target_include_directories(kamel_equil PUBLIC ${EQUIL_MODULE_DIR} - ${CMAKE_CURRENT_BINARY_DIR}/libneo/include + ${KAMEL_LIBNEO_BINARY_DIR}/include ) # Link libneo magfie for equilibrium field functionality diff --git a/common/hdf5_tools/CMakeLists.txt b/common/hdf5_tools/CMakeLists.txt index c9376d36..4e6fb422 100644 --- a/common/hdf5_tools/CMakeLists.txt +++ b/common/hdf5_tools/CMakeLists.txt @@ -1,40 +1,30 @@ -# HDF5 tools library for KAMEL project -# Provides common HDF5 wrapper functions for all KAMEL codes - -# Find HDF5 with Fortran support cmake_policy(SET CMP0074 NEW) find_package(HDF5 REQUIRED COMPONENTS Fortran Fortran_HL) -if (NOT ${HDF5_FOUND}) - message(FATAL_ERROR "HDF5 with Fortran support not found. Please set environment variable HDF5_ROOT to the correct path") -endif() - -# Create the HDF5 tools library add_library(kamel_hdf5_tools STATIC hdf5_tools.f90 hdf5_tools_f2003.f90 ) -# Set properties for the library set_target_properties(kamel_hdf5_tools PROPERTIES POSITION_INDEPENDENT_CODE ON Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/modules ) -# Include directories +add_dependencies(kamel_hdf5_tools LIBNEO::hdf5_tools) target_include_directories(kamel_hdf5_tools PUBLIC ${HDF5_INCLUDE_DIRS} + ${KAMEL_LIBNEO_BINARY_DIR}/include ${CMAKE_BINARY_DIR}/modules ) -# Link HDF5 libraries target_link_libraries(kamel_hdf5_tools PUBLIC + LIBNEO::hdf5_tools ${HDF5_Fortran_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ) -# Export for use by other KAMEL components set(KAMEL_HDF5_TOOLS_LIBRARIES kamel_hdf5_tools CACHE INTERNAL "KAMEL HDF5 tools library") set(KAMEL_HDF5_TOOLS_INCLUDE_DIRS ${CMAKE_BINARY_DIR}/modules CACHE INTERNAL "KAMEL HDF5 tools include directory") diff --git a/common/hdf5_tools/hdf5_tools.f90 b/common/hdf5_tools/hdf5_tools.f90 index 60b9622f..11fe52e7 100644 --- a/common/hdf5_tools/hdf5_tools.f90 +++ b/common/hdf5_tools/hdf5_tools.f90 @@ -1,573 +1,45 @@ module KAMEL_hdf5_tools - !********************************************************** - ! Compilation of useful HDF-5 wrapper functions - ! Date: 30.11.2015 - !********************************************************** + use hdf5, only: HID_T, HSIZE_T, SIZE_T, H5S_SELECT_SET_F, H5T_NATIVE_DOUBLE, & + h5dset_extent_f, h5screate_simple_f, h5dget_space_f, & + h5sselect_hyperslab_f, h5dwrite_f, h5sclose_f + use hdf5_tools - !********************************************************** - ! Include hdf5 module, hdf5 lite interface and - ! ISO_C_BINDING for long-integer support - !********************************************************** - use hdf5 - use h5lt implicit none - - !********************************************************** - ! Definition of complex type - !********************************************************** - integer, parameter :: dpp = kind(1.0d0) - integer, parameter :: dcp = dpp - type complex_t - real(kind=dpp) re - real(kind=dpp) im - end type complex_t - - !********************************************************** - ! Records the error code of the HDF-5 functions - !********************************************************** - integer :: h5error - - !********************************************************** - ! Overwrite existing datasets with h5_add? - !********************************************************** - logical :: h5overwrite = .false. - - !********************************************************** - ! Wrapper functions to add content - !********************************************************** - interface h5_add - module procedure h5_add_int - module procedure h5_add_int_1 - module procedure h5_add_int_1_nobounds - module procedure h5_add_int_2 - module procedure h5_add_int_2_nobounds - !module procedure h5_add_int8_2 - module procedure h5_add_double_0 - module procedure h5_add_double_1 - module procedure h5_add_double_1_nobounds - module procedure h5_add_float_1 - module procedure h5_add_double_2 - module procedure h5_add_double_3 - module procedure h5_add_double_4 - module procedure h5_add_double_5 - module procedure h5_add_complex_1 - module procedure h5_add_complex_2 - module procedure h5_add_string - module procedure h5_add_logical - end interface h5_add - - !********************************************************** - ! Wrapper functions to read content - !********************************************************** - interface h5_get - module procedure h5_get_int - module procedure h5_get_int_1 - module procedure h5_get_int_2 - !module procedure h5_get_int8_2 - module procedure h5_get_double_0 - module procedure h5_get_double_1 - module procedure h5_get_double_2 - module procedure h5_get_double_3 - module procedure h5_get_double_4 - module procedure h5_get_double_5 - module procedure h5_get_double_4_hyperslab - module procedure h5_get_complex_1 - module procedure h5_get_complex_2 - module procedure h5_get_logical - end interface h5_get - - !********************************************************** - ! Fortran supports arrays with arbitrary bounds. - ! Therefore, all h5_add functions save these boundaries. - !********************************************************** - interface h5_get_bounds - module procedure h5_get_bounds_1 - module procedure h5_get_bounds_2 - end interface h5_get_bounds - - !********************************************************** - ! Define unlimited dimension - !********************************************************** - interface h5_define_unlimited - module procedure h5_define_unlimited_array - module procedure h5_define_unlimited_matrix - end interface h5_define_unlimited - - !********************************************************** - ! Wrapper functions to append content to - ! unlimited dimensions - !********************************************************** - interface h5_append - module procedure h5_append_int_0 - module procedure h5_append_double_0 - module procedure h5_append_double_1 - module procedure h5_append_double_4 - end interface h5_append + public contains - !********************************************************** - ! Initialize HDF-5 Fortran interface - !********************************************************** - subroutine h5_init() - !write (*,*) "Initializing HDF5 interface" - call h5open_f(h5error) - call h5eset_auto_f(1, h5error) - end subroutine h5_init - - !********************************************************** - ! Deinitialize HDF-5 Fortran interface - !********************************************************** - subroutine h5_deinit() - !write (*,*) "Deinitializing HDF5 interface" - call h5close_f(h5error) - end subroutine h5_deinit - - !********************************************************** - ! Check error code - !********************************************************** - subroutine h5_check() - if (h5error < 0) then - write (*,*) "HDF5 Error" - call H5Eprint_f(h5error) - error stop - end if - end subroutine h5_check - - subroutine h5_disable_exceptions() - call h5eset_auto_f(0, h5error) - end subroutine h5_disable_exceptions - - subroutine h5_enable_exceptions() - call h5eset_auto_f(1, h5error) - end subroutine h5_enable_exceptions - - !********************************************************** - ! Create file - !********************************************************** - subroutine h5_create(filename, h5id, opt_fileformat_version) - character(len=*) :: filename - integer(HID_T) :: h5id - integer, optional :: opt_fileformat_version - - integer :: fileformat_version - - if (.not. present(opt_fileformat_version)) then - fileformat_version = 1 - else - fileformat_version = opt_fileformat_version - end if - - write (*,*) "Creating HDF5 file: ", trim(filename) - call h5fcreate_f(filename, H5F_ACC_TRUNC_F, h5id, h5error) - call h5_add(h5id, 'version', fileformat_version) - call h5_check() - - end subroutine h5_create - - !********************************************************** - ! Close file - !********************************************************** - subroutine h5_close(h5id) - integer(HID_T) :: h5id - - call h5fclose_f(h5id, h5error) - end subroutine h5_close - - !********************************************************** - ! Open file if exists - !********************************************************** - subroutine h5_open(filename, h5id) - character(len=*) :: filename - integer(HID_T) :: h5id - logical :: f_exists - - !write (*,*) "Opening HDF5 file: ", trim(filename) - - inquire (file=filename, exist=f_exists) - if (f_exists) then - call h5fopen_f(trim(filename), H5F_ACC_RDONLY_F, h5id, h5error) - else - write (*,*) "HDF5 file does not exist:", filename - error stop - end if - end subroutine h5_open - - !********************************************************** - ! Open file to read-write - !********************************************************** - subroutine h5_open_rw(filename, h5id, opt_fileformat_version) - character(len=*) :: filename - integer(HID_T) :: h5id - logical :: f_exists - integer, optional :: opt_fileformat_version - integer :: fileformat_version - - !write (*,*) "Opening HDF5 file: ", filename - inquire (file=filename, exist=f_exists) - if (f_exists) then - call h5fopen_f(trim(filename), H5F_ACC_RDWR_F, h5id, h5error) - else - fileformat_version = 1 - if (present(opt_fileformat_version)) fileformat_version = opt_fileformat_version - call h5_create(filename, h5id, fileformat_version) - !write (*,*) "File does not exist!" - !error stop - end if - end subroutine h5_open_rw - - !********************************************************** - ! Define group - !********************************************************** - subroutine h5_define_group(h5id, grpname, h5grpid) - integer(HID_T) :: h5id - character(len=*) :: grpname - integer(HID_T) :: h5grpid - - call h5gcreate_f(h5id, trim(adjustl(grpname)), h5grpid, h5error) - call h5_check() - end subroutine h5_define_group - - !********************************************************** - ! Open group - !********************************************************** - subroutine h5_open_group(h5id, grpname, h5id_grp) - integer(HID_T) :: h5id - character(len=*) :: grpname - integer(HID_T) :: h5id_grp - - !write (*,*) "Opening group ", grpname, "." - call h5gopen_f(h5id, trim(adjustl(grpname)), h5id_grp, h5error) - call h5_check() - end subroutine h5_open_group - - !********************************************************** - ! Close group. This is important since - ! there is a limited number of open groups at one time - !********************************************************** - subroutine h5_close_group(h5id_grp) - integer(HID_T) :: h5id_grp - - call h5gclose_f(h5id_grp, h5error) - end subroutine h5_close_group - - !********************************************************** - ! Get number of group members. Useful to iterate - ! over all groups - !********************************************************** - subroutine h5_get_nmembers(h5id, grpname, nmembers) - integer(HID_T) :: h5id - character(len=*) :: grpname - integer :: nmembers - - call h5gn_members_f(h5id, grpname, nmembers, h5error) - end subroutine h5_get_nmembers - - !********************************************************** - ! Get information about an object. Is it a group, - ! a variable, an attribute, ... - !********************************************************** - subroutine h5_get_objinfo(h5id, grpname, idx, objname, type_obj) - integer(HID_T) :: h5id - character(len=*) :: grpname, objname - integer :: idx - integer :: type_obj - - call h5gget_obj_info_idx_f(h5id, grpname , idx, objname, type_obj, & - & h5error) - end subroutine h5_get_objinfo - - function h5_isvalid(h5id) result(valid) - integer(HID_T) :: h5id - logical :: valid - - call h5iis_valid_f(h5id, valid, h5error) - call h5_check() - end function h5_isvalid - - subroutine h5_obj_exists(h5id, name_obj, exists) - integer(HID_T) :: h5id - character(len=*) :: name_obj - logical :: exists - !integer :: storage_type, nlinks, max_corder - - !call h5_disable_exceptions() - !call h5gget_info_by_name_f(h5id, trim(name), & - ! storage_type, nlinks, max_corder, h5error) - !exists = h5error .eq. 0 - !call h5_enable_exceptions() - exists = h5_exists(h5id, name_obj) - end subroutine h5_obj_exists - - function h5_exists(h5id, name_obj) result(exists) - integer(HID_T) :: h5id - character(len=*) :: name_obj - logical :: exists - - call h5lexists_f(h5id, name_obj, exists, h5error) - call h5_check() - end function h5_exists - - subroutine h5_write_opened_obj_count(h5id) - integer(HID_T) :: h5id - integer(SIZE_T) :: obj_count - - call h5fget_obj_count_f(h5id, H5F_OBJ_ALL_F, obj_count, h5error) - write (*,*) "Opened HDF5 objects: ", obj_count - - end subroutine h5_write_opened_obj_count - - subroutine h5_delete(h5id, name_obj) - integer(HID_T) :: h5id - character(len=*) :: name_obj - logical :: exists - - !write (*,*) "Trying to delete ", name - call h5lexists_f(h5id, name_obj, exists, h5error) - if (exists) then - call h5ldelete_f(h5id, name_obj, h5error) - call h5_check() - end if - !write (*,*) exists - end subroutine h5_delete - - !********************************************************** - ! Helper routine to recursively create parent groups - ! for given dataset if they do not exist yet. - !********************************************************** - recursive subroutine h5_create_parent_groups(h5id, dataset) - integer(HID_T), intent(in) :: h5id - character(len = *), intent(in) :: dataset - integer :: sep - integer(HID_T) :: grp_id - - sep = index(dataset, '/') - if (sep > 1) then - if (h5_exists(h5id, dataset(:sep-1))) then - call h5_open_group(h5id, dataset(:sep-1), grp_id) - else - call h5_define_group(h5id, dataset(:sep-1), grp_id) - end if - if (len_trim(dataset) > sep) call h5_create_parent_groups(grp_id, dataset(sep+1:)) - call h5_close_group(grp_id) - end if - end subroutine h5_create_parent_groups - - !********************************************************** - ! Define matrix with unlimited dimensions. Used for - ! appending data with an unknown number of elements. - !********************************************************** - subroutine h5_define_unlimited_matrix(h5id, dataset, datatype, dims, dsetid) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer, dimension(:) :: dims - integer(HID_T) :: datatype - integer(HID_T) :: dsetid - - integer :: rank - integer(SIZE_T), dimension(:), allocatable :: maxdims, startdims - integer(HID_T) :: dspaceid - integer(HID_T) :: crp_list - integer :: k - - rank = size(dims,1) - allocate(maxdims(rank), startdims(rank)) - maxdims = dims - startdims = dims - - do k = lbound(maxdims,1), ubound(maxdims,1) - if (maxdims(k) == -1) maxdims(k) = H5S_UNLIMITED_F - if (maxdims(k) == -1) startdims(k) = 1 - end do - !write (*,*) "Defining chunk: ", startdims - call h5screate_simple_f(rank, startdims, dspaceid, h5error, maxdims) - call h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, h5error) - call h5pset_chunk_f(crp_list, rank, startdims, h5error) - call h5dcreate_f(h5id, dataset, datatype, dspaceid, dsetid, h5error, crp_list ) - call h5sclose_f(dspaceid, h5error) - call h5pclose_f(crp_list, h5error) - - deallocate(maxdims) - deallocate(startdims) - - end subroutine h5_define_unlimited_matrix - - !********************************************************** - ! Same as h5_define_unlimited_matrix - !********************************************************** - subroutine h5_define_unlimited_array(h5id, dataset, datatype, dsetid) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer(HID_T) :: datatype - integer(HID_T) :: dsetid - - integer(HID_T) :: dspaceid - integer(HID_T) :: crp_list - integer :: rank = 1 - integer(SIZE_T), dimension(1) :: dims = (/1/) - integer(SIZE_T), dimension(1) :: maxdims - - maxdims = (/H5S_UNLIMITED_F/) - - call h5screate_simple_f(rank, dims, dspaceid, h5error, maxdims) - call h5pcreate_f(H5P_DATASET_CREATE_F, crp_list, h5error) - call h5pset_chunk_f(crp_list, rank, dims, h5error) - call h5dcreate_f(h5id, dataset, datatype, dspaceid, & - dsetid, h5error, crp_list ) - call h5sclose_f(dspaceid, h5error) - call h5pclose_f(crp_list, h5error) - - end subroutine h5_define_unlimited_array - - !********************************************************** - ! Get bounds of array - !********************************************************** - subroutine h5_get_bounds_1(h5id, dataset, lb1, ub1) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer, dimension(1) :: lbounds, ubounds - integer, intent(inout) :: lb1, ub1 - logical :: attr_exists - - lbounds(1) = 0 - ubounds(1) = 0 - - call h5aexists_by_name_f(h5id, dataset, 'lbounds', attr_exists, h5error) - if (attr_exists) call h5ltget_attribute_int_f(h5id, dataset,'lbounds', lbounds(1), h5error) - call h5aexists_by_name_f(h5id, dataset, 'ubounds', attr_exists, h5error) - if (attr_exists) call h5ltget_attribute_int_f(h5id, dataset,'ubounds', ubounds(1), h5error) - - lb1 = lbounds(1) - ub1 = ubounds(1) - - end subroutine h5_get_bounds_1 - - !********************************************************** - ! Get bounds of matrix - !********************************************************** - subroutine h5_get_bounds_2(h5id, dataset, lb1, lb2, ub1, ub2) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer, dimension(1:2):: lbounds, ubounds - integer, intent(out) :: lb1, lb2, ub1, ub2 - logical :: attr_exists - - lbounds(1) = 0 - lbounds(2) = 0 - ubounds(1) = 0 - ubounds(2) = 0 - - call h5aexists_by_name_f(h5id, dataset, 'lbounds', attr_exists, h5error) - if (attr_exists) call h5ltget_attribute_int_f(h5id, dataset,'lbounds', lbounds, h5error) - call h5aexists_by_name_f(h5id, dataset, 'ubounds', attr_exists, h5error) - if (attr_exists) call h5ltget_attribute_int_f(h5id, dataset,'ubounds', ubounds, h5error) - - lb1 = lbounds(1) - lb2 = lbounds(2) - ub1 = ubounds(1) - ub2 = ubounds(2) - - !write (*,*) "get_bounds: ", dataset, lbounds, ubounds - - end subroutine h5_get_bounds_2 - - !********************************************************** - ! Append integer scalar to unlimited dimension - !********************************************************** - subroutine h5_append_int_0(dsetid, value, offset) - integer(HID_T) :: dsetid - integer :: value - integer :: offset - - integer(SIZE_T), dimension(1) :: dims = (/1/) - integer(SIZE_T), dimension(1) :: size - integer(HID_T) :: memspace - integer :: rank = 1 - integer(HID_T) :: dspaceid - - integer(HSIZE_T), dimension(1) :: offsetd - integer(HSIZE_T), dimension(1) :: countd - - size = (/offset/) - offsetd = (/offset-1/) - countd = (/1/) - call h5dset_extent_f(dsetid, size, h5error) - call h5_check() - call h5screate_simple_f(rank, dims, memspace, h5error) - call h5_check() - call h5dget_space_f(dsetid, dspaceid, h5error) - call h5_check() - call h5sselect_hyperslab_f(dspaceid, H5S_SELECT_SET_F, offsetd, countd, h5error) - call h5_check() - call h5dwrite_f(dsetid, H5T_NATIVE_INTEGER, value, dims, h5error, memspace, dspaceid) - call h5_check() - - call h5sclose_f(memspace, h5error) - call h5sclose_f(dspaceid, h5error) - - end subroutine h5_append_int_0 - - !********************************************************** - ! Append double scalar to unlimited dimension - !********************************************************** - subroutine h5_append_double_0(dsetid, value, offset) - integer(HID_T) :: dsetid - double precision :: value - integer :: offset - - integer(SIZE_T), dimension(1) :: dims = (/1/) - integer(SIZE_T), dimension(1) :: size - integer(HID_T) :: memspace - integer :: rank = 1 - integer(HID_T) :: dspaceid - - integer(HSIZE_T), dimension(1) :: offsetd - integer(HSIZE_T), dimension(1) :: countd - - size = (/offset/) - offsetd = (/offset-1/) - countd = (/1/) - - call h5dset_extent_f(dsetid, size, h5error) - call h5_check() - call h5screate_simple_f(rank, dims, memspace, h5error) - call h5_check() - call h5dget_space_f(dsetid, dspaceid, h5error) - call h5_check() - call h5sselect_hyperslab_f(dspaceid, H5S_SELECT_SET_F, offsetd, countd, h5error) - call h5_check() - call h5dwrite_f(dsetid, H5T_NATIVE_DOUBLE, value, dims, h5error, memspace, dspaceid) - call h5_check() - - call h5sclose_f(memspace, h5error) - call h5sclose_f(dspaceid, h5error) - - end subroutine h5_append_double_0 + subroutine h5_add_float_1(h5id, dataset, value, lbounds, ubounds, comment, unit) + integer(HID_T), intent(in) :: h5id + character(len=*), intent(in) :: dataset + real, dimension(:), intent(in) :: value + integer, dimension(:), intent(in) :: lbounds, ubounds + character(len=*), optional :: comment + character(len=*), optional :: unit - !********************************************************** - ! Append double array to unlimited dimension - ! Added by Markus Markl, 23.02.2021 - !********************************************************** - subroutine h5_append_double_1(dsetid, value, offset) - integer(HID_T) :: dsetid - double precision, dimension(:) :: value - integer :: offset + call h5_add_double_1(h5id, dataset, dble(value), lbounds, ubounds, comment, unit) + end subroutine h5_add_float_1 - integer(SIZE_T), dimension(2) :: dims - integer(SIZE_T), dimension(2) :: size - integer(HID_T) :: memspace - integer :: rank = 2 - integer(HID_T) :: dspaceid + subroutine h5_append_double_1(dsetid, value, offset) + integer(HID_T), intent(in) :: dsetid + double precision, dimension(:), intent(in) :: value + integer, intent(in) :: offset - integer(HSIZE_T), dimension(2) :: offsetd -! integer(HSIZE_T), dimension(1) :: countd + integer(SIZE_T), dimension(2) :: dims + integer(SIZE_T), dimension(2) :: extent + integer(HID_T) :: memspace + integer(HID_T) :: dspaceid + integer :: rank + integer :: nvalues + integer(HSIZE_T), dimension(2) :: offsetd - size = (/shape(value), offset/) - dims = (/shape(value), 1/) - offsetd = (/0, offset-1/) -! countd = (/1/) + rank = 2 + nvalues = size(value) + extent = (/int(nvalues, kind=SIZE_T), int(offset, kind=SIZE_T)/) + dims = (/int(nvalues, kind=SIZE_T), 1_SIZE_T/) + offsetd = (/0_HSIZE_T, int(offset - 1, kind=HSIZE_T)/) - call h5dset_extent_f(dsetid, size, h5error) + call h5dset_extent_f(dsetid, extent, h5error) call h5_check() call h5screate_simple_f(rank, dims, memspace, h5error) call h5_check() @@ -580,1123 +52,5 @@ subroutine h5_append_double_1(dsetid, value, offset) call h5sclose_f(memspace, h5error) call h5sclose_f(dspaceid, h5error) - end subroutine h5_append_double_1 - - - !********************************************************** - ! Append double matrix to unlimited dimension - !********************************************************** - subroutine h5_append_double_4(dsetid, value, offset) - integer(HID_T) :: dsetid - double precision, dimension(:,:,:) :: value - integer :: offset - - integer(SIZE_T), dimension(4) :: dims - integer(SIZE_T), dimension(4) :: size - integer(HID_T) :: memspace - integer :: rank = 4 - integer(HID_T) :: dspaceid - - integer(HSIZE_T), dimension(4) :: offsetd - - size = (/shape(value), offset/) - dims = (/shape(value), 1/) - offsetd = (/0, 0, 0, offset-1/) - !offsetd = offset - !countd = shape(value) - - !write (*,*) "Size:", size - !write (*,*) "Dims:", dims - !write (*,*) "Offset:", offsetd - call h5dset_extent_f(dsetid, size, h5error) - call h5_check() - call h5screate_simple_f(rank, dims, memspace, h5error) - call h5_check() - call h5dget_space_f(dsetid, dspaceid, h5error) - call h5_check() - call h5sselect_hyperslab_f(dspaceid, H5S_SELECT_SET_F, offsetd, dims, h5error) - call h5_check() - call h5dwrite_f(dsetid, H5T_NATIVE_DOUBLE, value, dims, h5error, memspace, dspaceid) - call h5_check() - - call h5sclose_f(memspace, h5error) - call h5sclose_f(dspaceid, h5error) - - end subroutine h5_append_double_4 - - - - !********************************************************** - ! Add logical - !********************************************************** - subroutine h5_add_logical(h5id, dataset, value, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - logical :: value - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T) :: dims(1) = (/0/) - integer :: internalvalue - - if (h5overwrite) call h5_delete(h5id, dataset) - internalvalue = 0 - if (value) internalvalue = 1 - call h5ltmake_dataset_int_f(h5id, dataset, 0,dims, (/internalvalue/), h5error) - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - call h5_check() - - end subroutine h5_add_logical - - !********************************************************** - ! Add integer scalar - !********************************************************** - subroutine h5_add_int(h5id, dataset, value, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer :: value - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T) :: dims(1) = (/0/) - - if (h5overwrite) call h5_delete(h5id, dataset) - call h5ltmake_dataset_int_f(h5id, dataset, 0,dims, (/value/), h5error) - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - call h5_check() - - end subroutine h5_add_int - - !********************************************************** - ! Add integer array - !********************************************************** - subroutine h5_add_int_1(h5id, dataset, value, lbounds, ubounds, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer, dimension(:) :: value - integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 1 - - if (h5overwrite) call h5_delete(h5id, dataset) - allocate(dims(rank)) - dims = ubounds - lbounds + 1 - size = rank - call h5ltmake_dataset_int_f(h5id, dataset, rank, dims, value, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbounds, size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubounds, size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - - deallocate(dims) - call h5_check() - - end subroutine h5_add_int_1 - - subroutine h5_add_int_1_nobounds(h5id, dataset, value, comment, unit, default) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer, allocatable, dimension(:) :: value - !integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer, optional :: default - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 1 - - if (h5overwrite) call h5_delete(h5id, dataset) - if ( allocated(value) ) then - allocate(dims(rank)) - dims = ubound(value) - lbound(value) + 1 - size = rank - call h5ltmake_dataset_int_f(h5id, dataset, rank, dims, value, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbound(value), size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubound(value), size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - - deallocate(dims) - else - ! value is not allocated - if (present(default) ) then - call h5_add(h5id, dataset, default) - else - call h5_add(h5id, dataset, 0) - end if - call h5ltset_attribute_string_f(h5id, dataset, 'comment', 'value not allocated', h5error) - end if - call h5_check() - end subroutine h5_add_int_1_nobounds - - !********************************************************** - ! Add integer matrix - !********************************************************** - subroutine h5_add_int_2(h5id, dataset, value, lbounds, ubounds, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer, dimension(:,:) :: value - integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 2 - - if (h5overwrite) call h5_delete(h5id, dataset) - allocate(dims(rank)) - dims = ubounds - lbounds + 1 - size = rank - call h5ltmake_dataset_int_f(h5id, dataset, rank, dims, value, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbounds, size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubounds, size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - - deallocate(dims) - call h5_check() - - end subroutine h5_add_int_2 - - subroutine h5_add_int_2_nobounds(h5id, dataset, value, comment, unit, default) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer, allocatable, dimension(:,:) :: value - !integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer, optional :: default - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 2 - - if (h5overwrite) call h5_delete(h5id, dataset) - if ( allocated(value) ) then - allocate(dims(rank)) - dims = ubound(value) - lbound(value) + 1 - size = rank - call h5ltmake_dataset_int_f(h5id, dataset, rank, dims, value, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbound(value), size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubound(value), size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - - deallocate(dims) - else - ! value is not allocated - if (present(default) ) then - call h5_add(h5id, dataset, default) - else - call h5_add(h5id, dataset, 0) - end if - call h5ltset_attribute_string_f(h5id, dataset, 'comment', 'value not allocated', h5error) - end if - call h5_check() - end subroutine h5_add_int_2_nobounds - - - !********************************************************** - ! Add long integer matrix. This function makes use of the - ! HDF-5 Fortran 2003 interface, since the default HDF-5 - ! functions to not support integer(kind=8). - ! This is documentated at - ! https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=758694 - !********************************************************** -!!$ subroutine h5_add_int8_2(h5id, dataset, value, lbounds, ubounds, comment, unit) -!!$ integer(HID_T) :: h5id -!!$ character(len=*) :: dataset -!!$ integer(kind=8), dimension(:,:),target :: value -!!$ integer, dimension(:) :: lbounds, ubounds -!!$ character(len=*), optional :: comment -!!$ character(len=*), optional :: unit -!!$ integer(HSIZE_T), dimension(:), allocatable :: dims -!!$ integer(SIZE_T) :: size -!!$ integer :: rank = 2 -!!$ integer(HID_T) :: dspace_id, dset_id -!!$ integer(kind=8), dimension(:,:), pointer :: test -!!$ type(C_PTR) :: f_ptr -!!$ integer(HID_T) :: h5_kind_type_i -!!$ -!!$ allocate(dims(rank)) -!!$ dims = ubounds - lbounds + 1 -!!$ size = rank -!!$ h5_kind_type_i = h5kind_to_type(8,H5_INTEGER_KIND) -!!$ -!!$ call h5screate_simple_f(rank, dims, dspace_id, h5error) -!!$ call h5dcreate_f(h5id, dataset, h5_kind_type_i, dspace_id, dset_id, h5error) -!!$ -!!$ test => value -!!$ f_ptr = c_loc(test(1,1)) -!!$ call h5dwrite_f(dset_id, h5_kind_type_i, f_ptr, h5error) -!!$ -!!$ call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbounds, size, h5error) -!!$ call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubounds, size, h5error) -!!$ -!!$ if (present(comment)) then -!!$ call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) -!!$ end if -!!$ if (present(unit)) then -!!$ call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) -!!$ end if -!!$ -!!$ call h5dclose_f(dset_id, h5error) -!!$ call h5sclose_f(dspace_id, h5error) -!!$ -!!$ deallocate(dims) -!!$ -!!$ call h5_check() -!!$ end subroutine h5_add_int8_2 - - !********************************************************** - ! Get long integer matrix - !********************************************************** -!!$ subroutine h5_get_int8_2(h5id, dataset, value) -!!$ integer(HID_T) :: h5id -!!$ character(len=*) :: dataset -!!$ integer(kind=8), dimension(:,:), target :: value -!!$ integer :: lb1, lb2, ub1, ub2 -!!$ integer(HSIZE_T), dimension(2) :: dims -!!$ integer(HID_T) :: dspace_id, dset_id -!!$ integer(kind=8), dimension(:,:), pointer :: test -!!$ integer(HID_T) :: h5_kind_type_i -!!$ type(C_PTR) :: f_ptr -!!$ -!!$ h5_kind_type_i = h5kind_to_type(8,H5_INTEGER_KIND) -!!$ -!!$ call h5_get_bounds(h5id, dataset, lb1, lb2, ub1, ub2) -!!$ dims = (/ub1-lb1+1, ub2-lb2+1/) -!!$ -!!$ call h5dopen_f(h5id, dataset, dset_id, h5error) -!!$ call h5dget_space_f(dset_id, dspace_id, h5error) -!!$ test => value -!!$ f_ptr = c_loc(test(1,1)) -!!$ -!!$ call h5dread_f(dset_id, h5_kind_type_i, f_ptr, h5error) -!!$ -!!$ call h5dclose_f(dset_id, h5error) -!!$ call h5sclose_f(dspace_id, h5error) -!!$ -!!$ call h5_check() -!!$ -!!$ end subroutine h5_get_int8_2 - - !********************************************************** - ! Get integer scalar - !********************************************************** - subroutine h5_get_int(h5id, dataset, value) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer, intent(out) :: value - integer, dimension(1) :: buf - integer(HSIZE_T) :: dims(1) = (/0/) - - call h5ltread_dataset_int_f_1(h5id, dataset, buf, dims, h5error) - value = buf(1) - - call h5_check() - - end subroutine h5_get_int - - !********************************************************** - ! Get integer array - !********************************************************** - subroutine h5_get_int_1(h5id, dataset, value) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer, dimension(:) :: value - integer :: lb1, ub1 - integer(HSIZE_T), dimension(1) :: dims - - call h5_get_bounds(h5id, dataset, lb1, ub1) - dims = (/ub1 - lb1 + 1/) - !write (*,*) dims, 'UB', ub1, lb1 - call h5ltread_dataset_int_f(h5id, dataset, value, dims, h5error) - - call h5_check() - - end subroutine h5_get_int_1 - - !********************************************************** - ! Add double scalar - !********************************************************** - subroutine h5_add_double_0(h5id, dataset, value, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision :: value - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T) :: dims(1) = (/0/) - - if (h5overwrite) call h5_delete(h5id, dataset) - call h5ltmake_dataset_double_f(h5id, dataset, 0, dims, (/value/), h5error) - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - - call h5_check() - - end subroutine h5_add_double_0 - - !********************************************************** - ! Add double array - !********************************************************** - subroutine h5_add_double_1(h5id, dataset, value, lbounds, ubounds, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, dimension(:) :: value - integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 1 - - if (h5overwrite) call h5_delete(h5id, dataset) - allocate(dims(rank)) - dims = ubounds - lbounds + 1 - size = rank - call h5ltmake_dataset_double_f(h5id, dataset, rank, dims, value, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbounds, size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubounds, size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - - deallocate(dims) - call h5_check() - - end subroutine h5_add_double_1 - - subroutine h5_add_double_1_nobounds(h5id, dataset, value, comment, unit, default) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, allocatable, dimension(:) :: value - !integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - double precision, optional :: default - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 1 - - if (h5overwrite) call h5_delete(h5id, dataset) - if ( allocated(value) ) then - allocate(dims(rank)) - dims = ubound(value) - lbound(value) + 1 - size = rank - call h5ltmake_dataset_double_f(h5id, dataset, rank, dims, value, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbound(value), size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubound(value), size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - - deallocate(dims) - else - ! value is not allocated - if (present(default) ) then - call h5_add(h5id, dataset, default) - else - call h5_add(h5id, dataset, 0.0d0) - end if - call h5ltset_attribute_string_f(h5id, dataset, 'comment', 'value not allocated', h5error) - end if - call h5_check() - end subroutine h5_add_double_1_nobounds - - !********************************************************** - ! Add float array - !********************************************************** - subroutine h5_add_float_1(h5id, dataset, value, lbounds, ubounds, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - real, dimension(:) :: value - integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 1 - - if (h5overwrite) call h5_delete(h5id, dataset) - allocate(dims(rank)) - dims = ubounds - lbounds + 1 - size = rank - call h5ltmake_dataset_float_f(h5id, dataset, rank, dims, value, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbounds, size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubounds, size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - - deallocate(dims) - call h5_check() - - end subroutine h5_add_float_1 - - - !********************************************************** - ! Get integer matrix - !********************************************************** - subroutine h5_get_int_2(h5id, dataset, value) - integer(HID_T) :: h5id - character(len=*) :: dataset - integer, dimension(:,:) :: value - integer(HSIZE_T), dimension(2) :: dims - - dims = shape(value) - call h5ltread_dataset_int_f(h5id, dataset, value, dims, h5error) - - !PRINT *,dims(1),dims(2),dims(3) - - call h5_check() - end subroutine h5_get_int_2 - - !********************************************************** - ! Get double scalar - !********************************************************** - subroutine h5_get_double_0(h5id, dataset, value) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, intent(out) :: value - double precision, dimension(1) :: buf - integer(HSIZE_T), dimension(1) :: dims = (/0/) - - call h5ltread_dataset_double_f(h5id, dataset, buf, dims, h5error) - value = buf(1) - - call h5_check() - - end subroutine h5_get_double_0 - - !********************************************************** - ! Get double array - !********************************************************** - subroutine h5_get_double_1(h5id, dataset, value) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, dimension(:) :: value - integer :: lb1, ub1 - integer(HSIZE_T), dimension(1) :: dims - - call h5_get_bounds(h5id, dataset, lb1, ub1) - !if (.not. unlimited) then - ! dims = (/ub1 - lb1 + 1/) - !else - dims = shape(value) - !write (*,*) "Unlimited dimension ", dims - !end if - call h5ltread_dataset_double_f(h5id, dataset, value, dims, h5error) - call h5_check() - end subroutine h5_get_double_1 - - !********************************************************** - ! Get double matrix - !********************************************************** - subroutine h5_get_double_2(h5id, dataset, value) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, dimension(:,:) :: value - integer :: lb1, lb2, ub1, ub2 - integer(HSIZE_T), dimension(2) :: dims - - call h5_get_bounds(h5id, dataset, lb1, lb2, ub1, ub2) - dims = (/ub1-lb1+1, ub2-lb2+1/) - call h5ltread_dataset_double_f(h5id, dataset, value, dims, h5error) - - call h5_check() - end subroutine h5_get_double_2 - - !********************************************************** - ! Get double 3-dim-matrix - !********************************************************** - subroutine h5_get_double_3(h5id, dataset, value) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, dimension(:,:,:) :: value - integer(HSIZE_T), dimension(3) :: dims - - dims = shape(value) - call h5ltread_dataset_double_f(h5id, dataset, value, dims, h5error) - - !PRINT *,dims(1),dims(2),dims(3) - - call h5_check() - end subroutine h5_get_double_3 - - !********************************************************** - ! Get double 4-dim-matrix - !********************************************************** - subroutine h5_get_double_4(h5id, dataset, value) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, dimension(:,:,:,:) :: value - integer(HSIZE_T), dimension(4) :: dims - - dims = shape(value) - call h5ltread_dataset_double_f(h5id, dataset, value, dims, h5error) - - call h5_check() - end subroutine h5_get_double_4 - - !********************************************************** - ! Get double 5-dim-matrix - !********************************************************** - subroutine h5_get_double_5(h5id, dataset, value) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, dimension(:,:,:,:,:):: value - integer(HSIZE_T), dimension(5) :: dims - - dims = shape(value) - call h5ltread_dataset_double_f(h5id, dataset, value, dims, h5error) - - call h5_check() - end subroutine h5_get_double_5 - - !********************************************************** - ! Get double 4-dim-matrix - !********************************************************** - subroutine h5_get_double_4_hyperslab(h5id, dataset, value, offset_par, count_par) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, dimension(:,:,:,:) :: value - integer,dimension(4) :: offset_par, count_par - integer(HSIZE_T), dimension(4) :: offset, count, startout - integer(HSIZE_T), dimension(4) :: dims - integer(HID_T) :: dset_id, dataspace, memspace - integer :: memrank = 4 - - offset = offset_par - count = count_par - dims = shape(value) - - call h5dopen_f(h5id, dataset, dset_id, h5error) - call h5dget_space_f(dset_id, dataspace, h5error) - - call h5sselect_hyperslab_f(dataspace, H5S_SELECT_SET_F, & - offset, count, h5error) - - call h5screate_simple_f(memrank, dims, memspace, h5error) - - startout = (/0,0,0,0/) - call h5sselect_hyperslab_f(memspace, H5S_SELECT_SET_F, & - startout, count, h5error) - - call H5dread_f(dset_id, H5T_NATIVE_DOUBLE, value, dims,h5error, & - memspace, dataspace) - call h5_check() - - call h5sclose_f(dataspace, h5error) - call h5sclose_f(memspace, h5error) - call h5dclose_f(dset_id, h5error) - - !write (*,*) "Read", value - !write (*,*) "Shape", shape(value) - !write (*,*) "Dimns", offset, count, startout, dims - call h5_check() - end subroutine h5_get_double_4_hyperslab - - !********************************************************** - ! Get 1-dim complex double matrix - !********************************************************** - subroutine h5_get_complex_1(h5id, dataset, val) - integer(HID_T), intent(in) :: h5id - character(len=*), intent(in) :: dataset - complex(kind=dcp), dimension(:), intent(inout) :: val - real(kind=dpp), dimension(:), allocatable :: temp_val - integer :: lb1, ub1 - integer, parameter :: rank = 1 - integer(HSIZE_T), dimension(rank) :: dims - integer(SIZE_T) :: re_size, im_size, t_size - integer(SIZE_T) :: offset - integer(HID_T) :: type_id - integer(HID_T) :: dset_id - - !********************************************************** - ! Get sizes - !********************************************************** - call h5tget_size_f(H5T_NATIVE_DOUBLE, re_size, h5error) - call h5tget_size_f(H5T_NATIVE_DOUBLE, im_size, h5error) - t_size = re_size + im_size - - !********************************************************** - ! Create compound type - !********************************************************** - call h5tcreate_f(H5T_COMPOUND_F, t_size, type_id, h5error) - offset = 0 - call h5tinsert_f(type_id, 'real', offset, H5T_NATIVE_DOUBLE, h5error) - offset = offset + re_size - call h5tinsert_f(type_id, 'imag', offset, H5T_NATIVE_DOUBLE, h5error) - - !********************************************************** - ! Get dimension of value to be retrieved - !********************************************************** - call h5_get_bounds(h5id, dataset, lb1, ub1) - dims = (/ ub1 - lb1 + 1 /) - allocate(temp_val(1:2*product(dims))) - - !********************************************************** - ! Write data - !********************************************************** - call h5dopen_f(h5id, dataset, dset_id, h5error) - call h5dread_f(dset_id, type_id, temp_val, dims, h5error) - val(:) = cmplx(temp_val(1:2*product(dims)-1:2), temp_val(2:2*product(dims):2), dpp) - - call h5dclose_f(dset_id, h5error) - call h5tclose_f(type_id, h5error) - - call h5_check() - end subroutine h5_get_complex_1 - - !********************************************************** - ! Get 2-dim complex double matrix - !********************************************************** - subroutine h5_get_complex_2(h5id, dataset, val) - integer(HID_T), intent(in) :: h5id - character(len=*), intent(in) :: dataset - complex(kind=dcp), dimension(:,:), intent(inout) :: val - real(kind=dpp), dimension(:), allocatable :: temp_val - integer :: lb1, ub1, lb2, ub2 - integer, parameter :: rank = 2 - integer(HSIZE_T), dimension(rank) :: dims - integer(SIZE_T) :: re_size, im_size, t_size - integer(SIZE_T) :: offset - integer(HID_T) :: type_id - integer(HID_T) :: dset_id - - !********************************************************** - ! Get sizes - !********************************************************** - call h5tget_size_f(H5T_NATIVE_DOUBLE, re_size, h5error) - call h5tget_size_f(H5T_NATIVE_DOUBLE, im_size, h5error) - t_size = re_size + im_size - - !********************************************************** - ! Create compound type - !********************************************************** - call h5tcreate_f(H5T_COMPOUND_F, t_size, type_id, h5error) - offset = 0 - call h5tinsert_f(type_id, 'real', offset, H5T_NATIVE_DOUBLE, h5error) - offset = offset + re_size - call h5tinsert_f(type_id, 'imag', offset, H5T_NATIVE_DOUBLE, h5error) - - !********************************************************** - ! Get dimension of value to be retrieved - !********************************************************** - call h5_get_bounds(h5id, dataset, lb1, lb2, ub1, ub2) - dims = (/ ub1 - lb1 + 1, ub2 - lb2 + 1 /) - allocate(temp_val(1:2*product(dims))) - - !********************************************************** - ! Write data - !********************************************************** - call h5dopen_f(h5id, dataset, dset_id, h5error) - call h5dread_f(dset_id, type_id, temp_val, dims, h5error) - val(:,:) = reshape(cmplx(temp_val(1:2*product(dims)-1:2), & - temp_val(2:2*product(dims):2), dpp), dims) - - call h5dclose_f(dset_id, h5error) - call h5tclose_f(type_id, h5error) - - call h5_check() - end subroutine h5_get_complex_2 - - !********************************************************** - ! Get logical scalar - !********************************************************** - subroutine h5_get_logical(h5id, dataset, value) - integer(HID_T) :: h5id - character(len=*) :: dataset - logical, intent(out) :: value - integer, dimension(1) :: buf - integer(HSIZE_T) :: dims(1) = (/0/) - - call h5ltread_dataset_int_f_1(h5id, dataset, buf, dims, h5error) - - value = .false. - if (buf(1) .eq. 1) then - value = .true. - end if - call h5_check() - - end subroutine h5_get_logical - - !********************************************************** - ! Add double matrix - !********************************************************** - subroutine h5_add_double_2(h5id, dataset, value, lbounds, ubounds, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, dimension(:,:) :: value - integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 2 - - if (h5overwrite) call h5_delete(h5id, dataset) - allocate(dims(rank)) - dims = ubounds - lbounds + 1 - size = rank - call h5ltmake_dataset_double_f(h5id, dataset, rank, dims, value, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbounds, size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubounds, size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - deallocate(dims) - - call h5_check() - end subroutine h5_add_double_2 - - !********************************************************** - ! Add 3-dim double matrix - !********************************************************** - subroutine h5_add_double_3(h5id, dataset, value, lbounds, ubounds, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, dimension(:,:,:) :: value - integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 3 - - if (h5overwrite) call h5_delete(h5id, dataset) - allocate(dims(rank)) - dims = ubounds - lbounds + 1 - size = rank - call h5ltmake_dataset_double_f(h5id, dataset, rank, dims, value, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbounds, size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubounds, size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - deallocate(dims) - - call h5_check() - end subroutine h5_add_double_3 - - !********************************************************** - ! Add 4-dim double matrix - !********************************************************** - subroutine h5_add_double_4(h5id, dataset, value, lbounds, ubounds, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, dimension(:,:,:,:) :: value - integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 4 - - if (h5overwrite) call h5_delete(h5id, dataset) - allocate(dims(rank)) - dims = ubounds - lbounds + 1 - size = rank - call h5ltmake_dataset_double_f(h5id, dataset, rank, dims, value, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbounds, size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubounds, size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - deallocate(dims) - - call h5_check() - end subroutine h5_add_double_4 - - !********************************************************** - ! Add 5-dim double matrix - !********************************************************** - subroutine h5_add_double_5(h5id, dataset, value, lbounds, ubounds, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - double precision, dimension(:,:,:,:,:) :: value - integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 5 - - if (h5overwrite) call h5_delete(h5id, dataset) - allocate(dims(rank)) - dims = ubounds - lbounds + 1 - size = rank - call h5ltmake_dataset_double_f(h5id, dataset, rank, dims, value, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbounds, size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubounds, size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - deallocate(dims) - - call h5_check() - end subroutine h5_add_double_5 - - !********************************************************** - ! Add 1-dim complex double matrix - !********************************************************** - subroutine h5_add_complex_1(h5id, dataset, value, lbounds, ubounds, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - complex(kind=dcp), dimension(:) :: value - integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 1 - integer(SIZE_T) :: re_size, im_size, t_size - integer(SIZE_T) :: offset - integer(HID_T) :: type_id - integer(HID_T) :: dspace_id, dset_id, dt_re_id, dt_im_id - - if (h5overwrite) call h5_delete(h5id, dataset) - !********************************************************** - ! Get sizes - !********************************************************** - call h5tget_size_f(H5T_NATIVE_DOUBLE, re_size, h5error) - call h5tget_size_f(H5T_NATIVE_DOUBLE, im_size, h5error) - t_size = re_size + im_size - - !********************************************************** - ! Create compound type - !********************************************************** - call h5tcreate_f(H5T_COMPOUND_F, t_size, type_id, h5error) - offset = 0 - call h5tinsert_f(type_id, 'real', offset, H5T_NATIVE_DOUBLE, h5error) - offset = offset + re_size - call h5tinsert_f(type_id, 'imag', offset, H5T_NATIVE_DOUBLE, h5error) - - !********************************************************** - ! Get dimension of value to be stored - !********************************************************** - allocate(dims(rank)) - dims = ubounds - lbounds + 1 - size = rank - - !********************************************************** - ! Create dataset - !********************************************************** - call h5screate_simple_f(rank, dims, dspace_id, h5error) - call h5dcreate_f(h5id, dataset, type_id, dspace_id, dset_id, h5error) - - !********************************************************** - ! Create sub datasets - !********************************************************** - call h5tcreate_f(H5T_COMPOUND_F, re_size, dt_re_id, h5error) - offset = 0 - call h5tinsert_f(dt_re_id, "real", offset, H5T_NATIVE_DOUBLE, h5error) - - call h5tcreate_f(H5T_COMPOUND_F, im_size, dt_im_id, h5error) - offset = 0 - call h5tinsert_f(dt_im_id, "imag", offset, H5T_NATIVE_DOUBLE, h5error) - - !********************************************************** - ! Write data - !********************************************************** - call h5dwrite_f(dset_id, dt_re_id, real(value), dims, h5error) - call h5dwrite_f(dset_id, dt_im_id, aimag(value), dims, h5error) - - !********************************************************** - ! Set additional attributes - !********************************************************** - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbounds, size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubounds, size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - deallocate(dims) - - call h5dclose_f(dset_id, h5error) - call h5sclose_f(dspace_id, h5error) - call h5tclose_f(type_id, h5error) - call h5tclose_f(dt_re_id, h5error) - call h5tclose_f(dt_im_id, h5error) - - call h5_check() - end subroutine h5_add_complex_1 - - !********************************************************** - ! Add 2-dim complex double matrix - !********************************************************** - subroutine h5_add_complex_2(h5id, dataset, value, lbounds, ubounds, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - complex(kind=dcp), dimension(:,:) :: value - integer, dimension(:) :: lbounds, ubounds - character(len=*), optional :: comment - character(len=*), optional :: unit - integer(HSIZE_T), dimension(:), allocatable :: dims - integer(SIZE_T) :: size - integer :: rank = 2 - integer(SIZE_T) :: re_size, im_size, t_size - integer(SIZE_T) :: offset - integer(HID_T) :: type_id - integer(HID_T) :: dspace_id, dset_id, dt_re_id, dt_im_id - - if (h5overwrite) call h5_delete(h5id, dataset) - !********************************************************** - ! Get sizes - !********************************************************** - call h5tget_size_f(H5T_NATIVE_DOUBLE, re_size, h5error) - call h5tget_size_f(H5T_NATIVE_DOUBLE, im_size, h5error) - t_size = re_size + im_size - - !********************************************************** - ! Create compound type - !********************************************************** - call h5tcreate_f(H5T_COMPOUND_F, t_size, type_id, h5error) - offset = 0 - call h5tinsert_f(type_id, 'real', offset, H5T_NATIVE_DOUBLE, h5error) - offset = offset + re_size - call h5tinsert_f(type_id, 'imag', offset, H5T_NATIVE_DOUBLE, h5error) - - !********************************************************** - ! Get dimension of value to be stored - !********************************************************** - allocate(dims(rank)) - dims = ubounds - lbounds + 1 - size = rank - - !********************************************************** - ! Create dataset - !********************************************************** - call h5screate_simple_f(rank, dims, dspace_id, h5error) - call h5dcreate_f(h5id, dataset, type_id, dspace_id, dset_id, h5error) - - !********************************************************** - ! Create sub datasets - !********************************************************** - call h5tcreate_f(H5T_COMPOUND_F, re_size, dt_re_id, h5error) - offset = 0 - call h5tinsert_f(dt_re_id, "real", offset, H5T_NATIVE_DOUBLE, h5error) - - call h5tcreate_f(H5T_COMPOUND_F, im_size, dt_im_id, h5error) - offset = 0 - call h5tinsert_f(dt_im_id, "imag", offset, H5T_NATIVE_DOUBLE, h5error) - - !********************************************************** - ! Write data - !********************************************************** - call h5dwrite_f(dset_id, dt_re_id, real(value), dims, h5error) - call h5dwrite_f(dset_id, dt_im_id, aimag(value), dims, h5error) - - !********************************************************** - ! Set additional attributes - !********************************************************** - call h5ltset_attribute_int_f(h5id, dataset, 'lbounds', lbounds, size, h5error) - call h5ltset_attribute_int_f(h5id, dataset, 'ubounds', ubounds, size, h5error) - - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - deallocate(dims) - - call h5dclose_f(dset_id, h5error) - call h5sclose_f(dspace_id, h5error) - call h5tclose_f(type_id, h5error) - call h5tclose_f(dt_re_id, h5error) - call h5tclose_f(dt_im_id, h5error) - - call h5_check() - end subroutine h5_add_complex_2 - - !********************************************************** - ! Add string - !********************************************************** - subroutine h5_add_string(h5id, dataset, value, comment, unit) - integer(HID_T) :: h5id - character(len=*) :: dataset - character(len=*) :: value - character(len=*), optional :: comment - character(len=*), optional :: unit - - if (h5overwrite) call h5_delete(h5id, dataset) - call h5ltmake_dataset_string_f(h5id, dataset, value, h5error) - if (present(comment)) then - call h5ltset_attribute_string_f(h5id, dataset, 'comment', comment, h5error) - end if - if (present(unit)) then - call h5ltset_attribute_string_f(h5id, dataset, 'unit', unit, h5error) - end if - - call h5_check() - end subroutine h5_add_string - end module KAMEL_hdf5_tools