!!****************************************************************************** !! !! This file is part of the AMUN source code, a program to perform !! Newtonian or relativistic magnetohydrodynamical simulations on uniform or !! adaptive mesh. !! !! Copyright (C) 2008-2024 Grzegorz Kowal !! !! This program is free software: you can redistribute it and/or modify !! it under the terms of the GNU General Public License as published by !! the Free Software Foundation, either version 3 of the License, or !! (at your option) any later version. !! !! This program is distributed in the hope that it will be useful, !! but WITHOUT ANY WARRANTY; without even the implied warranty of !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the !! GNU General Public License for more details. !! !! You should have received a copy of the GNU General Public License !! along with this program. If not, see . !! !!****************************************************************************** !! !! module: IO !! !! This module handles data storage and job restart from restart files. !! !! !!****************************************************************************** ! module io use blocks, only : pointer_meta #ifdef HDF5 use hdf5 #endif /* HDF5 */ use timers, only : set_timer, start_timer, stop_timer implicit none #ifdef HDF5 interface restore_attribute_h5 module procedure restore_attribute_string_h5 module procedure restore_attribute_number_h5 end interface interface store_attribute_h5 module procedure store_attribute_string_h5 module procedure store_attribute_number_h5 end interface #endif /* HDF5 */ integer, save :: iio ! MODULE PARAMETERS: ! ================= ! ! snapshot formats ! integer, parameter :: snapshot_xml = 0 #ifdef HDF5 integer, parameter :: snapshot_hdf5 = 1 #endif /* HDF5 */ ! snapshot_format - the format of snapshots; ! restart_format - the format of restart snapshots; ! integer, save :: snapshot_format = snapshot_xml integer, save :: restart_format = snapshot_xml ! respath - the directory from which the restart snapshots should be read; ! nrest - for job restarting, this is the number of restart snapshot; ! irest - the local counter for the restart snapshots; ! isnap - the local counter for the regular snapshots; ! ishift - the shift of the snapshot counter for restarting job with ! different snapshot interval; ! hrest - the execution time interval for restart snapshot storing ! (in hours); the minimum allowed value is 3 minutes; ! hsnap - the problem time interval for regular snapshot storing; ! tsnap - the next snapshot time; ! character(len=255), save :: respath = "./" integer , save :: nrest = -1 integer(kind=4) , save :: irest = 1 integer(kind=4) , save :: isnap = 0 integer(kind=4) , save :: ishift = 0 real(kind=8) , save :: hrest = 6.0d+00 real(kind=8) , save :: hsnap = 1.0d+00 real(kind=8) , save :: tsnap = 0.0d+00 ! flag indicating to store snapshots at exact intervals ! logical , save :: precise_snapshots = .false. #ifdef HDF5 ! a flag to determine if XDMF files should be generated ! logical , save :: with_xdmf = .false. #endif /* HDF5 */ ! the compression format and level of the XML+binary files ! integer :: snapshot_compressor = 0, & compression_level = -22 ! data encoder applied before the compression ! integer :: snapshot_encoder = 0 ! the type of digest to use and its length ! integer :: hash_type = 0, & hash_size = 0 #ifdef HDF5 ! supported compression types ! integer, parameter :: H5Z_DEFLATE = 1 integer, parameter :: H5Z_SZIP = 4 integer, parameter :: H5Z_ZFP = 32013 integer, parameter :: H5Z_ZSTANDARD = 32015 ! used compression type and level ! integer, save :: hcformat = 0, hclevel = 20 ! ZFP compressor parameters ! character(len=32), save :: zfpmode = "reversible" integer , save :: zfpprec = 64 real(kind=8) , save :: zfprate = 6.4d+01 real(kind=8) , save :: zfpaccu = 0.0d+00 ! HDF5 property object identifier ! integer(hid_t), save :: prp_id #endif /* HDF5 */ ! array of pointer used during job restart ! type(pointer_meta), dimension(:), allocatable, save :: block_array private public :: initialize_io, finalize_io, print_io public :: restart_snapshot_number, restart_from_snapshot public :: restore_snapshot_parameters public :: read_restart_snapshot, write_restart_snapshot, write_snapshot public :: update_dtp !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! contains ! !=============================================================================== !! !!*** PUBLIC SUBROUTINES ***************************************************** !! !=============================================================================== ! !=============================================================================== ! ! subroutine INITIALIZE_IO: ! ------------------------ ! ! Subroutine initializes module IO by setting its parameters. ! ! Arguments: ! ! verbose - flag determining if the subroutine should be verbose; ! status - return flag of the procedure execution status; ! !=============================================================================== ! subroutine initialize_io(verbose, status) use compression, only : check_compressor, is_compressor_on, & check_encoder, get_compressor_name use hash , only : hash_info use helpers , only : print_message #ifdef HDF5 use mpitools , only : nproc #endif /* HDF5 */ use parameters , only : get_parameter implicit none logical, intent(in) :: verbose integer, intent(out) :: status logical :: test character(len=255) :: string, dname character(len=255) :: sformat = "xml" character(len=255) :: precise = "off" character(len=255) :: ghosts = "on" character(len=255) :: xdmf = "off" character(len=8) :: htype = "xxh64" #ifdef HDF5 integer(hsize_t) :: cd_nelmts = 6 integer, dimension(6) :: cd_values = 0 #endif /* HDF5 */ #ifdef HDF5 character(len=*), parameter :: loc = 'IO::initialize_io()' #endif /* HDF5 */ !------------------------------------------------------------------------------- ! status = 0 call set_timer('SNAPSHOTS I/O', iio) call get_parameter("restart_path" , respath) call get_parameter("restart_number" , nrest ) call get_parameter("restart_interval" , hrest ) call get_parameter("snapshot_interval", hsnap ) call get_parameter("precise_snapshots", precise) call get_parameter("include_ghosts" , ghosts ) call get_parameter("generate_xdmf" , xdmf ) if (index(respath, '/', back = .true.) /= len(trim(respath))) then write (respath,"(a)") trim(adjustl(respath)) // '/' end if call get_parameter("snapshot_format", sformat) select case(sformat) #ifdef HDF5 case('h5', 'hdf5', 'H5', 'HDF5') snapshot_format = snapshot_hdf5 #endif /* HDF5 */ case default snapshot_format = snapshot_xml end select call get_parameter("restart_format", sformat) select case(sformat) #ifdef HDF5 case('h5', 'hdf5', 'H5', 'HDF5') restart_format = snapshot_hdf5 #endif /* HDF5 */ case default restart_format = snapshot_xml end select if (nrest == 0) then test = .true. nrest = 0 select case(restart_format) #ifdef HDF5 case(snapshot_hdf5) do while (test) nrest = nrest + 1 write (dname, "(a,'r',i6.6,'_',i5.5,'.h5')") & trim(respath), nrest, nproc inquire (file=dname, exist=test) end do #endif /* HDF5 */ case default do while (test) nrest = nrest + 1 write (dname, "(a,'restart-',i5.5)") trim(respath), nrest #ifdef __INTEL_COMPILER inquire (directory=dname, exist=test) #else /* __INTEL_COMPILER */ inquire (file=dname, exist=test) #endif /* __INTEL_COMPILER */ end do end select nrest = nrest - 1 end if string = "none" call get_parameter("compression_format", string) call get_parameter("compression_level" , compression_level) call check_compressor(string, snapshot_compressor, & compression_level) string = "none" if (is_compressor_on(snapshot_compressor)) & call get_parameter("data_encoder", string) call check_encoder(string, snapshot_encoder) call get_parameter("digest_type", htype) call hash_info(htype, hash_type, hash_size) if (status == 0) then select case(trim(precise)) case ("off", "OFF", "n", "N", "false", "FALSE", "no", "NO") precise_snapshots = .false. case default precise_snapshots = .true. end select #ifdef HDF5 select case(trim(xdmf)) case ("off", "OFF", "n", "N", "false", "FALSE", "no", "NO") with_xdmf = .false. case default with_xdmf = .true. end select call h5open_f(status) if (status /= 0) then call print_message(loc, & "Cannot initialize the HDF5 Fortran interface!") else call h5pcreate_f(H5P_DATASET_CREATE_F, prp_id, status) if (status < 0) then call print_message(loc, & "Cannot create the compression property for datasets!") else call get_parameter("compression_format", sformat) call get_parameter("compression_level" , hclevel) call get_parameter("zfp_mode" , zfpmode) call get_parameter("zfp_rate" , zfprate) call get_parameter("zfp_precision" , zfpprec) call get_parameter("zfp_accuracy" , zfpaccu) select case(sformat) case("deflate", "gzip") call h5zfilter_avail_f(H5Z_DEFLATE, test, status) if (status == 0) then if (test) then hcformat = H5Z_DEFLATE hclevel = max(1, min(9, hclevel)) call h5pset_deflate_f(prp_id, hclevel, status) end if else call print_message(loc, & "Could not check if the filter is available!") end if case("szip") call h5zfilter_avail_f(H5Z_FILTER_SZIP_F, test, status) if (status == 0) then if (test) then hcformat = H5Z_SZIP call h5pset_szip_f(prp_id, 32, 32, status) end if else call print_message(loc, & "Could not check if the filter is available!") end if with_xdmf = .false. case("zstd", "zstandard") call h5zfilter_avail_f(H5Z_ZSTANDARD, test, status) if (status == 0) then if (test) then hcformat = H5Z_ZSTANDARD hclevel = max(1, min(20, hclevel)) cd_values(:) = hclevel call h5pset_filter_f(prp_id, H5Z_ZSTANDARD, & H5Z_FLAG_OPTIONAL_F, cd_nelmts, cd_values, status) end if else call print_message(loc, & "Could not check if the filter is available!") end if with_xdmf = .false. case("zfp") call h5zfilter_avail_f(H5Z_ZFP, test, status) if (status == 0) then if (test) then hcformat = H5Z_ZFP select case(trim(zfpmode)) case('rate') cd_values(1) = 1 cd_values(3:4) = transfer(zfprate, [0_4]) case('precision') cd_values(1) = 2 cd_values(3) = zfpprec case('accuracy') cd_values(1) = 3 cd_values(3:4) = transfer(zfpaccu, [0_4]) case('reversible') cd_values(1) = 5 end select call h5pset_filter_f(prp_id, H5Z_ZFP, 0, & cd_nelmts, cd_values, status) end if else call print_message(loc, & "Could not check if the filter is available!") end if with_xdmf = .false. case default end select end if end if #endif /* HDF5 */ end if !------------------------------------------------------------------------------- ! end subroutine initialize_io ! !=============================================================================== ! ! subroutine FINALIZE_IO: ! ---------------------- ! ! Subroutine releases memory used by the module. ! ! Arguments: ! ! status - the subroutine call status; ! !=============================================================================== ! subroutine finalize_io(status) #ifdef HDF5 use helpers, only : print_message #endif /* HDF5 */ implicit none integer, intent(out) :: status #ifdef HDF5 character(len=*), parameter :: loc = 'IO::finalize_io()' #endif /* HDF5 */ !------------------------------------------------------------------------------- ! status = 0 #ifdef HDF5 call h5pclose_f(prp_id, status) if (status < 0) & call print_message(loc, "Could not close the HDF5 compression property!") call h5close_f(status) if (status < 0) & call print_message(loc, "Could not close the HDF5 Fortran interface!") #endif /* HDF5 */ !------------------------------------------------------------------------------- ! end subroutine finalize_io ! !=============================================================================== ! ! subroutine PRINT_IO: ! ------------------- ! ! Subroutine prints IO parameters. ! ! Arguments: ! ! verbose - flag determining if the subroutine should be verbose; ! !=============================================================================== ! subroutine print_io(verbose) use compression, only : get_compressor_name, get_encoder_name, & is_compressor_on use hash , only : hash_name use helpers , only : print_section, print_parameter implicit none logical, intent(in) :: verbose character(len=80) :: sfmt, msg integer :: dd, hh, mm, ss !------------------------------------------------------------------------------- ! if (verbose) then call print_section(verbose, "Snapshots") select case(snapshot_format) #ifdef HDF5 case(snapshot_hdf5) call print_parameter(verbose, "snapshot format", "HDF5") #endif /* HDF5 */ case default call print_parameter(verbose, "snapshot format", "XML+binary") end select select case(restart_format) #ifdef HDF5 case(snapshot_hdf5) call print_parameter(verbose, "restart snapshot format", "HDF5") #endif /* HDF5 */ case default call print_parameter(verbose, "restart snapshot format", "XML+binary") call print_parameter(verbose, "digest type", hash_name(hash_type)) if (is_compressor_on(snapshot_compressor)) then call print_parameter(verbose, "compression format", & get_compressor_name(snapshot_compressor)) call print_parameter(verbose, "compression level", & compression_level) call print_parameter(verbose, "data encoder", & get_encoder_name(snapshot_encoder)) end if end select call print_parameter(verbose, "precise snapshot intervals", & precise_snapshots, "on") #ifdef HDF5 select case(hcformat) case(H5Z_DEFLATE) call print_parameter(verbose, "HDF5 compression", "deflate") call print_parameter(verbose, "compression level", hclevel) case(H5Z_SZIP) call print_parameter(verbose, "HDF5 compression", "szip") case(H5Z_ZSTANDARD) call print_parameter(verbose, "HDF5 compression", "zstd") call print_parameter(verbose, "compression level", hclevel) case(H5Z_ZFP) call print_parameter(verbose, "HDF5 compression", "zfp") call print_parameter(verbose, "ZFP mode", zfpmode) select case(trim(zfpmode)) case('rate') call print_parameter(verbose, "ZFP rate" , zfprate) case('precision') call print_parameter(verbose, "ZFP precision", zfpprec) case('accuracy') call print_parameter(verbose, "ZFP accuracy" , zfpaccu) end select case default call print_parameter(verbose, "HDF5 compression" , "none") end select call print_parameter(verbose, "generate XDMF files", with_xdmf, "on") #endif /* HDF5 */ call print_parameter(verbose, "snapshot interval" , hsnap) if (hrest > 0.0d+00) then dd = int(hrest / 2.4d+01) hh = int(mod(hrest, 2.4d+01)) mm = int(mod(6.0d+01 * hrest, 6.0d+01)) ss = int(mod(3.6d+03 * hrest, 6.0d+01)) sfmt = "(i2.2,'d',i2.2,'h',i2.2,'m',i2.2,'s')" write (msg,sfmt) dd, hh, mm, ss call print_parameter(verbose, "restart interval" , msg ) end if if (restart_from_snapshot()) then call print_parameter(verbose, "restart from path" , respath) call print_parameter(verbose, "restart from snapshot", nrest ) end if end if !------------------------------------------------------------------------------- ! end subroutine print_io ! !=============================================================================== ! ! function RESTART_SNAPSHOT_NUMBER: ! -------------------------------- ! ! Subroutine returns the number of restart snapshot. ! !=============================================================================== ! integer function restart_snapshot_number() implicit none !------------------------------------------------------------------------------- ! restart_snapshot_number = nrest !------------------------------------------------------------------------------- ! end function restart_snapshot_number ! !=============================================================================== ! ! function RESTART_FROM_SNAPSHOT: ! ------------------------------ ! ! Subroutine returns true if the current job is the restarted one. ! !=============================================================================== ! logical function restart_from_snapshot() implicit none !------------------------------------------------------------------------------- ! restart_from_snapshot = (nrest > 0) !------------------------------------------------------------------------------- ! end function restart_from_snapshot ! !=============================================================================== ! ! subroutine RESTORE_SNAPSHOT_PARAMETERS: ! -------------------------------------- ! ! Description: ! ! The subroutine restores parameters from the restart snapshot for ! restarted jobs, ensuring that these parameters remain unchanged during ! the restart process. ! ! Arguments: ! ! status - the subroutine call status; ! !=============================================================================== ! subroutine restore_snapshot_parameters(status) use helpers , only : print_message #ifdef MPI use parameters, only : distribute_parameters #endif /* MPI */ implicit none integer, intent(out) :: status character(len=*), parameter :: loc = 'IO::restore_snapshot_parameters()' !------------------------------------------------------------------------------- ! call start_timer(iio) status = 0 select case(restart_format) #ifdef HDF5 case(snapshot_hdf5) call restore_snapshot_parameters_h5(status) #endif /* HDF5 */ case default call restore_snapshot_parameters_xml(status) end select #ifdef MPI call distribute_parameters() #endif /* MPI */ call stop_timer(iio) !------------------------------------------------------------------------------- ! end subroutine restore_snapshot_parameters ! !=============================================================================== ! ! subroutine READ_RESTART_SNAPSHOT: ! -------------------------------- ! ! Subroutine reads restart snapshot files in order to resume the job. ! This is a wrapper calling specific format subroutine. ! ! Arguments: ! ! status - the status flag to inform if subroutine succeeded or failed; ! !=============================================================================== ! subroutine read_restart_snapshot(status) use blocks , only : build_leaf_list, build_datablock_list use evolution, only : time use helpers , only : print_message implicit none integer, intent(out) :: status character(len=*), parameter :: loc = 'IO::read_restart_snapshot()' !------------------------------------------------------------------------------- ! call start_timer(iio) status = 0 select case(restart_format) #ifdef HDF5 case(snapshot_hdf5) call read_restart_snapshot_h5(status) #endif /* HDF5 */ case default call read_restart_snapshot_xml(status) end select call build_leaf_list(status) if (status /= 0) & call print_message(loc, "Could not build the list of leafs!") call build_datablock_list(status) if (status /= 0) & call print_message(loc, "Could not build the list of data blocks!") ! calculate the shift of the snapshot counter, and the next snapshot time ! ishift = int(time / hsnap) - isnap + 1 tsnap = (ishift + isnap) * hsnap call stop_timer(iio) !------------------------------------------------------------------------------- ! end subroutine read_restart_snapshot ! !=============================================================================== ! ! subroutine WRITE_RESTART_SNAPSHOT: ! --------------------------------- ! ! Subroutine stores current restart snapshot files. This is a wrapper ! calling specific format subroutine. ! ! Arguments: ! ! thrs - the current execution time in hours; ! problem - the problem's name; ! nrun - the run number; ! status - the status flag; ! !=============================================================================== ! subroutine write_restart_snapshot(thrs, problem, nrun, status) implicit none real(kind=8) , intent(in) :: thrs character(len=*), intent(in) :: problem integer , intent(in) :: nrun integer , intent(out) :: status !------------------------------------------------------------------------------- ! status = 0 ! check if conditions for storing the restart snapshot have been met ! if (hrest < 5.0d-02 .or. thrs < irest * hrest) return call start_timer(iio) select case(snapshot_format) #ifdef HDF5 case(snapshot_hdf5) call store_restart_snapshot_h5(problem, nrun, status) #endif /* HDF5 */ case default call store_restart_snapshot_xml(problem, nrun, status) end select ! increase the restart snapshot counter ! irest = irest + 1 call stop_timer(iio) !------------------------------------------------------------------------------- ! end subroutine write_restart_snapshot ! !=============================================================================== ! ! subroutine WRITE_SNAPSHOT: ! ------------------------- ! ! Subroutine stores block data in snapshots. Block variables are grouped ! together and stored in big 4D arrays separately. This is a wrapper for ! specific format storing. ! ! Arguments: ! ! problem - the problem's name; ! !=============================================================================== ! subroutine write_snapshot(problem) use evolution, only : time #ifdef HDF5 use mpitools , only : master #endif /* HDF5 */ implicit none character(len=*), intent(in) :: problem integer :: status !------------------------------------------------------------------------------- ! if (hsnap <= 0.0e+00 .or. time < tsnap) return call start_timer(iio) select case(snapshot_format) #ifdef HDF5 case(snapshot_hdf5) call store_snapshot_h5(problem, status) if (with_xdmf) then call write_snapshot_xdmf() if (master) call write_snapshot_xdmf_master() end if #endif /* HDF5 */ case default call store_snapshot_xml(problem, status) end select ! increase the snapshot counter and calculate the next snapshot time ! isnap = isnap + 1 tsnap = (ishift + isnap) * hsnap call stop_timer(iio) !------------------------------------------------------------------------------- ! end subroutine write_snapshot ! !=============================================================================== ! ! subroutine UPDATE_DTP: ! --------------------- ! ! Subroutine updates dtp from module EVOLUTION. ! !=============================================================================== ! subroutine update_dtp() use evolution, only : time, dtp implicit none !------------------------------------------------------------------------------- ! if (precise_snapshots) then if (tsnap > time) then dtp = tsnap - time else dtp = hsnap endif end if !------------------------------------------------------------------------------- ! end subroutine update_dtp ! !=============================================================================== !! !!*** PRIVATE SUBROUTINES **************************************************** !! !=============================================================================== ! !=============================================================================== ! ! subroutine RESTORE_SNAPSHOT_PARAMETERS_XML: ! ------------------------------------------ ! ! Subroutine restores parameters from the restart snapshot. ! ! Arguments: ! ! status - the status flag (the success is 0, failure otherwise); ! !=============================================================================== ! subroutine restore_snapshot_parameters_xml(status) use helpers , only : print_message use mpitools , only : master use parameters, only : update_parameter implicit none integer, intent(inout) :: status logical :: exists character(len=255) :: dname, fname, line integer :: io, n, l, u character(len=8), dimension(14) :: keys = & [ "problem ", "eqsys ", "eos ", & "ncells ", "last_id ", & "xblocks ", "yblocks ", "zblocks ", & "xmin ", "ymin ", "zmin ", & "xmax ", "ymax ", "zmax " ] character(len=*), parameter :: loc = 'IO::restore_snapshot_parameters_xml' !------------------------------------------------------------------------------- ! status = 0 if (.not. master) return ! check if the snapshot directory and metafile exist ! write (dname, "(a,'restart-',i5.5)") trim(respath), nrest #ifdef __INTEL_COMPILER inquire (directory=dname, exist=exists) #else /* __INTEL_COMPILER */ inquire (file=dname, exist=exists) #endif /* __INTEL_COMPILER */ if (.not. exists) then call print_message(loc, trim(dname) // " does not exist!") status = 121 return end if write (fname,"(a,'/metadata.xml')") trim(dname) inquire (file=fname, exist=exists) if (.not. exists) then call print_message(loc, trim(fname) // " does not exist!") status = 121 return end if ! read requested parameter from the file ! open (newunit=io, file=fname, status='old', action='read') 10 read (io, fmt="(a)", end=20) line do n = 1, size(keys) l = index(line, trim(keys(n))) if (l > 0) then l = index(line, '>') + 1 u = index(line, '<', back = .true.) - 1 if (keys(n) == "eqsys") then call update_parameter("equation_system", trim(adjustl(line(l:u)))) else if (keys(n) == "eos") then call update_parameter("equation_of_state", trim(adjustl(line(l:u)))) else call update_parameter(trim(keys(n)), trim(adjustl(line(l:u)))) end if end if end do go to 10 20 close (io) !------------------------------------------------------------------------------- ! end subroutine restore_snapshot_parameters_xml ! !=============================================================================== ! ! subroutine READ_RESTART_SNAPSHOT_XML: ! ------------------------------------ ! ! Subroutine reads restart snapshot, i.e. parameters, meta and data blocks ! stored in the XML+binary format restart files and reconstructs ! the data structure in order to resume a terminated job. ! ! Arguments: ! ! status - the return flag to inform if subroutine succeeded or failed; ! !=============================================================================== ! subroutine read_restart_snapshot_xml(status) use blocks , only : block_meta, block_data, pointer_meta, list_meta use blocks , only : ns => nsides, nc => nchildren, nregs use blocks , only : append_metablock, append_datablock, link_blocks use blocks , only : get_mblocks use blocks , only : set_last_id, get_last_id use blocks , only : metablock_set_id, metablock_set_process use blocks , only : metablock_set_refinement use blocks , only : metablock_set_configuration use blocks , only : metablock_set_level, metablock_set_position use blocks , only : metablock_set_coordinates, metablock_set_bounds use blocks , only : metablock_set_leaf use blocks , only : change_blocks_process use coordinates , only : nn => bcells, ncells, nghosts use coordinates , only : xmin, xmax, ymin, ymax #if NDIMS == 3 use coordinates , only : zmin, zmax #endif /* NDIMS == 3 */ use equations , only : cmax, cmax2, cglm use evolution , only : step, time, dt, dth, dte use evolution , only : niterations, nrejections, errs use forcing , only : nmodes, fcoefs, einj use helpers , only : print_message use iso_c_binding, only : c_loc #ifdef MPI use mesh , only : redistribute_blocks #endif /* MPI */ use mpitools , only : nprocs, nproc use random , only : gentype, set_seeds use XML , only : XMLNode, XMLParseFile, XMLFreeTree, & XMLGetElementValue implicit none integer, intent(out) :: status type(XMLNode), pointer :: xml_ptr logical :: test character(len=256) :: snapshot_path, file_path character(len= 16) :: aname integer :: il, iu, nl, nx, nm, nd, nv, i, j, l, n, p, nu, nr #if NDIMS == 3 integer :: k #endif /* NDIMS == 3 */ integer(kind=4) :: lndims, lnprocs, lnproc, lmblocks, lnleafs, llast_id integer(kind=4) :: lncells, lnghosts, lnseeds, lnmodes integer(kind=8) :: bytes real(kind=8) :: deinj type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata integer(kind=4), dimension(:) , allocatable, target :: ids integer(kind=4), dimension(:,:) , allocatable, target :: fields integer(kind=4), dimension(:,:) , allocatable, target :: children #if NDIMS == 2 integer(kind=4), dimension(:,:,:,:) , allocatable, target :: edges integer(kind=4), dimension(:,:,:) , allocatable, target :: corners #endif /* NDIMS == 2 */ #if NDIMS == 3 integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: faces integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: edges integer(kind=4), dimension(:,:,:,:) , allocatable, target :: corners #endif /* NDIMS == 3 */ integer(kind=8), dimension(:,:) , allocatable, target :: seeds real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds real(kind=8) , dimension(:,:,:,:,:), allocatable, target :: array complex(kind=8), dimension(:,:) , allocatable, target :: lfcoefs character(len=*), parameter :: loc = 'IO::read_restart_snapshot_xml()' character(len=*), parameter :: sfmt = "(a,a,'_',i6.6,'.',a)" !------------------------------------------------------------------------------- ! status = 0 write (snapshot_path, "(a,'restart-',i5.5)") trim(respath), nrest #ifdef __INTEL_COMPILER inquire (directory=snapshot_path, exist=test) #else /* __INTEL_COMPILER */ inquire (file=snapshot_path, exist=test) #endif /* __INTEL_COMPILER */ if (.not. test) then call print_message(loc, trim(snapshot_path) // " does not exist!") status = 121 return end if snapshot_path = trim(snapshot_path) // "/" file_path = trim(snapshot_path) // "metadata.xml" inquire (file=file_path, exist=test) if (.not. test) then call print_message(loc, "The file '" // trim(file_path) // & "' does not exist.") status = 121 return end if call XMLParseFile(file_path, xml_ptr, status) call XMLGetElementValue(xml_ptr, 'Parallelization', 'nprocs' , lnprocs) call XMLGetElementValue(xml_ptr, 'Parallelization', 'nproc' , lnproc) call XMLGetElementValue(xml_ptr, 'Physics' , 'nvars' , nv) call XMLGetElementValue(xml_ptr, 'Geometry' , 'ndims' , lndims) call XMLGetElementValue(xml_ptr, 'Geometry' , 'xmin' , xmin) call XMLGetElementValue(xml_ptr, 'Geometry' , 'xmax' , xmax) call XMLGetElementValue(xml_ptr, 'Geometry' , 'ymin' , ymin) call XMLGetElementValue(xml_ptr, 'Geometry' , 'ymax' , ymax) #if NDIMS == 3 call XMLGetElementValue(xml_ptr, 'Geometry' , 'zmin' , zmin) call XMLGetElementValue(xml_ptr, 'Geometry' , 'zmax' , zmax) #endif /* NDIMS == 3 */ call XMLGetElementValue(xml_ptr, 'Mesh' , 'ncells' , lncells) call XMLGetElementValue(xml_ptr, 'Mesh' , 'nghosts' , lnghosts) call XMLGetElementValue(xml_ptr, 'Mesh' , 'mblocks' , lmblocks) call XMLGetElementValue(xml_ptr, 'Mesh' , 'nleafs' , lnleafs) call XMLGetElementValue(xml_ptr, 'Mesh' , 'last_id' , llast_id) call XMLGetElementValue(xml_ptr, 'Evolution' , 'step' , step) call XMLGetElementValue(xml_ptr, 'Evolution' , 'time' , time) call XMLGetElementValue(xml_ptr, 'Evolution' , 'dt' , dt) call XMLGetElementValue(xml_ptr, 'Evolution' , 'dth' , dth) call XMLGetElementValue(xml_ptr, 'Evolution' , 'dte' , dte) call XMLGetElementValue(xml_ptr, 'Evolution' , 'cmax' , cmax) call XMLGetElementValue(xml_ptr, 'Evolution' , 'cglm' , cglm) call XMLGetElementValue(xml_ptr, 'Evolution' , 'niterations', niterations) call XMLGetElementValue(xml_ptr, 'Evolution' , 'nrejections', nrejections) call XMLGetElementValue(xml_ptr, 'Evolution' , 'errs(1)' , errs(1)) call XMLGetElementValue(xml_ptr, 'Evolution' , 'errs(2)' , errs(2)) call XMLGetElementValue(xml_ptr, 'Evolution' , 'errs(3)' , errs(3)) call XMLGetElementValue(xml_ptr, 'Forcing' , 'nmodes' , lnmodes) call XMLGetElementValue(xml_ptr, 'Random' , 'nseeds' , lnseeds) call XMLGetElementValue(xml_ptr, 'Snapshots' , 'isnap' , isnap) cmax2 = cmax * cmax if (lndims /= NDIMS) then call print_message(loc, "The number of dimensions does not match!") return end if if (lncells /= ncells) then call print_message(loc, "The block dimensions do not match!") return end if do l = 1, lmblocks call append_metablock(pmeta, status) end do if (lmblocks /= get_mblocks()) then call print_message(loc, "Number of metablocks does not match!") end if call set_last_id(llast_id) nx = llast_id nm = lmblocks allocate(fields(16,nm), children(nc,nm), bounds(3,2,nm), & #if NDIMS == 3 faces(NDIMS,ns,ns,ns,nm), & edges(NDIMS,ns,ns,ns,nm), corners(ns,ns,ns,nm), & #else /* NDIMS == 3 */ edges(NDIMS,ns,ns,nm), corners(ns,ns,nm), & #endif /* NDIMS == 3 */ block_array(nx), stat=status) if (status == 0) then bytes = size(fields, kind=8) * kind(fields) call read_binary_xml(snapshot_path, 'fields' , c_loc(fields), & bytes, xml_ptr, status) bytes = size(children, kind=8) * kind(children) call read_binary_xml(snapshot_path, 'children', c_loc(children), & bytes, xml_ptr, status) #if NDIMS == 3 bytes = size(faces, kind=8) * kind(faces) call read_binary_xml(snapshot_path, 'faces' , c_loc(faces), & bytes, xml_ptr, status) #endif /* NDIMS == 3 */ bytes = size(edges, kind=8) * kind(edges) call read_binary_xml(snapshot_path, 'edges' , c_loc(edges), & bytes, xml_ptr, status) bytes = size(corners, kind=8) * kind(corners) call read_binary_xml(snapshot_path, 'corners' , c_loc(corners), & bytes, xml_ptr, status) bytes = size(bounds, kind=8) * kind(bounds) call read_binary_xml(snapshot_path, 'bounds' , c_loc(bounds), & bytes, xml_ptr, status) l = 0 pmeta => list_meta do while(associated(pmeta)) l = l + 1 block_array(fields(1,l))%ptr => pmeta call metablock_set_id (pmeta, fields( 1,l)) call metablock_set_process (pmeta, fields( 2,l)) call metablock_set_level (pmeta, fields( 3,l)) call metablock_set_configuration(pmeta, fields( 4,l)) call metablock_set_refinement (pmeta, fields( 5,l)) call metablock_set_position (pmeta, fields(6: 8,l)) call metablock_set_coordinates (pmeta, fields(9:11,l)) call metablock_set_bounds (pmeta, bounds(1,1,l), bounds(1,2,l), & bounds(2,1,l), bounds(2,2,l), & bounds(3,1,l), bounds(3,2,l)) if (fields(12,l) == 1) call metablock_set_leaf(pmeta) pmeta => pmeta%next end do l = 0 pmeta => list_meta do while(associated(pmeta)) l = l + 1 if (fields(14,l) > 0) pmeta%parent => block_array(fields(14,l))%ptr do p = 1, nc if (children(p,l) > 0) then pmeta%child(p)%ptr => block_array(children(p,l))%ptr end if end do #if NDIMS == 2 do j = 1, ns do i = 1, ns do n = 1, NDIMS if (edges(n,i,j,l) > 0) & pmeta%edges(i,j,n)%ptr => block_array(edges(n,i,j,l))%ptr end do if (corners(i,j,l) > 0) & pmeta%corners(i,j)%ptr => block_array(corners(i,j,l))%ptr end do end do #endif /* NDIMS == 2 */ #if NDIMS == 3 do k = 1, ns do j = 1, ns do i = 1, ns do n = 1, NDIMS if (faces(n,i,j,k,l) > 0) & pmeta%faces(i,j,k,n)%ptr => block_array(faces(n,i,j,k,l))%ptr if (edges(n,i,j,k,l) > 0) & pmeta%edges(i,j,k,n)%ptr => block_array(edges(n,i,j,k,l))%ptr end do if (corners(i,j,k,l) > 0) & pmeta%corners(i,j,k)%ptr => block_array(corners(i,j,k,l))%ptr end do end do end do #endif /* NDIMS == 3 */ pmeta => pmeta%next end do #if NDIMS == 3 deallocate(fields, children, bounds, faces, edges, corners, stat=status) #else /* NDIMS == 3 */ deallocate(fields, children, bounds, edges, corners, stat=status) #endif /* NDIMS == 3 */ if (status /= 0) & call print_message(loc, "Could not release space of metablocks!") else call print_message(loc, "Could not allocate space of metablocks!") end if if (lnmodes == nmodes) then if (lnmodes > 0) then allocate(lfcoefs(lnmodes,lndims), stat=status) if (status == 0) then bytes = size(lfcoefs, kind=8) * kind(lfcoefs) * 2 call read_binary_xml(snapshot_path, 'forcing', c_loc(lfcoefs), & bytes, xml_ptr, status) fcoefs = lfcoefs deallocate(lfcoefs, stat=status) if (status /= 0) & call print_message(loc, & "Could not release space of Fourier coefficients!") else call print_message(loc, & "Could not allocate space of Fourier coefficients!") end if end if else call print_message(loc, "The number of forcing modes does not match!") end if ! release the XML tree for 'metadata.xml' file ! call XMLFreeTree(xml_ptr) if (nprocs >= lnprocs) then ! spread the restart snapshots reading across new processes so we do not ! overload the memory; change the data block process starting from the last ! down to the first process, so we do not change the process number of blocks ! which have already been updated; ! n = nprocs / lnprocs do nl = lnprocs - 1, 0, -1 nu = nl * n call change_blocks_process(nl, nu) end do if (mod(nproc, n) == 0) then nl = nproc / n else nl = -1 end if if (nl >= lnprocs) nl = -1 if (nl >= 0) then write (file_path, sfmt) trim(snapshot_path), "datablocks", nl, "xml" inquire (file=file_path, exist=test) if (.not. test) then call print_message(loc, "The file '" // trim(file_path) // & "' does not exist.") status = 121 return end if call XMLParseFile(file_path, xml_ptr, status) call XMLGetElementValue(xml_ptr, 'DataBlocks', 'dblocks', nd) call XMLGetElementValue(xml_ptr, 'DataBlocks', 'nregs' , nr) call XMLGetElementValue(xml_ptr, 'Forcing' , 'einj' , einj) nm = lncells + 2 * lnghosts if (lnghosts >= nghosts) then il = 1 + (lnghosts - nghosts) iu = nm - (lnghosts - nghosts) else il = 1 + (nghosts - lnghosts) iu = nn - (nghosts - lnghosts) end if if (nd > 0) then #if NDIMS == 3 allocate(ids(nd), array(nv,nm,nm,nm,nr), stat=status) #else /* NDIMS == 3 */ allocate(ids(nd), array(nv,nm,nm, 1,nr), stat=status) #endif /* NDIMS == 3 */ if (status == 0) then bytes = size(ids, kind=8) * kind(ids) call read_binary_xml(snapshot_path, 'ids', c_loc(ids), & bytes, xml_ptr, status) bytes = size(array, kind=8) * kind(array) / nr do l = 1, nd call append_datablock(pdata, status) call link_blocks(block_array(ids(l))%ptr, pdata) write (aname, "('prim_',i6.6)") l call read_binary_xml(snapshot_path, aname, c_loc(array), & bytes, xml_ptr, status) if (lnghosts >= nghosts) then #if NDIMS == 3 pdata%q = array(:,il:iu,il:iu,il:iu,1) #else /* NDIMS == 3 */ pdata%q = array(:,il:iu,il:iu, : ,1) #endif /* NDIMS == 3 */ else #if NDIMS == 3 pdata%q(:,il:iu,il:iu,il:iu) = array(:,:,:,:,1) #else /* NDIMS == 3 */ pdata%q(:,il:iu,il:iu, : ) = array(:,:,:,:,1) #endif /* NDIMS == 3 */ end if write (aname, "('cons_',i6.6)") l call read_binary_xml(snapshot_path, aname, c_loc(array), & bytes * nr, xml_ptr, status) p = min(nregs, nr) if (lnghosts >= nghosts) then #if NDIMS == 3 pdata%uu(:,:,:,:,1:p) = array(:,il:iu,il:iu,il:iu,1:p) #else /* NDIMS == 3 */ pdata%uu(:,:,:,:,1:p) = array(:,il:iu,il:iu, : ,1:p) #endif /* NDIMS == 3 */ else #if NDIMS == 3 pdata%uu(:,il:iu,il:iu,il:iu,1:p) = array(:,:,:,:,1:p) #else /* NDIMS == 3 */ pdata%uu(:,il:iu,il:iu, : ,1:p) = array(:,:,:,:,1:p) #endif /* NDIMS == 3 */ end if end do deallocate(ids, array, stat=status) if (status /= 0) & call print_message(loc, "Could not release space of datablocks!") else call print_message(loc, "Could not allocate space for datablocks!") end if end if allocate(seeds(4,lnseeds), stat=status) if (status == 0) then bytes = size(seeds, kind=8) * kind(seeds) call read_binary_xml(snapshot_path, 'seeds', c_loc(seeds), & bytes, xml_ptr, status) call set_seeds(lnseeds, seeds(:,:), .false.) deallocate(seeds, stat=status) if (status /= 0) & call print_message(loc, "Could not release space of seeds!") else call print_message(loc, "Could not allocate space for seeds!") end if call XMLFreeTree(xml_ptr) else ! nl < 0 ! restore PRNG seeds for the remaining processes ! if (trim(gentype) == "same") then allocate(seeds(4,lnseeds), stat=status) if (status == 0) then write (file_path, sfmt) trim(snapshot_path), "datablocks", 0, "xml" inquire (file=file_path, exist=test) if (.not. test) then call print_message(loc, "The file '" // trim(file_path) // & "' does not exist.") status = 121 return end if call XMLParseFile(file_path, xml_ptr, status) bytes = size(seeds, kind=8) * kind(seeds) call read_binary_xml(snapshot_path, 'seeds', c_loc(seeds), & bytes, xml_ptr, status) call set_seeds(lnseeds, seeds(:,:), .false.) call XMLFreeTree(xml_ptr) deallocate(seeds, stat=status) if (status /= 0) & call print_message(loc, "Could not release space of seeds!") else call print_message(loc, "Could not allocate space for seeds!") end if end if ! gentype == "same" end if ! nl < 0 else ! nprocs < lnprocs ! divide files between processes and update the block process accordingly ! nl = 0 nd = lnprocs / nprocs nr = mod(lnprocs, nprocs) do n = 0, nprocs - 1 if (n < nr) then il = n * (nd + 1) iu = il + nd else il = n * nd + nr iu = il + nd - 1 end if do i = il, iu call change_blocks_process(i, n) end do if (n == nproc) then nl = il nu = iu end if end do do n = nl, nu write (file_path, sfmt) trim(snapshot_path), "datablocks", n, "xml" inquire (file=file_path, exist=test) if (.not. test) then call print_message(loc, "The file '" // trim(file_path) // & "' does not exist.") status = 121 return end if call XMLParseFile(file_path, xml_ptr, status) call XMLGetElementValue(xml_ptr, 'DataBlocks', 'dblocks', nd) call XMLGetElementValue(xml_ptr, 'DataBlocks', 'nregs' , nr) call XMLGetElementValue(xml_ptr, 'Forcing' , 'einj' , deinj) einj = einj + deinj nm = lncells + 2 * lnghosts if (lnghosts >= nghosts) then il = 1 + (lnghosts - nghosts) iu = nm - (lnghosts - nghosts) else il = 1 + (nghosts - lnghosts) iu = nn - (nghosts - lnghosts) end if if (nd > 0) then #if NDIMS == 3 allocate(ids(nd), array(nv,nm,nm,nm,nr), stat=status) #else /* NDIMS == 3 */ allocate(ids(nd), array(nv,nm,nm, 1,nr), stat=status) #endif /* NDIMS == 3 */ if (status == 0) then bytes = size(ids, kind=8) * kind(ids) call read_binary_xml(snapshot_path, 'ids', c_loc(ids), & bytes, xml_ptr, status) bytes = size(array, kind=8) * kind(array) / nr do l = 1, nd call append_datablock(pdata, status) call link_blocks(block_array(ids(l))%ptr, pdata) write (aname, "('prim_',i6.6)") l call read_binary_xml(snapshot_path, aname, c_loc(array), & bytes, xml_ptr, status) if (lnghosts >= nghosts) then #if NDIMS == 3 pdata%q = array(:,il:iu,il:iu,il:iu,1) #else /* NDIMS == 3 */ pdata%q = array(:,il:iu,il:iu, : ,1) #endif /* NDIMS == 3 */ else #if NDIMS == 3 pdata%q(:,il:iu,il:iu,il:iu) = array(:,:,:,:,1) #else /* NDIMS == 3 */ pdata%q(:,il:iu,il:iu, : ) = array(:,:,:,:,1) #endif /* NDIMS == 3 */ end if write (aname, "('cons_',i6.6)") l call read_binary_xml(snapshot_path, aname, c_loc(array), & bytes * nr, xml_ptr, status) p = min(nregs, nr) if (lnghosts >= nghosts) then #if NDIMS == 3 pdata%uu(:,:,:,:,1:p) = array(:,il:iu,il:iu,il:iu,1:p) #else /* NDIMS == 3 */ pdata%uu(:,:,:,:,1:p) = array(:,il:iu,il:iu, : ,1:p) #endif /* NDIMS == 3 */ else #if NDIMS == 3 pdata%uu(:,il:iu,il:iu,il:iu,1:p) = array(:,:,:,:,1:p) #else /* NDIMS == 3 */ pdata%uu(:,il:iu,il:iu, : ,1:p) = array(:,:,:,:,1:p) #endif /* NDIMS == 3 */ end if end do deallocate(ids, array, stat=status) if (status /= 0) & call print_message(loc, "Could not release space of datablocks!") else call print_message(loc, "Could not allocate space for datablocks!") end if end if call XMLFreeTree(xml_ptr) end do ! n = nl, nu allocate(seeds(4,lnseeds), stat=status) if (status == 0) then write (file_path, sfmt) trim(snapshot_path), "datablocks", nproc, "xml" inquire (file=file_path, exist=test) if (.not. test) then call print_message(loc, "The file '" // trim(file_path) // & "' does not exist.") status = 121 return end if call XMLParseFile(file_path, xml_ptr, status) bytes = size(seeds, kind=8) * kind(seeds) call read_binary_xml(snapshot_path, 'seeds', c_loc(seeds), & bytes, xml_ptr, status) call set_seeds(lnseeds, seeds(:,:), .false.) call XMLFreeTree(xml_ptr) deallocate(seeds, stat=status) if (status /= 0) & call print_message(loc, "Could not release space of seeds!") else call print_message(loc, "Could not allocate space for seeds!") end if end if ! nprocs >= lnprocs if (allocated(block_array)) deallocate(block_array) #ifdef MPI call redistribute_blocks(status) #endif /* MPI */ !------------------------------------------------------------------------------- ! end subroutine read_restart_snapshot_xml ! !=============================================================================== ! ! subroutine STORE_RESTART_SNAPSHOT_XML: ! ------------------------------------- ! ! Subroutine stores a restart snapshot, i.e. parameters, meta and data blocks ! using the XML format for parameters and binary format for meta and data ! block fields. ! ! Arguments: ! ! problem - the problem's name; ! nrun - the snapshot number; ! status - the status flag to inform if subroutine succeeded or failed; ! !=============================================================================== ! subroutine store_restart_snapshot_xml(problem, nrun, status) use blocks , only : block_meta, block_data, list_meta, list_data use blocks , only : get_mblocks, get_dblocks, get_nleafs use blocks , only : get_last_id use blocks , only : ns => nsides, nc => nchildren, nr => nregs use coordinates , only : nn => bcells, ncells, nghosts, minlev, maxlev use coordinates , only : xmin, xmax, ymin, ymax #if NDIMS == 3 use coordinates , only : zmin, zmax #endif /* NDIMS == 3 */ use coordinates , only : bdims => domain_base_dims use equations , only : eqsys, eos, nv, cmax, cglm use evolution , only : step, time, dt, dth, dte, cfl, glm_alpha, errs use evolution , only : atol, rtol, mrej, niterations, nrejections use forcing , only : nmodes, fcoefs, einj use hash , only : hash_info use helpers , only : print_message use iso_c_binding, only : c_loc use mpitools , only : nprocs, nproc use parameters , only : parameter_file use random , only : gentype, nseeds, get_seeds use XML , only : XMLNode, XMLAddElement, & XMLInitTree, XMLFreeTree, XMLSaveTree implicit none character(len=*), intent(in ) :: problem integer , intent(in ) :: nrun integer , intent( out) :: status character(len=*), parameter :: loc = "IO::store_restart_snapshot_xml()" logical :: test character(len=128) :: str integer(kind=8) :: bytes integer :: htype, hsize integer :: nd, nl, nm, nx, i, j, l, n, p #if NDIMS == 3 integer :: k #endif /* NDIMS == 3 */ character(len=:), allocatable :: rpath, cmd, aname type(XMLNode) , pointer :: xml_ptr type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata integer(kind=4), dimension(:) , allocatable, target :: ids integer(kind=4), dimension(:,:) , allocatable, target :: fields integer(kind=4), dimension(:,:) , allocatable, target :: children #if NDIMS == 2 integer(kind=4), dimension(:,:,:,:) , allocatable, target :: edges integer(kind=4), dimension(:,:,:) , allocatable, target :: corners #endif /* NDIMS == 2 */ #if NDIMS == 3 integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: faces integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: edges integer(kind=4), dimension(:,:,:,:) , allocatable, target :: corners #endif /* NDIMS == 3 */ integer(kind=8), dimension(:,:) , allocatable, target :: seeds real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds !------------------------------------------------------------------------------- ! status = 0 call hash_info("xxh64", htype, hsize) write (str, "('restart-',i5.5,'/')") nrun rpath = trim(str) cmd = "mkdir -p " // trim(rpath) #ifdef __INTEL_COMPILER inquire (directory=rpath, exist=test) do while(.not. test) if (.not. test) call execute_command_line(cmd) inquire (directory=rpath, exist=test) end do #else /* __INTEL_COMPILER */ inquire (file=rpath, exist=test) do while(.not. test) if (.not. test) call execute_command_line(cmd) inquire (file=rpath, exist=test) end do #endif /* __INTEL_COMPILER */ nx = get_last_id() nm = get_mblocks() nd = get_dblocks() nl = get_nleafs() aname = '' if (nproc == 0) then cmd = "cp -a " // parameter_file // " " // rpath if (status == 0) then call execute_command_line(cmd) else call print_message(loc, "Cannot get the location of parameter file!") return end if call XMLInitTree(xml_ptr) call XMLAddElement(xml_ptr, "Problem" , "problem" , problem) call XMLAddElement(xml_ptr, "Parallelization", "nprocs" , nprocs) call XMLAddElement(xml_ptr, "Parallelization", "nproc" , nproc ) call XMLAddElement(xml_ptr, "Physics" , "eqsys" , eqsys ) call XMLAddElement(xml_ptr, "Physics" , "eos" , eos ) call XMLAddElement(xml_ptr, "Physics" , "nvars" , nv ) call XMLAddElement(xml_ptr, "Geometry" , "ndims" , NDIMS ) call XMLAddElement(xml_ptr, "Geometry" , "xblocks" , bdims(1)) call XMLAddElement(xml_ptr, "Geometry" , "yblocks" , bdims(2)) #if NDIMS == 3 call XMLAddElement(xml_ptr, "Geometry" , "zblocks" , bdims(3)) #endif /* NDIMS */ call XMLAddElement(xml_ptr, "Geometry" , "xmin" , xmin) call XMLAddElement(xml_ptr, "Geometry" , "xmax" , xmax) call XMLAddElement(xml_ptr, "Geometry" , "ymin" , ymin) call XMLAddElement(xml_ptr, "Geometry" , "ymax" , ymax) #if NDIMS == 3 call XMLAddElement(xml_ptr, "Geometry" , "zmin" , zmin) call XMLAddElement(xml_ptr, "Geometry" , "zmax" , zmax) #endif /* NDIMS */ call XMLAddElement(xml_ptr, "Mesh" , "minlev" , minlev) call XMLAddElement(xml_ptr, "Mesh" , "maxlev" , maxlev) call XMLAddElement(xml_ptr, "Mesh" , "ncells" , ncells) call XMLAddElement(xml_ptr, "Mesh" , "nghosts" , nghosts) call XMLAddElement(xml_ptr, "Mesh" , "bcells" , nn) call XMLAddElement(xml_ptr, "Mesh" , "nchildren" , nc) call XMLAddElement(xml_ptr, "Mesh" , "mblocks" , nm) call XMLAddElement(xml_ptr, "Mesh" , "nleafs" , nl) call XMLAddElement(xml_ptr, "Mesh" , "last_id" , nx) call XMLAddElement(xml_ptr, "Evolution", "step" , step) call XMLAddElement(xml_ptr, "Evolution", "time" , time) call XMLAddElement(xml_ptr, "Evolution", "dt" , dt) call XMLAddElement(xml_ptr, "Evolution", "dth" , dth) call XMLAddElement(xml_ptr, "Evolution", "dte" , dte) call XMLAddElement(xml_ptr, "Evolution", "cfl" , cfl) call XMLAddElement(xml_ptr, "Evolution", "cmax" , cmax) call XMLAddElement(xml_ptr, "Evolution", "cglm" , cglm) call XMLAddElement(xml_ptr, "Evolution", "glm_alpha" , glm_alpha) call XMLAddElement(xml_ptr, "Evolution", "absolute_tolerance", atol) call XMLAddElement(xml_ptr, "Evolution", "relative_tolerance", rtol) call XMLAddElement(xml_ptr, "Evolution", "maximum_rejections", mrej) call XMLAddElement(xml_ptr, "Evolution", "niterations" , niterations) call XMLAddElement(xml_ptr, "Evolution", "nrejections" , nrejections) call XMLAddElement(xml_ptr, "Evolution", "errs(1)" , errs(1)) call XMLAddElement(xml_ptr, "Evolution", "errs(2)" , errs(2)) call XMLAddElement(xml_ptr, "Evolution", "errs(3)" , errs(3)) call XMLAddElement(xml_ptr, "Forcing" , "nmodes" , nmodes) call XMLAddElement(xml_ptr, "Random" , "gentype" , gentype) call XMLAddElement(xml_ptr, "Random" , "nseeds" , nseeds) call XMLAddElement(xml_ptr, "Snapshots", "isnap" , isnap) allocate(fields(16,nm), children(nc,nm), bounds(3,2,nm), & #if NDIMS == 3 faces(NDIMS,ns,ns,ns,nm), & edges(NDIMS,ns,ns,ns,nm), corners(ns,ns,ns,nm), & #else /* NDIMS == 3 */ edges(NDIMS,ns,ns,nm), corners(ns,ns,nm), & #endif /* NDIMS == 3 */ stat = status) if (status == 0) then fields = -1 children = -1 #if NDIMS == 3 faces = -1 #endif /* NDIMS == 3 */ edges = -1 corners = -1 bounds = 0.0d+00 l = 0 pmeta => list_meta do while(associated(pmeta)) l = l + 1 fields( 1,l) = pmeta%id fields( 2,l) = pmeta%process fields( 3,l) = pmeta%level fields( 4,l) = pmeta%conf fields( 5,l) = pmeta%refine fields( 6,l) = pmeta%pos(1) fields( 7,l) = pmeta%pos(2) #if NDIMS == 3 fields( 8,l) = pmeta%pos(3) #endif /* NDIMS == 3 */ fields( 9,l) = pmeta%coords(1) fields(10,l) = pmeta%coords(2) #if NDIMS == 3 fields(11,l) = pmeta%coords(3) #endif /* NDIMS == 3 */ if (pmeta%leaf) fields(12,l) = 1 if (associated(pmeta%data) ) fields(13,l) = 1 if (associated(pmeta%parent)) fields(14,l) = pmeta%parent%id do p = 1, nc if (associated(pmeta%child(p)%ptr)) & children(p,l) = pmeta%child(p)%ptr%id end do #if NDIMS == 2 do j = 1, ns do i = 1, ns do n = 1, NDIMS if (associated(pmeta%edges(i,j,n)%ptr)) & edges(n,i,j,l) = pmeta%edges(i,j,n)%ptr%id end do ! NDIMS if (associated(pmeta%corners(i,j)%ptr)) & corners(i,j,l) = pmeta%corners(i,j)%ptr%id end do end do #endif /* NDIMS == 2 */ #if NDIMS == 3 do k = 1, ns do j = 1, ns do i = 1, ns do n = 1, NDIMS if (associated(pmeta%faces(i,j,k,n)%ptr)) & faces(n,i,j,k,l) = pmeta%faces(i,j,k,n)%ptr%id if (associated(pmeta%edges(i,j,k,n)%ptr)) & edges(n,i,j,k,l) = pmeta%edges(i,j,k,n)%ptr%id end do ! NDIMS if (associated(pmeta%corners(i,j,k)%ptr)) & corners(i,j,k,l) = pmeta%corners(i,j,k)%ptr%id end do end do end do #endif /* NDIMS == 3 */ bounds(1,:,l) = [ pmeta%xmin, pmeta%xmax ] bounds(2,:,l) = [ pmeta%ymin, pmeta%ymax ] #if NDIMS == 3 bounds(3,:,l) = [ pmeta%zmin, pmeta%zmax ] #endif /* NDIMS == 3 */ pmeta => pmeta%next end do bytes = size(fields, kind=8) * kind(fields) call write_binary_xml(rpath, "fields", "metablock_fields", & c_loc(fields), bytes, "int32", shape(fields), & htype, snapshot_compressor, compression_level, & snapshot_encoder, xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store metablock fields!") bytes = size(children, kind=8) * kind(children) call write_binary_xml(rpath, "children", "metablock_children", & c_loc(children), bytes, "int32", shape(children),& htype, snapshot_compressor, compression_level, & snapshot_encoder, xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store metablock children!") #if NDIMS == 3 bytes = size(faces, kind=8) * kind(faces) call write_binary_xml(rpath, "faces", "metablock_faces", & c_loc(faces), bytes, "int32", shape(faces), & htype, snapshot_compressor, compression_level, & snapshot_encoder, xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store metablock faces!") #endif /* NDIMS == 3 */ bytes = size(edges, kind=8) * kind(edges) call write_binary_xml(rpath, "edges", "metablock_edges", & c_loc(edges), bytes, "int32", shape(edges), & htype, snapshot_compressor, compression_level, & snapshot_encoder, xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store metablock edges!") bytes = size(corners, kind=8) * kind(corners) call write_binary_xml(rpath, "corners", "metablock_corners", & c_loc(corners), bytes, "int32", shape(corners), & htype, snapshot_compressor, compression_level, & snapshot_encoder, xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store metablock corners!") bytes = size(bounds, kind=8) * kind(bounds) call write_binary_xml(rpath, "bounds", "metablock_bounds", & c_loc(bounds), bytes, "float64", shape(bounds), & htype, snapshot_compressor, & compression_level, snapshot_encoder, & xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store metablock bounds!") if (nmodes > 0) then bytes = size(fcoefs, kind=8) * kind(fcoefs) * 2 call write_binary_xml(rpath, "forcing", "forcing_coefficients", & c_loc(fcoefs), bytes, "complex64", & shape(fcoefs), htype, snapshot_compressor, & compression_level, snapshot_encoder, & xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store forcing coefficients!") end if #if NDIMS == 3 deallocate(fields, children, bounds, faces, & edges, corners, stat=status) #else /* NDIMS == 3 */ deallocate(fields, children, bounds, edges, corners, stat=status) #endif /* NDIMS == 3 */ if (status /= 0) & call print_message(loc, "Could not deallocate space of metablocks!") else call print_message(loc, "Cannot allocate space for metablocks!") return end if #if NDIMS == 3 #endif /* NDIMS == 3 */ call XMLSaveTree(xml_ptr, trim(rpath) // "metadata.xml") call XMLFreeTree(xml_ptr) end if call XMLInitTree(xml_ptr) call XMLAddElement(xml_ptr, "DataBlocks", "nprocs" , nprocs) call XMLAddElement(xml_ptr, "DataBlocks", "nproc" , nproc ) call XMLAddElement(xml_ptr, "DataBlocks", "ndims" , NDIMS) call XMLAddElement(xml_ptr, "DataBlocks", "ncells" , ncells) call XMLAddElement(xml_ptr, "DataBlocks", "nghosts", nghosts) call XMLAddElement(xml_ptr, "DataBlocks", "bcells" , nn) call XMLAddElement(xml_ptr, "DataBlocks", "dblocks", nd) call XMLAddElement(xml_ptr, "DataBlocks", "nregs" , nr) call XMLAddElement(xml_ptr, "Forcing" , "einj" , einj) call XMLAddElement(xml_ptr, "Random" , "gentype", gentype) call XMLAddElement(xml_ptr, "Random" , "nseeds" , nseeds) if (nd > 0) then allocate(ids(nd), stat = status) if (status == 0) then l = 0 pdata => list_data do while(associated(pdata)) l = l + 1 ids(l) = pdata%meta%id bytes = size(pdata%q, kind=8) * kind(pdata%q) write (str,"('prim_',i6.6)") l aname = trim(str) write (str,"('datablock_prim_',i6.6,'_',i6.6)") nproc, l call write_binary_xml(rpath, aname, trim(str), c_loc(pdata%q), & bytes, "float64", shape(pdata%q), htype, & snapshot_compressor, compression_level, & snapshot_encoder, xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store primitive variables!") bytes = size(pdata%uu, kind=8) * kind(pdata%uu) write (str,"('cons_',i6.6)") l aname = trim(str) write (str,"('datablock_cons_',i6.6,'_',i6.6)") nproc, l call write_binary_xml(rpath, aname, trim(str), c_loc(pdata%uu), & bytes, "float64", shape(pdata%uu), htype, & snapshot_compressor, compression_level, & snapshot_encoder, xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store conservative variables!") pdata => pdata%next end do bytes = size(ids, kind=8) * kind(ids) write (str,"('datablock_ids_',i6.6)") nproc call write_binary_xml(rpath, "ids", trim(str), c_loc(ids), & bytes, "int32", shape(ids), htype, & snapshot_compressor, compression_level, & snapshot_encoder, xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store block IDs!") if (allocated(ids)) deallocate(ids) else call print_message(loc, "Cannot allocate space for datablocks!") status = 1001 return end if end if allocate(seeds(4,nseeds), stat = status) if (status == 0) then call get_seeds(seeds(:,:)) bytes = size(seeds, kind=8) * kind(seeds) write (str,"('random_seeds_',i6.6)") nproc call write_binary_xml(rpath, 'seeds', trim(str), c_loc(seeds), & bytes, "int64", shape(seeds), htype, & snapshot_compressor, compression_level, & snapshot_encoder, xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store random seeds!") if (allocated(seeds)) deallocate(seeds) else call print_message(loc, & "Cannot allocate space for random generator seeds!") status = 1001 return end if write (str,"(a,'datablocks_',i6.6,'.xml')") trim(rpath), nproc call XMLSaveTree(xml_ptr, trim(str)) call XMLFreeTree(xml_ptr) !------------------------------------------------------------------------------- ! end subroutine store_restart_snapshot_xml ! !=============================================================================== ! ! subroutine STORE_SNAPSHOT_XML: ! ----------------------------- ! ! Subroutine stores a regular snapshot, i.e. parameters, leafs and data blocks ! using the XML format for metadata and binary format for meta and data ! block fields. ! ! Arguments: ! ! problem - the problem's name; ! status - the status flag to inform if subroutine succeeded or failed; ! !=============================================================================== ! subroutine store_snapshot_xml(problem, status) use blocks , only : block_meta, block_data, list_meta, list_data use blocks , only : get_dblocks, get_nleafs use coordinates , only : nn => bcells, ncells, nghosts, minlev, maxlev use coordinates , only : xmin, xmax, ymin, ymax #if NDIMS == 3 use coordinates , only : zmin, zmax #endif /* NDIMS == 3 */ use coordinates , only : bdims => domain_base_dims use equations , only : eqsys, eos, nv, pvars, adiabatic_index, csnd use evolution , only : step, time, dt, cfl, glm_alpha use helpers , only : print_message use iso_c_binding, only : c_loc use mpitools , only : nprocs, nproc use parameters , only : parameter_file use sources , only : viscosity, resistivity use XML , only : XMLNode, XMLAddElement, & XMLInitTree, XMLFreeTree, XMLSaveTree implicit none character(len=*), intent(in ) :: problem integer , intent( out) :: status character(len=*), parameter :: loc = "IO::store_snapshot_xml()" logical :: test character(len=128) :: str integer(kind=8) :: bytes integer :: nd, nl, l, p character(len=:), allocatable :: rpath, cmd, vars type(XMLNode) , pointer :: xml_ptr type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata integer(kind=4), dimension(:) , allocatable, target :: ids integer(kind=4), dimension(:,:) , allocatable, target :: fields real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds real(kind=8) , dimension(:,:,:,:), allocatable, target :: array !------------------------------------------------------------------------------- ! status = 0 write (str, "('snapshot-',i9.9,'/')") isnap rpath = trim(str) cmd = "mkdir -p " // trim(rpath) #ifdef __INTEL_COMPILER inquire (directory=rpath, exist=test) do while(.not. test) if (.not. test) call execute_command_line(cmd) inquire (directory=rpath, exist=test) end do #else /* __INTEL_COMPILER */ inquire (file=rpath, exist=test) do while(.not. test) if (.not. test) call execute_command_line(cmd) inquire (file=rpath, exist=test) end do #endif /* __INTEL_COMPILER */ nd = get_dblocks() nl = get_nleafs() write (str, "(20(a,1x))") pvars vars = trim(str) if (nproc == 0) then cmd = "cp -a " // parameter_file // " " // rpath if (status == 0) then call execute_command_line(cmd) else call print_message(loc, "Cannot get the location of parameter file!") return end if call XMLInitTree(xml_ptr) call XMLAddElement(xml_ptr, "Problem" , "problem" , problem) call XMLAddElement(xml_ptr, "Parallelization", "nprocs" , nprocs) call XMLAddElement(xml_ptr, "Parallelization", "nproc" , nproc ) call XMLAddElement(xml_ptr, "Physics" , "eqsys" , eqsys ) call XMLAddElement(xml_ptr, "Physics" , "eos" , eos ) call XMLAddElement(xml_ptr, "Physics" , "nvars" , nv ) call XMLAddElement(xml_ptr, "Physics" , "adiabatic_index", adiabatic_index) call XMLAddElement(xml_ptr, "Physics" , "sound_speed" , csnd) call XMLAddElement(xml_ptr, "Physics" , "viscosity" , viscosity) call XMLAddElement(xml_ptr, "Physics" , "resistivity" , resistivity) call XMLAddElement(xml_ptr, "Geometry" , "ndims" , NDIMS ) call XMLAddElement(xml_ptr, "Geometry" , "xblocks" , bdims(1)) call XMLAddElement(xml_ptr, "Geometry" , "yblocks" , bdims(2)) #if NDIMS == 3 call XMLAddElement(xml_ptr, "Geometry" , "zblocks" , bdims(3)) #endif /* NDIMS */ call XMLAddElement(xml_ptr, "Geometry" , "xmin" , xmin) call XMLAddElement(xml_ptr, "Geometry" , "xmax" , xmax) call XMLAddElement(xml_ptr, "Geometry" , "ymin" , ymin) call XMLAddElement(xml_ptr, "Geometry" , "ymax" , ymax) #if NDIMS == 3 call XMLAddElement(xml_ptr, "Geometry" , "zmin" , zmin) call XMLAddElement(xml_ptr, "Geometry" , "zmax" , zmax) #endif /* NDIMS */ call XMLAddElement(xml_ptr, "Mesh" , "minlev" , minlev) call XMLAddElement(xml_ptr, "Mesh" , "maxlev" , maxlev) call XMLAddElement(xml_ptr, "Mesh" , "ncells" , ncells) call XMLAddElement(xml_ptr, "Mesh" , "nghosts" , nghosts) call XMLAddElement(xml_ptr, "Mesh" , "bcells" , nn) call XMLAddElement(xml_ptr, "Mesh" , "nleafs" , nl) call XMLAddElement(xml_ptr, "Evolution", "step" , step) call XMLAddElement(xml_ptr, "Evolution", "time" , time) call XMLAddElement(xml_ptr, "Evolution", "dt" , dt) call XMLAddElement(xml_ptr, "Evolution", "cfl" , cfl) call XMLAddElement(xml_ptr, "Evolution", "glm_alpha" , glm_alpha) call XMLAddElement(xml_ptr, "Snapshots", "isnap" , isnap) call XMLAddElement(xml_ptr, "Snapshots", "variables" , trim(vars)) allocate(fields(8,nl), bounds(3,2,nl), stat = status) if (status == 0) then fields = -1 bounds = 0.0d+00 l = 0 pmeta => list_meta do while(associated(pmeta)) if (pmeta%leaf) then l = l + 1 fields(1,l) = pmeta%id fields(2,l) = pmeta%level fields(3,l) = pmeta%coords(1) fields(4,l) = pmeta%coords(2) #if NDIMS == 3 fields(5,l) = pmeta%coords(3) #endif /* NDIMS == 3 */ bounds(1,:,l) = [ pmeta%xmin, pmeta%xmax ] bounds(2,:,l) = [ pmeta%ymin, pmeta%ymax ] #if NDIMS == 3 bounds(3,:,l) = [ pmeta%zmin, pmeta%zmax ] #endif /* NDIMS == 3 */ end if pmeta => pmeta%next end do bytes = size(fields, kind=8) * kind(fields) call write_binary_xml(rpath, "fields", "metablock_fields", & c_loc(fields), bytes, "int32", shape(fields), & hash_type, snapshot_compressor, & compression_level, snapshot_encoder, & xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store metablock fields!") bytes = size(bounds, kind=8) * kind(bounds) call write_binary_xml(rpath, "bounds", "metablock_bounds", & c_loc(bounds), bytes, "float64", shape(bounds), & hash_type, snapshot_compressor, & compression_level, snapshot_encoder, & xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store metablock bounds!") if (allocated(fields)) deallocate(fields) if (allocated(bounds)) deallocate(bounds) else call print_message(loc, "Cannot allocate space for metablocks!") status = 1001 return end if call XMLSaveTree(xml_ptr, trim(rpath) // "metadata.xml") call XMLFreeTree(xml_ptr) end if ! meta data file is stored only on the master process call XMLInitTree(xml_ptr) call XMLAddElement(xml_ptr, "DataBlocks", "nprocs" , nprocs) call XMLAddElement(xml_ptr, "DataBlocks", "nproc" , nproc ) call XMLAddElement(xml_ptr, "DataBlocks", "ndims" , NDIMS) call XMLAddElement(xml_ptr, "DataBlocks", "ncells" , ncells) call XMLAddElement(xml_ptr, "DataBlocks", "nghosts", nghosts) call XMLAddElement(xml_ptr, "DataBlocks", "bcells" , nn) call XMLAddElement(xml_ptr, "DataBlocks", "nvars" , nv) call XMLAddElement(xml_ptr, "DataBlocks", "dblocks", nd) call XMLAddElement(xml_ptr, "DataBlocks", "variables", trim(vars)) if (nd > 0) then #if NDIMS == 3 allocate(ids(nd), array(nn,nn,nn,nd), stat = status) #else /* NDIMS == 3 */ allocate(ids(nd), array(nn,nn, 1,nd), stat = status) #endif /* NDIMS == 3 */ if (status == 0) then l = 0 pdata => list_data do while(associated(pdata)) l = l + 1 ids(l) = pdata%meta%id pdata => pdata%next end do ! data blocks bytes = size(ids, kind=8) * kind(ids) write (str, "('datablock_ids_',i6.6)") nproc call write_binary_xml(rpath, "ids", trim(str), c_loc(ids), & bytes, "int32", shape(ids), hash_type, & snapshot_compressor, compression_level, & snapshot_encoder, xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store block IDs!") bytes = size(array, kind=8) * kind(array) do p = 1, nv l = 0 pdata => list_data do while(associated(pdata)) l = l + 1 array(:,:,:,l) = pdata%q(p,:,:,:) pdata => pdata%next end do write (str,"('datablock_',a,'_',i6.6)") trim(pvars(p)), nproc call write_binary_xml(rpath, pvars(p), trim(str), c_loc(array), & bytes, "float64", shape(array), hash_type, & snapshot_compressor, compression_level, & snapshot_encoder, xml_ptr, status) if (status /= 0) & call print_message(loc, "Could not store variable '" // & trim(pvars(p)) // "'!") end do if (allocated(ids)) deallocate(ids) if (allocated(array)) deallocate(array) else call print_message(loc, "Cannot allocate space for datablocks!") status = 1001 return end if end if write (str,"(a,'datablocks_',i6.6,'.xml')") trim(rpath), nproc call XMLSaveTree(xml_ptr, trim(str)) call XMLFreeTree(xml_ptr) !------------------------------------------------------------------------------- ! end subroutine store_snapshot_xml ! !=============================================================================== ! ! subroutine READ_BINARY_XML: ! -------------------------- ! ! This subroutine serves the purpose of reading binary data from ! a specified data path and array name, while also performing integrity ! checks using hash functions and processing associated XML metadata. ! ! Arguments: ! ! data_path - The file path indicating the location of the stored data. ! array_name - The name of the target array for data reading. ! array_ptr - A pointer intended to hold the read data from the array. ! array_bytes - The allocated size in bytes for the array. ! xml_ptr - A pointer referring to an XML tree containing ! associated metadata. ! status - A flag conveying the status of the subroutine. ! !=============================================================================== ! subroutine read_binary_xml(data_path, array_name, array_ptr, array_bytes, & xml_ptr, status) use compression , only : get_compressor_id, decompress use compression , only : get_encoder_id, decode use hash , only : hash_info, check_digest, digest_integer use helpers , only : print_message use iso_c_binding, only : c_loc, c_ptr, c_f_pointer use XML , only : XMLNode, XMLGetElementValue, & XMLHasAttribute, XMLGetAttributeValue implicit none character(len=*) , intent(in ) :: data_path, array_name type(c_ptr) , intent(in ) :: array_ptr integer(kind=8) , intent(in ) :: array_bytes type(XMLNode), pointer, intent(in ) :: xml_ptr integer , intent( out) :: status character(len=*), parameter :: loc = "IO::read_binary_xml()" logical :: test character(len=256) :: str character(len=:), allocatable :: file_path, compressor, encoder integer :: io, item_size integer :: digest_type, digest_length integer :: compressor_id, encoder_id integer(kind=8) :: hash, usize, csize integer(kind=1), dimension(:), pointer :: array integer(kind=1), dimension(:), allocatable, target :: buffer !------------------------------------------------------------------------------- ! status = 0 compressor = '' encoder = '' call XMLGetElementValue(xml_ptr, 'BinaryFiles', array_name, str) file_path = trim(data_path) // trim(str) inquire (file=file_path, exist=test) if (.not. test) then call print_message(loc, "The file '" // trim(file_path) // & "' does not exist.") status = 121 return end if call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, 'size', usize) if (usize /= array_bytes) then call print_message(loc, "Array size mismatch. The size of the array '" & // trim(array_name) // "' in memory " // & "does not match the stored array size.") status = 1 return end if call c_f_pointer(array_ptr, array, [ array_bytes ]) test = XMLHasAttribute(xml_ptr, 'BinaryFiles', array_name, & 'compression_format') if (test) then call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & 'compression_format', str) compressor = trim(str) test = compressor /= 'none' end if if (test) then compressor_id = get_compressor_id(compressor) call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & 'compressed_size', csize) allocate(buffer(csize)) open (newunit=io, file=file_path, access='stream', & status='old', action='read') read (io) buffer close (io) call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & 'digest_type', str) call hash_info(trim(str), digest_type, digest_length) call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & 'compressed_digest', str) call digest_integer(trim(str), hash) call check_digest(loc, file_path, c_loc(buffer), csize, hash, digest_type) call decompress(compressor_id, c_loc(buffer), csize, array_ptr, usize, status) if (status /= 0) then call print_message(loc, "Array size mismatch. The size of the array '" & // trim(array_name) // "' in memory " // & "does not match the decompressed array size.") status = 1 return end if deallocate(buffer) test = XMLHasAttribute(xml_ptr, 'BinaryFiles', array_name, 'data_encoder') if (test) then call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & 'data_encoder', str) encoder = trim(str) test = encoder /= 'none' end if if (test) then encoder_id = get_encoder_id(encoder) call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & 'data_type', str) select case(str) case('complex64', 'float64', 'int64') item_size = 8 case('float32', 'int32') item_size = 4 case default item_size = 1 end select allocate(buffer(usize)) buffer = array call decode(encoder_id, item_size, array_bytes, c_loc(buffer), array) deallocate(buffer) end if else open (newunit=io, file=file_path, access='stream', & status='old', action='read') read (io) array close (io) end if call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & 'digest_type', str) call hash_info(trim(str), digest_type, digest_length) call XMLGetAttributeValue(xml_ptr, 'BinaryFiles', array_name, & 'digest', str) call digest_integer(trim(str), hash) call check_digest(loc, file_path, array_ptr, array_bytes, hash, digest_type) end subroutine read_binary_xml ! !=============================================================================== ! ! subroutine WRITE_BINARY_XML: ! --------------------------- ! ! This subroutine is designed to write compressed binary data to a specified ! file path and array name. It includes functionality for ensuring data ! integrity through hash functions, as well as storing relevant metadata ! in XML format. ! ! Arguments: ! ! data_path - The file path indicating the location of the stored data. ! array_name - The name of the target array for data reading. ! array_ptr - A pointer intended to hold the read data from the array. ! array_bytes - The allocated size in bytes for the array. ! array_dtype - The data type of the array elements. ! array_dims - The dimensions (shape) of the array. ! digest_id - The method ID used for calculating hashes. ! compressor_id - The method ID used for compression of the array. ! level - The compression level. ! encoder_id - The method ID used for data encoding before compression. ! xml_ptr - A pointer referring to an XML tree containing ! associated metadata. ! status - A flag conveying the status of the subroutine. ! !=============================================================================== ! subroutine write_binary_xml(data_path, array_name, array_file, array_ptr, & array_bytes, array_dtype, array_dims, & digest_id, compressor_id, level, & encoder_id, xml_ptr, status) use compression , only : is_compressor_on, is_encoder_on, & get_compressor_name, get_encoder_name, & get_compressed_file_suffix, compression_bound, & encode, compress use hash , only : hash_name, digest, digest_string use iso_c_binding, only : c_loc, c_ptr, c_f_pointer use XML , only : XMLNode, XMLAddElement implicit none character(len=*) , intent(in ) :: data_path, array_name, & array_file, array_dtype type(c_ptr) , intent(in ) :: array_ptr integer(kind=8) , intent(in ) :: array_bytes integer, dimension(:) , intent(in ) :: array_dims integer , intent(in ) :: digest_id integer , intent(in ) :: compressor_id, level, encoder_id type(XMLNode), pointer, intent(inout) :: xml_ptr integer , intent( out) :: status character(len=1024) :: str character(len=:), allocatable :: filename, filepath, file_suffix character(len=:), allocatable :: digest_name, compressor_name, encoder_name character(len=:), allocatable :: uhash, chash integer(kind=8) :: hash, cbytes integer :: io, item_size integer(kind=1), dimension(:), pointer :: array integer(kind=1), dimension(:), allocatable, target :: input, buffer type(c_ptr) :: input_ptr, buffer_ptr !------------------------------------------------------------------------------- ! status = 0 digest_name = hash_name(digest_id) hash = digest(array_ptr, array_bytes, digest_id) call digest_string(hash, str) uhash = trim(str) chash = '' filename = '' encoder_name = '' if (is_compressor_on(compressor_id)) then compressor_name = trim(get_compressor_name(compressor_id)) file_suffix = trim(get_compressed_file_suffix(compressor_id)) if (is_encoder_on(encoder_id)) then encoder_name = trim(get_encoder_name(encoder_id)) select case(array_dtype) case('complex64', 'float64', 'int64') item_size = 8 case('float32', 'int32') item_size = 4 case default item_size = 1 end select allocate(input(array_bytes), stat = status) call encode(encoder_id, item_size, array_bytes, array_ptr, input) input_ptr = c_loc(input) else input_ptr = array_ptr end if cbytes = compression_bound(compressor_id, level, array_bytes) allocate(buffer(cbytes), stat = status) if (status == 0) then buffer_ptr = c_loc(buffer) call compress(compressor_id, level, & input_ptr, array_bytes, buffer_ptr, cbytes) if (cbytes > 0) then filename = trim(array_file) // '.bin' // file_suffix filepath = trim(data_path) // trim(filename) open (newunit=io, file=filepath, access='stream', & action='write', status='replace') write (io) buffer(1:cbytes) close (io) end if hash = digest(buffer_ptr, cbytes, digest_id) call digest_string(hash, str) chash = trim(str) if (allocated(input)) deallocate(input) if (allocated(buffer)) deallocate(buffer) end if if (is_encoder_on(encoder_id)) then call XMLAddElement(xml_ptr, "BinaryFiles", array_name, & filename, array_dtype, array_bytes, & array_dims, digest_name, uhash, & compressor_name, cbytes, chash, & encoder_name) else call XMLAddElement(xml_ptr, "BinaryFiles", array_name, & filename, array_dtype, array_bytes, & array_dims, digest_name, uhash, & compressor_name, cbytes, chash) end if else ! no compression call c_f_pointer(array_ptr, array, [ array_bytes ]) filename = trim(array_file) // '.bin' filepath = trim(data_path) // trim(filename) open (newunit=io, file=filepath, access='stream', & action='write', status='replace') write (io) array close (io) call XMLAddElement(xml_ptr, "BinaryFiles", array_name, & filename, array_dtype, array_bytes, & array_dims, digest_name, uhash) end if end subroutine write_binary_xml #ifdef HDF5 ! !=============================================================================== ! ! subroutine RESTORE_SNAPSHOT_PARAMETERS_H5: ! ----------------------------------------- ! ! Subroutine restores parameters from the restart snapshot. ! ! Arguments: ! ! status - the status flag (the success is 0, failure otherwise); ! !=============================================================================== ! subroutine restore_snapshot_parameters_h5(status) use helpers , only : print_message use mpitools , only : master use parameters, only : update_parameter implicit none integer, intent(inout) :: status character(len=255) :: fname logical :: flag integer(hid_t) :: file_id, grp_id integer :: ival real(kind=8) :: rval character(len=64) :: sval character(len=:), allocatable :: pname character(len=*), parameter :: loc = 'IO::restore_snapshot_parameters_h5' !------------------------------------------------------------------------------- ! status = 0 if (.not. master) return write (fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, 0 inquire (file=fname, exist=flag) if (.not. flag) then call print_message(loc, "Restart snapshot " // trim(fname) // & " does not exist!") status = 1 return end if call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status) if (status /= 0) then call print_message(loc, "Could not open " // trim(fname) // "!") return end if call h5gopen_f(file_id, 'attributes', grp_id, status) if (status == 0) then pname = "problem" call restore_attribute_h5(grp_id, pname, sval, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") call update_parameter(pname, trim(adjustl(sval))) pname = "eqsys" call restore_attribute_h5(grp_id, pname, sval, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") call update_parameter("equation_system", trim(adjustl(sval))) pname = "eos" call restore_attribute_h5(grp_id, pname, sval, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") call update_parameter("equation_of_state", trim(adjustl(sval))) pname = "nprocs" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_INTEGER, 1, ival, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(i0)") ival call update_parameter("nfiles", trim(adjustl(sval))) pname = "ncells" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_INTEGER, 1, ival, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(i0)") ival call update_parameter(pname, trim(adjustl(sval))) pname = "xblocks" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_INTEGER, 1, ival, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(i0)") ival call update_parameter(pname, trim(adjustl(sval))) pname = "yblocks" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_INTEGER, 1, ival, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(i0)") ival call update_parameter(pname, trim(adjustl(sval))) #if NDIMS == 3 pname = "zblocks" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_INTEGER, 1, ival, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(i0)") ival call update_parameter(pname, trim(adjustl(sval))) #endif /* NDIMS == 3 */ pname = "last_id" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_INTEGER, 1, ival, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(i0)") ival call update_parameter(pname, trim(adjustl(sval))) pname = "xmin" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_DOUBLE, 1, rval, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(1es32.20)") rval call update_parameter(pname, trim(adjustl(sval))) pname = "xmax" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_DOUBLE, 1, rval, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(1es32.20)") rval call update_parameter(pname, trim(adjustl(sval))) pname = "ymin" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_DOUBLE, 1, rval, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(1es32.20)") rval call update_parameter(pname, trim(adjustl(sval))) pname = "ymax" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_DOUBLE, 1, rval, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(1es32.20)") rval call update_parameter(pname, trim(adjustl(sval))) #if NDIMS == 3 pname = "zmin" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_DOUBLE, 1, rval, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(1es32.20)") rval call update_parameter(pname, trim(adjustl(sval))) pname = "zmax" call restore_attribute_h5(grp_id, pname, & H5T_NATIVE_DOUBLE, 1, rval, status) if (status /= 0) & call print_message(loc, "Failed to restore attribute" // & trim(pname) // "!") write (sval,"(1es32.20)") rval call update_parameter(pname, trim(adjustl(sval))) #endif /* NDIMS == 3 */ call h5gclose_f(grp_id, status) if (status /= 0) & call print_message(loc, "Could not close group 'attributes'!") else call print_message(loc, "Could not open group 'attributes'!") end if call h5fclose_f(file_id, status) if (status /= 0) & call print_message(loc, "Could not close " // trim(fname) // "!") !------------------------------------------------------------------------------- ! end subroutine restore_snapshot_parameters_h5 ! !=============================================================================== ! ! subroutine READ_RESTART_SNAPSHOT_H5: ! ----------------------------------- ! ! Subroutine reads restart snapshot, i.e. parameters, meta and data blocks ! stored in the HDF5 format restart files and reconstructs the data structure ! in order to resume a terminated job. ! ! Arguments: ! ! status - the subroutine call status; ! !=============================================================================== ! subroutine read_restart_snapshot_h5(status) use blocks , only : change_blocks_process use forcing , only : einj use helpers , only : print_message #ifdef MPI use mesh , only : redistribute_blocks #endif /* MPI */ use mpitools , only : nprocs, nproc use parameters, only : get_parameter implicit none integer, intent(out) :: status character(len=255) :: fname integer(hid_t) :: file_id, grp_id integer :: nfiles, last_id, n, i, nd, nr, nl, nu, il, iu logical :: flag real(kind=8) :: deinj character(len=*), parameter :: loc = 'IO::read_restart_snapshot_h5()' !------------------------------------------------------------------------------- ! !! 1. RESTORE PARAMETERS AND META BLOCKS FROM THE FIRST FILE !! write (fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, 0 inquire (file=fname, exist=flag) if (.not. flag) then call print_message(loc, & "Restart snapshot '" // trim(fname) // "' not found!") status = 1 return end if call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status) if (status /= 0) then call print_message(loc, "Could not open '" // trim(fname) // "'!") return end if call get_parameter("nfiles", nfiles) call get_parameter("last_id", last_id) allocate(block_array(last_id)) call restore_attributes_h5(file_id, status) if (status /= 0) & call print_message(loc, & "Could not restore attributes from '" // trim(fname) // "'!") call restore_metablocks_h5(file_id, status) if (status /= 0) & call print_message(loc, & "Could not restore metablocks from '" // trim(fname) // "'!") call h5fclose_f(file_id, status) if (status /= 0) then call print_message(loc, "Could not close '" // trim(fname) // "'!") return end if !! 1. RESTORE DATA BLOCKS !! ! separate data blocks reading into two cases, when the number of processors is ! larger or equal to the number of files, and when we have less processors than ! files ! if (nfiles <= nprocs .and. nproc < nfiles) then write (fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, nproc inquire (file=fname, exist=flag) if (.not. flag) then call print_message(loc, & "Restart snapshot '" // trim(fname) // "' not found!") status = 1 return end if call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status) if (status /= 0) then call print_message(loc, "Could not open '" // trim(fname) // "'!") return end if call restore_datablocks_h5(file_id, status) if (status /= 0) & call print_message(loc, & "Could not restore datablocks from '" // trim(fname) // "'!") call h5gopen_f(file_id, 'attributes', grp_id, status) if (status /= 0) then call print_message(loc, "Could not open group 'attributes'!") return end if call restore_attribute_h5(grp_id, 'einj', & H5T_NATIVE_DOUBLE, 1, einj, status) if (status /= 0) & call print_message(loc, "Could not get the injected energy!") call h5gclose_f(grp_id, status) if (status /= 0) & call print_message(loc, "Could not close group 'attributes'!") call h5fclose_f(file_id, status) if (status /= 0) then call print_message(loc, "Could not close '" // trim(fname) // "'!") return end if end if ! nproc < nfiles ! if there are more files than processes, divide the files equally between ! processes ! if (nprocs < nfiles) then nl = 0 nd = nfiles / nprocs nr = mod(nfiles, nprocs) do n = 0, nprocs - 1 if (n < nr) then il = n * (nd + 1) iu = il + nd else il = n * nd + nr iu = il + nd - 1 end if do i = il, iu call change_blocks_process(i, n) end do if (n == nproc) then nl = il nu = iu end if end do do n = nl, nu write (fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, n inquire (file=fname, exist=flag) if (.not. flag) then call print_message(loc, & "Restart snapshot '" // trim(fname) // "' not found!") status = 1 return end if call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status) if (status /= 0) then call print_message(loc, "Could not open '" // trim(fname) // "'!") return end if call restore_datablocks_h5(file_id, status) if (status /= 0) & call print_message(loc, & "Could not restore datablocks from '" // trim(fname) // "'!") call h5gopen_f(file_id, 'attributes', grp_id, status) if (status /= 0) then call print_message(loc, "Could not open group 'attributes'!") return end if call restore_attribute_h5(grp_id, 'einj', & H5T_NATIVE_DOUBLE, 1, deinj, status) if (status /= 0) & call print_message(loc, "Could not get the injected energy!") einj = einj + deinj call h5gclose_f(grp_id, status) if (status /= 0) & call print_message(loc, "Could not close group 'attributes'!") call h5fclose_f(file_id, status) if (status /= 0) then call print_message(loc, "Could not close '" // trim(fname) // "'!") return end if end do end if if (allocated(block_array)) deallocate(block_array) #ifdef MPI call redistribute_blocks(status) #endif /* MPI */ !------------------------------------------------------------------------------- ! end subroutine read_restart_snapshot_h5 ! !=============================================================================== ! ! subroutine STORE_RESTART_SNAPSHOT_H5: ! ------------------------------------ ! ! Subroutine stores restart snapshots in the HDF5 format. ! ! Arguments: ! ! problem - the problem's name; ! nrun - the snapshot number; ! status - the subroutine call status; ! !=============================================================================== ! subroutine store_restart_snapshot_h5(problem, nrun, status) use helpers , only : print_message use mpitools, only : nproc implicit none character(len=*), intent(in) :: problem integer , intent(in) :: nrun integer , intent(out) :: status character(len=255) :: fname integer(hid_t) :: file_id character(len=*), parameter :: loc = 'IO::store_restart_snapshot_h5()' !------------------------------------------------------------------------------- ! write (fname, "('r',i6.6,'_',i5.5,'.h5')") nrun, nproc call h5fcreate_f(fname, H5F_ACC_TRUNC_F, file_id, status) if (status /= 0) then call print_message(loc, "Could not create file " // trim(fname)) return end if call store_attributes_h5(file_id, problem, .true., status) call store_metablocks_h5(file_id, status) call store_datablocks_h5(file_id, status) call h5fclose_f(file_id, status) if (status /= 0) & call print_message(loc, "Could not close file " // trim(fname)) !------------------------------------------------------------------------------- ! end subroutine store_restart_snapshot_h5 ! !=============================================================================== ! ! subroutine STORE_SNAPSHOT_H5: ! ---------------------------- ! ! Subroutine stores the current simulation snapshot, i.e. parameters, ! coordinates and variables as a HDF5 file. ! ! Arguments: ! ! problem - the problem's name; ! status - the subroutine call status; ! !=============================================================================== ! subroutine store_snapshot_h5(problem, status) use helpers , only : print_message use mpitools, only : nproc implicit none character(len=*), intent(in) :: problem integer , intent(out) :: status character(len=255) :: fname integer(hid_t) :: file_id character(len=*), parameter :: loc = 'IO::store_snapshot_h5()' !------------------------------------------------------------------------------- ! write (fname,"('p',i6.6,'_',i5.5,'.h5')") isnap, nproc call h5fcreate_f(fname, H5F_ACC_TRUNC_F, file_id, status) if (status < 0) then call print_message(loc, "Could not create file " // trim(fname)) return end if call store_attributes_h5(file_id, problem, .false., status) call store_coordinates_h5(file_id, status) call store_variables_h5(file_id, status) call h5fclose_f(file_id, status) if (status < 0) & call print_message(loc, "Could not close file " // trim(fname)) !------------------------------------------------------------------------------- ! end subroutine store_snapshot_h5 ! !=============================================================================== ! ! subroutine RESTORE_ATTRIBUTES_H5: ! -------------------------------- ! ! Subroutine restores global attributes from an HDF5 file provided by its ! identifier. ! ! Arguments: ! ! loc_id - the HDF5 file identifier; ! status - the subroutine call status; ! !=============================================================================== ! subroutine restore_attributes_h5(loc_id, status) use blocks , only : block_meta use blocks , only : append_metablock use blocks , only : set_last_id use blocks , only : get_mblocks, get_dblocks, get_nleafs use coordinates , only : ncells use coordinates , only : xmin, xmax, ymin, ymax, zmin, zmax use equations , only : cmax, cmax2, cglm use evolution , only : step, time, dt, dth, dte use evolution , only : niterations, nrejections, errs use forcing , only : nmodes, fcoefs use helpers , only : print_message use random , only : set_seeds, gentype implicit none integer(hid_t), intent(in) :: loc_id integer , intent(out) :: status type(block_meta), pointer :: pmeta integer(hid_t) :: grp_id integer :: l integer :: lndims, lmblocks, lnleafs, llast_id integer :: lncells, lnseeds, lnmodes integer(hsize_t), dimension(2) :: dims integer(kind=8), dimension(:,:), allocatable :: seeds real(kind=8) , dimension(:,:), allocatable :: coefs character(len=*), parameter :: loc = 'IO::restore_attributes_h5()' !------------------------------------------------------------------------------- ! call h5gopen_f(loc_id, 'attributes', grp_id, status) if (status /= 0) then call print_message(loc, "Could not open group 'attributes'!") return end if call restore_attribute_h5(grp_id, 'ndims', & H5T_NATIVE_INTEGER, 1, lndims, status) call restore_attribute_h5(grp_id, 'mblocks', & H5T_NATIVE_INTEGER, 1, lmblocks, status) call restore_attribute_h5(grp_id, 'nleafs', & H5T_NATIVE_INTEGER, 1, lnleafs, status) call restore_attribute_h5(grp_id, 'last_id', & H5T_NATIVE_INTEGER, 1, llast_id, status) call restore_attribute_h5(grp_id, 'ncells', & H5T_NATIVE_INTEGER, 1, lncells, status) call restore_attribute_h5(grp_id, 'nseeds', & H5T_NATIVE_INTEGER, 1, lnseeds, status) call restore_attribute_h5(grp_id, 'step', & H5T_NATIVE_INTEGER, 1, step, status) call restore_attribute_h5(grp_id, 'isnap', & H5T_NATIVE_INTEGER, 1, isnap, status) call restore_attribute_h5(grp_id, 'niterations', & H5T_NATIVE_INTEGER, 1, niterations, status) call restore_attribute_h5(grp_id, 'nrejections', & H5T_NATIVE_INTEGER, 1, nrejections, status) call restore_attribute_h5(grp_id, 'nmodes', & H5T_NATIVE_INTEGER, 1, lnmodes, status) call restore_attribute_h5(grp_id, 'xmin', & H5T_NATIVE_DOUBLE, 1, xmin, status) call restore_attribute_h5(grp_id, 'xmax', & H5T_NATIVE_DOUBLE, 1, xmax, status) call restore_attribute_h5(grp_id, 'ymin', & H5T_NATIVE_DOUBLE, 1, ymin, status) call restore_attribute_h5(grp_id, 'ymax', & H5T_NATIVE_DOUBLE, 1, ymax, status) call restore_attribute_h5(grp_id, 'zmin', & H5T_NATIVE_DOUBLE, 1, zmin, status) call restore_attribute_h5(grp_id, 'zmax', & H5T_NATIVE_DOUBLE, 1, zmax, status) call restore_attribute_h5(grp_id, 'time', & H5T_NATIVE_DOUBLE, 1, time, status) call restore_attribute_h5(grp_id, 'dt' , & H5T_NATIVE_DOUBLE, 1, dt , status) call restore_attribute_h5(grp_id, 'dth' , & H5T_NATIVE_DOUBLE, 1, dth , status) call restore_attribute_h5(grp_id, 'dte' , & H5T_NATIVE_DOUBLE, 1, dte , status) call restore_attribute_h5(grp_id, 'cmax', & H5T_NATIVE_DOUBLE, 1, cmax, status) cmax2 = cmax * cmax call restore_attribute_h5(grp_id, 'cglm', & H5T_NATIVE_DOUBLE, 1, cglm, status) call restore_attribute_h5(grp_id, 'errs', & H5T_NATIVE_DOUBLE, 3, errs, status) call set_last_id(llast_id) call h5gclose_f(grp_id, status) if (status /= 0) then call print_message(loc, "Could not close group 'attributes'!") return end if if (lndims /= NDIMS) then call print_message(loc, "The number of dimensions does not match!") status = 1 return end if if (lncells /= ncells) then call print_message(loc, "The block dimensions do not match!") status = 1 return end if do l = 1, lmblocks call append_metablock(pmeta, status) if (status /= 0) then call print_message(loc, "Could not append a new metablock!") return end if end do if (lmblocks /= get_mblocks()) then call print_message(loc, "The number of metablocks does not match!") return end if if (lnmodes > 0) then if (lnmodes == nmodes) then call h5gopen_f(loc_id, 'forcing', grp_id, status) if (status == 0) then dims = shape(fcoefs) allocate(coefs(dims(1),dims(2)), stat=status) if (status == 0) then call read_dataset_h5(grp_id, 'fcoefs_real', & H5T_NATIVE_DOUBLE, dims, coefs, status) fcoefs = cmplx(1.0d+00, 0.0+00, kind=8) * coefs call read_dataset_h5(grp_id, 'fcoefs_imag', & H5T_NATIVE_DOUBLE, dims, coefs, status) fcoefs = fcoefs + cmplx(0.0d+00, 1.0+00, kind=8) * coefs deallocate(coefs, stat=status) if (status /= 0) & call print_message(loc, & "Could not deallocate space of the forcing coefficients!") else call print_message(loc, & "Could not allocate space for the forcing coefficients!") end if call h5gclose_f(grp_id, status) if (status /= 0) & call print_message(loc, "Could not close group 'forcing'!") else call print_message(loc, "Could not open group 'forcing'!") end if else call print_message(loc, "The number of driving modes has changed!") end if end if if (trim(gentype) == "same") then call h5gopen_f(loc_id, 'random', grp_id, status) if (status == 0) then dims = [ 4, lnseeds ] allocate(seeds(dims(1),dims(2)), stat=status) if (status == 0) then call read_dataset_h5(grp_id, 'seeds', & H5T_STD_I64LE, dims, seeds, status) call set_seeds(lnseeds, seeds(:,:), .false.) deallocate(seeds, stat=status) if (status /= 0) & call print_message(loc, & "Could not deallocate space of the random seeds!") else call print_message(loc, & "Could not allocate space for the random seeds!") end if call h5gclose_f(grp_id, status) if (status /= 0) & call print_message(loc, "Could not close group 'random'!") else call print_message(loc, "Could not open group 'random'!") end if end if !------------------------------------------------------------------------------- ! end subroutine restore_attributes_h5 ! !=============================================================================== ! ! subroutine STORE_ATTRIBUTES_H5: ! ------------------------------ ! ! Subroutine stores the global simulation attributes in the specific location. ! ! Arguments: ! ! loc_id - the HDF5 file identifier; ! problem - the problem's name; ! restart - the flag indicating to store attributes for restart snapshot; ! status - the subroutine call status; ! !=============================================================================== ! subroutine store_attributes_h5(loc_id, problem, restart, status) use blocks , only : get_mblocks, get_dblocks, get_nleafs use blocks , only : get_last_id, nregs, nchildren use coordinates, only : minlev, maxlev use coordinates, only : bcells, ncells, nghosts use coordinates, only : bdims => domain_base_dims use coordinates, only : xmin, xmax, ymin, ymax, zmin, zmax use coordinates, only : periodic use equations , only : eqsys, eos, adiabatic_index, csnd, cmax, cglm, nv use evolution , only : step, time, dt, dth, dte, cfl, glm_alpha, errs use evolution , only : atol, rtol, mrej, niterations, nrejections use forcing , only : nmodes, einj, fcoefs use helpers , only : print_message use mpitools , only : nprocs, nproc use random , only : gentype, nseeds, get_seeds use sources , only : viscosity, resistivity implicit none integer(hid_t) , intent(in) :: loc_id character(len=*), intent(in) :: problem logical , intent(in) :: restart integer , intent(out) :: status integer(hid_t) :: grp_id integer(hsize_t), dimension(2) :: dims = 1 integer(kind=8), dimension(:,:), allocatable :: seeds real(kind=8) , dimension(:,:), allocatable :: array character(len=*), parameter :: loc = 'IO::store_attributes_h5()' !------------------------------------------------------------------------------- ! call store_attribute_h5(loc_id, 'code', 'AMUN', status) call store_attribute_h5(loc_id, 'version', H5T_NATIVE_REAL, 1, 1.0, status) call h5gcreate_f(loc_id, 'attributes', grp_id, status) if (status == 0) then call store_attribute_h5(grp_id, "problem", trim(problem), status) call store_attribute_h5(grp_id, "eqsys" , trim(eqsys) , status) call store_attribute_h5(grp_id, 'eos' , trim(eos) , status) call store_attribute_h5(grp_id, 'nprocs', & H5T_NATIVE_INTEGER, 1, nprocs, status) call store_attribute_h5(grp_id, 'nproc', & H5T_NATIVE_INTEGER, 1, nproc, status) call store_attribute_h5(grp_id, 'nvars', & H5T_NATIVE_INTEGER, 1, nv, status) call store_attribute_h5(grp_id, 'ndims', & H5T_NATIVE_INTEGER, 1, NDIMS, status) call store_attribute_h5(grp_id, 'bdims', & H5T_NATIVE_INTEGER, 3, bdims, status) call store_attribute_h5(grp_id, 'xblocks', & H5T_NATIVE_INTEGER, 1, bdims(1), status) call store_attribute_h5(grp_id, 'yblocks', & H5T_NATIVE_INTEGER, 1, bdims(2), status) call store_attribute_h5(grp_id, 'zblocks', & H5T_NATIVE_INTEGER, 1, bdims(3), status) call store_attribute_h5(grp_id, 'minlev', & H5T_NATIVE_INTEGER, 1, minlev, status) call store_attribute_h5(grp_id, 'maxlev', & H5T_NATIVE_INTEGER, 1, maxlev, status) call store_attribute_h5(grp_id, 'ncells', & H5T_NATIVE_INTEGER, 1, ncells, status) call store_attribute_h5(grp_id, 'nghosts', & H5T_NATIVE_INTEGER, 1, nghosts, status) call store_attribute_h5(grp_id, 'bcells', & H5T_NATIVE_INTEGER, 1, bcells, status) call store_attribute_h5(grp_id, 'dblocks', & H5T_NATIVE_INTEGER, 1, get_dblocks(), status) call store_attribute_h5(grp_id, 'nleafs', & H5T_NATIVE_INTEGER, 1, get_nleafs(), status) call store_attribute_h5(grp_id, 'step', & H5T_NATIVE_INTEGER, 1, step, status) call store_attribute_h5(grp_id, 'isnap', & H5T_NATIVE_INTEGER, 1, isnap, status) call store_attribute_h5(grp_id, 'periodic', & H5T_NATIVE_INTEGER, 3, periodic, status) call store_attribute_h5(grp_id, 'adiabatic_index', & H5T_NATIVE_DOUBLE, 1, adiabatic_index, status) call store_attribute_h5(grp_id, 'sound_speed', & H5T_NATIVE_DOUBLE, 1, csnd, status) call store_attribute_h5(grp_id, 'viscosity', & H5T_NATIVE_DOUBLE, 1, viscosity, status) call store_attribute_h5(grp_id, 'resistivity', & H5T_NATIVE_DOUBLE, 1, resistivity, status) call store_attribute_h5(grp_id, 'xmin', & H5T_NATIVE_DOUBLE, 1, xmin, status) call store_attribute_h5(grp_id, 'xmax', & H5T_NATIVE_DOUBLE, 1, xmax, status) call store_attribute_h5(grp_id, 'ymin', & H5T_NATIVE_DOUBLE, 1, ymin, status) call store_attribute_h5(grp_id, 'ymax', & H5T_NATIVE_DOUBLE, 1, ymax, status) call store_attribute_h5(grp_id, 'zmin', & H5T_NATIVE_DOUBLE, 1, zmin, status) call store_attribute_h5(grp_id, 'zmax', & H5T_NATIVE_DOUBLE, 1, zmax, status) call store_attribute_h5(grp_id, 'time', & H5T_NATIVE_DOUBLE, 1, time, status) call store_attribute_h5(grp_id, 'dt' , & H5T_NATIVE_DOUBLE, 1, dt, status) call store_attribute_h5(grp_id, 'cfl' , & H5T_NATIVE_DOUBLE, 1, cfl, status) call store_attribute_h5(grp_id, 'glm_alpha', & H5T_NATIVE_DOUBLE, 1, glm_alpha, status) if (restart) then call store_attribute_h5(grp_id, 'rngtype', trim(gentype), status) call store_attribute_h5(grp_id, 'nchildren', & H5T_NATIVE_INTEGER, 1, nchildren, status) call store_attribute_h5(grp_id, 'mblocks', & H5T_NATIVE_INTEGER, 1, get_mblocks(), status) call store_attribute_h5(grp_id, 'nregisters', & H5T_NATIVE_INTEGER, 1, nregs, status) call store_attribute_h5(grp_id, 'last_id', & H5T_NATIVE_INTEGER, 1, get_last_id(), status) call store_attribute_h5(grp_id, 'maximum_rejections', & H5T_NATIVE_INTEGER, 1, mrej, status) call store_attribute_h5(grp_id, 'niterations', & H5T_NATIVE_INTEGER, 1, niterations, status) call store_attribute_h5(grp_id, 'nrejections', & H5T_NATIVE_INTEGER, 1, nrejections, status) call store_attribute_h5(grp_id, 'nmodes', & H5T_NATIVE_INTEGER, 1, nmodes, status) call store_attribute_h5(grp_id, 'nseeds', & H5T_NATIVE_INTEGER, 1, nseeds, status) call store_attribute_h5(grp_id, 'dth' , & H5T_NATIVE_DOUBLE, 1, dth, status) call store_attribute_h5(grp_id, 'dte' , & H5T_NATIVE_DOUBLE, 1, dte, status) call store_attribute_h5(grp_id, 'cmax', & H5T_NATIVE_DOUBLE, 1, cmax, status) call store_attribute_h5(grp_id, 'cglm', & H5T_NATIVE_DOUBLE, 1, cglm, status) call store_attribute_h5(grp_id, 'absolute_tolerance', & H5T_NATIVE_DOUBLE, 1, atol, status) call store_attribute_h5(grp_id, 'relative_tolerance', & H5T_NATIVE_DOUBLE, 1, rtol, status) call store_attribute_h5(grp_id, 'errs', & H5T_NATIVE_DOUBLE, 3, errs, status) call store_attribute_h5(grp_id, 'einj', & H5T_NATIVE_DOUBLE, 1, einj, status) end if call h5gclose_f(grp_id, status) if (status < 0) & call print_message(loc, "Could not close group 'attributes'!") else call print_message(loc, "Could not create group 'attributes'!") end if ! store forcing coefficients in a different group ! if (restart) then call h5gcreate_f(loc_id, 'forcing', grp_id, status) if (status >= 0) then if (nmodes > 0) then dims(1) = nmodes dims(2) = NDIMS allocate(array(nmodes,NDIMS), stat=status) if (status == 0) then array = real(fcoefs) call store_dataset_h5(grp_id, 'fcoefs_real', H5T_NATIVE_DOUBLE, & dims, array, .false., status) if (status < 0) & call print_message(loc, "Could not store real(fcoefs)!") array = aimag(fcoefs) call store_dataset_h5(grp_id, 'fcoefs_imag', H5T_NATIVE_DOUBLE, & dims, array, .false., status) if (status < 0) & call print_message(loc, "Could not store imag(fcoefs)!") deallocate(array, stat=status) if (status /= 0) & call print_message(loc, "Could not deallocate space for fcoefs!") else call print_message(loc, "Could not allocate space for fcoefs!") end if end if call h5gclose_f(grp_id, status) if (status < 0) & call print_message(loc, "Could not close group 'forcing'!") else call print_message(loc, "Could not create group 'forcing'!") end if ! store random seeds in a different group ! call h5gcreate_f(loc_id, 'random', grp_id, status) if (status >= 0) then if (nseeds > 0) then dims(1) = 4 dims(2) = nseeds allocate(seeds(4,nseeds), stat=status) if (status == 0) then call get_seeds(seeds) call store_dataset_h5(grp_id, 'seeds', H5T_STD_I64LE, & dims, seeds, .false., status) if (status < 0) & call print_message(loc, "Could not store seeds!") deallocate(seeds, stat=status) if (status /= 0) & call print_message(loc, "Could not deallocate space for seeds!") else call print_message(loc, "Could not allocate space for seeds!") end if end if call h5gclose_f(grp_id, status) if (status < 0) & call print_message(loc, "Could not close group 'random'!") else call print_message(loc, "Could not create group 'random'!") end if end if !------------------------------------------------------------------------------- ! end subroutine store_attributes_h5 ! !=============================================================================== ! ! subroutine RESTORE_METABLOCKS_H5: ! -------------------------------- ! ! Subroutine restores meta blocks and their fields and dependencies from ! the 'metablocks' group of HDF5 restart snapshot. ! ! Arguments: ! ! loc_id - the location in which store the datablocks; ! status - the subroutine call status; ! !=============================================================================== ! subroutine restore_metablocks_h5(loc_id, status) use blocks , only : block_meta, list_meta use blocks , only : ns => nsides, nc => nchildren use blocks , only : get_last_id, get_mblocks use blocks , only : metablock_set_id, metablock_set_process use blocks , only : metablock_set_refinement use blocks , only : metablock_set_configuration use blocks , only : metablock_set_level, metablock_set_position use blocks , only : metablock_set_coordinates, metablock_set_bounds use blocks , only : metablock_set_leaf use helpers, only : print_message implicit none integer(hid_t), intent(in) :: loc_id integer , intent(out) :: status type(block_meta), pointer :: pmeta integer(hid_t) :: grp_id integer :: nm, l, n, p, i, j #if NDIMS == 3 integer :: k #endif /* NDIMS == 3 */ integer(hsize_t), dimension(5) :: dims integer(kind=4), dimension(:,:) , allocatable :: fields integer(kind=4), dimension(:,:) , allocatable :: children #if NDIMS == 2 integer(kind=4), dimension(:,:,:,:) , allocatable :: edges integer(kind=4), dimension(:,:,:) , allocatable :: corners #endif /* NDIMS == 2 */ #if NDIMS == 3 integer(kind=4), dimension(:,:,:,:,:), allocatable :: faces integer(kind=4), dimension(:,:,:,:,:), allocatable :: edges integer(kind=4), dimension(:,:,:,:) , allocatable :: corners #endif /* NDIMS == 3 */ real(kind=8) , dimension(:,:,:) , allocatable :: bounds character(len=*), parameter :: loc = 'IO::restore_metablocks_h5()' !------------------------------------------------------------------------------- ! call h5gopen_f(loc_id, 'metablocks', grp_id, status) if (status /= 0) then call print_message(loc, "Could not open group 'metablocks'!") return end if nm = get_mblocks() if (nm > 0) then allocate(fields(16,nm), children(nc,nm), bounds(3,2,nm), & #if NDIMS == 3 faces(NDIMS,ns,ns,ns,nm), & edges(NDIMS,ns,ns,ns,nm), corners(ns,ns,ns,nm), & #else /* NDIMS == 3 */ edges(NDIMS,ns,ns,nm), corners(ns,ns,nm), & #endif /* NDIMS == 3 */ stat = status) if (status == 0) then l = rank(fields) dims(1:l) = shape(fields) call read_dataset_h5(grp_id, 'fields', & H5T_NATIVE_INTEGER, dims(1:l), fields, status) l = rank(children) dims(1:l) = shape(children) call read_dataset_h5(grp_id, 'children', & H5T_NATIVE_INTEGER, dims(1:l), children, status) #if NDIMS == 3 l = rank(faces) dims(1:l) = shape(faces) call read_dataset_h5(grp_id, 'faces', & H5T_NATIVE_INTEGER, dims(1:l), faces, status) #endif /* NDIMS == 3 */ l = rank(edges) dims(1:l) = shape(edges) call read_dataset_h5(grp_id, 'edges', & H5T_NATIVE_INTEGER, dims(1:l), edges, status) l = rank(corners) dims(1:l) = shape(corners) call read_dataset_h5(grp_id, 'corners', & H5T_NATIVE_INTEGER, dims(1:l), corners, status) l = rank(bounds) dims(1:l) = shape(bounds) call read_dataset_h5(grp_id, 'bounds', & H5T_NATIVE_DOUBLE, dims(1:l), bounds, status) l = 0 pmeta => list_meta do while(associated(pmeta)) l = l + 1 block_array(fields(1,l))%ptr => pmeta call metablock_set_id(pmeta, fields(1,l)) call metablock_set_process(pmeta, fields(2,l)) call metablock_set_level(pmeta, fields(3,l)) call metablock_set_configuration(pmeta, fields(4,l)) call metablock_set_refinement(pmeta, fields(5,l)) call metablock_set_position(pmeta, fields(6:8,l)) call metablock_set_coordinates(pmeta, fields(9:11,l)) call metablock_set_bounds(pmeta, bounds(1,1,l), bounds(1,2,l), & bounds(2,1,l), bounds(2,2,l), & bounds(3,1,l), bounds(3,2,l)) if (fields(12,l) == 1) call metablock_set_leaf(pmeta) pmeta => pmeta%next end do l = 0 pmeta => list_meta do while(associated(pmeta)) l = l + 1 if (fields(14,l) > 0) pmeta%parent => block_array(fields(14,l))%ptr do p = 1, nc if (children(p,l) > 0) & pmeta%child(p)%ptr => block_array(children(p,l))%ptr end do #if NDIMS == 2 do j = 1, ns do i = 1, ns do n = 1, NDIMS if (edges(n,i,j,l) > 0) & pmeta%edges(i,j,n)%ptr => block_array(edges(n,i,j,l))%ptr end do if (corners(i,j,l) > 0) & pmeta%corners(i,j)%ptr => block_array(corners(i,j,l))%ptr end do end do #endif /* NDIMS == 2 */ #if NDIMS == 3 do k = 1, ns do j = 1, ns do i = 1, ns do n = 1, NDIMS if (faces(n,i,j,k,l) > 0) & pmeta%faces(i,j,k,n)%ptr => & block_array(faces(n,i,j,k,l))%ptr if (edges(n,i,j,k,l) > 0) & pmeta%edges(i,j,k,n)%ptr => & block_array(edges(n,i,j,k,l))%ptr end do ! NDIMS if (corners(i,j,k,l) > 0) & pmeta%corners(i,j,k)%ptr => & block_array(corners(i,j,k,l))%ptr end do end do end do #endif /* NDIMS == 3 */ pmeta => pmeta%next end do #if NDIMS == 3 deallocate(fields, children, bounds, faces, & edges, corners, stat=status) #else /* NDIMS == 3 */ deallocate(fields, children, bounds, edges, corners, stat=status) #endif /* NDIMS == 3 */ if (status /= 0) & call print_message(loc, "Could not deallocate space of metablocks!") else call print_message(loc, "Could not allocate space for metablocks!") end if end if call h5gclose_f(grp_id, status) if (status /= 0) & call print_message(loc, "Could not close group 'metablocks'!") !------------------------------------------------------------------------------- ! end subroutine restore_metablocks_h5 ! !=============================================================================== ! ! subroutine STORE_METABLOCKS_H5: ! ------------------------------ ! ! Subroutine stores all meta blocks' data in the group 'metablocks'. ! ! Arguments: ! ! loc_id - the location in which store the datablocks; ! status - the subroutine call status; ! !=============================================================================== ! subroutine store_metablocks_h5(loc_id, status) use blocks , only : block_meta, list_meta, get_last_id use blocks , only : ns => nsides, nc => nchildren use blocks , only : get_last_id, get_mblocks use helpers, only : print_message implicit none integer(hid_t), intent(in) :: loc_id integer , intent(out) :: status type(block_meta), pointer :: pmeta integer(hid_t) :: grp_id integer :: nm, l, n, p, i, j #if NDIMS == 3 integer :: k #endif /* NDIMS == 3 */ integer(hsize_t), dimension(5) :: dims integer(kind=4), dimension(:,:) , allocatable :: fields integer(kind=4), dimension(:,:) , allocatable :: children #if NDIMS == 2 integer(kind=4), dimension(:,:,:,:) , allocatable :: edges integer(kind=4), dimension(:,:,:) , allocatable :: corners #endif /* NDIMS == 2 */ #if NDIMS == 3 integer(kind=4), dimension(:,:,:,:,:), allocatable :: faces integer(kind=4), dimension(:,:,:,:,:), allocatable :: edges integer(kind=4), dimension(:,:,:,:) , allocatable :: corners #endif /* NDIMS == 3 */ real(kind=8) , dimension(:,:,:) , allocatable :: bounds character(len=*), parameter :: loc = 'IO::store_metablocks_h5()' !------------------------------------------------------------------------------- ! call h5gcreate_f(loc_id, 'metablocks', grp_id, status) if (status /= 0) then call print_message(loc, "Could not create group 'metablocks'!") return end if nm = get_mblocks() if (nm > 0) then allocate(fields(16,nm), children(nc,nm), bounds(3,2,nm), & #if NDIMS == 3 faces(NDIMS,ns,ns,ns,nm), & edges(NDIMS,ns,ns,ns,nm), corners(ns,ns,ns,nm), & #else /* NDIMS == 3 */ edges(NDIMS,ns,ns,nm), corners(ns,ns,nm), & #endif /* NDIMS == 3 */ stat = status) if (status == 0) then fields = -1 children = -1 #if NDIMS == 3 faces = -1 #endif /* NDIMS == 3 */ edges = -1 corners = -1 bounds = 0.0d+00 l = 0 pmeta => list_meta do while(associated(pmeta)) l = l + 1 fields( 1,l) = pmeta%id fields( 2,l) = pmeta%process fields( 3,l) = pmeta%level fields( 4,l) = pmeta%conf fields( 5,l) = pmeta%refine fields( 6,l) = pmeta%pos(1) fields( 7,l) = pmeta%pos(2) #if NDIMS == 3 fields( 8,l) = pmeta%pos(3) #endif /* NDIMS == 3 */ fields( 9,l) = pmeta%coords(1) fields(10,l) = pmeta%coords(2) #if NDIMS == 3 fields(11,l) = pmeta%coords(3) #endif /* NDIMS == 3 */ if (pmeta%leaf) fields(12,l) = 1 if (associated(pmeta%data) ) fields(13,l) = 1 if (associated(pmeta%parent)) fields(14,l) = pmeta%parent%id do p = 1, nc if (associated(pmeta%child(p)%ptr)) & children(p,l) = pmeta%child(p)%ptr%id end do #if NDIMS == 2 do j = 1, ns do i = 1, ns do n = 1, NDIMS if (associated(pmeta%edges(i,j,n)%ptr)) & edges(n,i,j,l) = pmeta%edges(i,j,n)%ptr%id end do if (associated(pmeta%corners(i,j)%ptr)) & corners(i,j,l) = pmeta%corners(i,j)%ptr%id end do end do #endif /* NDIMS == 2 */ #if NDIMS == 3 do k = 1, ns do j = 1, ns do i = 1, ns do n = 1, NDIMS if (associated(pmeta%faces(i,j,k,n)%ptr)) & faces(n,i,j,k,l) = pmeta%faces(i,j,k,n)%ptr%id if (associated(pmeta%edges(i,j,k,n)%ptr)) & edges(n,i,j,k,l) = pmeta%edges(i,j,k,n)%ptr%id end do if (associated(pmeta%corners(i,j,k)%ptr)) & corners(i,j,k,l) = pmeta%corners(i,j,k)%ptr%id end do end do end do #endif /* NDIMS == 3 */ bounds(1,1,l) = pmeta%xmin bounds(1,2,l) = pmeta%xmax bounds(2,1,l) = pmeta%ymin bounds(2,2,l) = pmeta%ymax #if NDIMS == 3 bounds(3,1,l) = pmeta%zmin bounds(3,2,l) = pmeta%zmax #endif /* NDIMS == 3 */ pmeta => pmeta%next end do l = rank(fields) dims(1:l) = shape(fields) call store_dataset_h5(grp_id, 'fields', H5T_NATIVE_INTEGER, & dims(1:l), fields, .false., status) l = rank(children) dims(1:l) = shape(children) call store_dataset_h5(grp_id, 'children', H5T_NATIVE_INTEGER, & dims(1:l), children, .false., status) #if NDIMS == 3 l = rank(faces) dims(1:l) = shape(faces) call store_dataset_h5(grp_id, 'faces', H5T_NATIVE_INTEGER, & dims(1:l), faces, .false., status) #endif /* NDIMS == 3 */ l = rank(edges) dims(1:l) = shape(edges) call store_dataset_h5(grp_id, 'edges', H5T_NATIVE_INTEGER, & dims(1:l), edges, .false., status) l = rank(corners) dims(1:l) = shape(corners) call store_dataset_h5(grp_id, 'corners', H5T_NATIVE_INTEGER, & dims(1:l), corners, .false., status) l = rank(bounds) dims(1:l) = shape(bounds) call store_dataset_h5(grp_id, 'bounds', H5T_NATIVE_DOUBLE, & dims(1:l), bounds, .false., status) #if NDIMS == 3 deallocate(fields, children, bounds, faces, & edges, corners, stat=status) #else /* NDIMS == 3 */ deallocate(fields, children, bounds, edges, corners, stat=status) #endif /* NDIMS == 3 */ if (status /= 0) & call print_message(loc, "Could not deallocate space of metablocks!") else call print_message(loc, "Could not allocate space for metablocks!") end if end if call h5gclose_f(grp_id, status) if (status /= 0) & call print_message(loc, "Could not close group 'metablocks'!") !------------------------------------------------------------------------------- ! end subroutine store_metablocks_h5 ! !=============================================================================== ! ! subroutine RESTORE_DATABLOCKS_H5: ! -------------------------------- ! ! Subroutine reads all data blocks stored in the group 'datablocks' of ! the provided handler to the HDF5 restart file. ! ! Arguments: ! ! loc_id - the location in which store the datablocks; ! status - the subroutine call status; ! !=============================================================================== ! subroutine restore_datablocks_h5(loc_id, status) use blocks , only : block_meta, block_data use blocks , only : append_datablock, link_blocks, nregs use coordinates, only : bcells, nghosts use helpers , only : print_message implicit none integer(hid_t), intent(in) :: loc_id integer , intent(out) :: status type(block_data), pointer :: pdata integer(hid_t) :: grp_id, blk_id character(len=64) :: blk_name integer(kind=4) :: dblocks, l, id, nr, nv, nm, ng, nl, nu integer(hsize_t), dimension(5) :: dims = 1 real(kind=8), dimension(:,:,:,:,:), allocatable :: array character(len=*), parameter :: loc = 'IO::restore_datablocks_h5()' !------------------------------------------------------------------------------- ! call h5gopen_f(loc_id, 'attributes', grp_id, status) if (status /= 0) then call print_message(loc, "Could not open group 'attributes'!") return end if call restore_attribute_h5(grp_id, 'dblocks', & H5T_NATIVE_INTEGER, 1, dblocks, status) call restore_attribute_h5(grp_id, 'nregisters', & H5T_NATIVE_INTEGER, 1, nr, status) call restore_attribute_h5(grp_id, 'nvars', & H5T_NATIVE_INTEGER, 1, nv, status) call restore_attribute_h5(grp_id, 'bcells', & H5T_NATIVE_INTEGER, 1, nm, status) call restore_attribute_h5(grp_id, 'nghosts', & H5T_NATIVE_INTEGER, 1, ng, status) call h5gclose_f(grp_id, status) if (status /= 0) then call print_message(loc, "Could not close group 'attributes'!") return end if if (dblocks == 0) return call h5gopen_f(loc_id, 'datablocks', grp_id, status) if (status /= 0) then call print_message(loc, "Could not open group 'datablocks'!") return end if #if NDIMS == 3 allocate(array(nv,nm,nm,nm,nr), stat=status) #else /* NDIMS == 3 */ allocate(array(nv,nm,nm, 1,nr), stat=status) #endif /* NDIMS == 3 */ if (status == 0) then dims = shape(array) nr = min(nr, nregs) if (ng >= nghosts) then nl = 1 + (ng - nghosts) nu = nm - (ng - nghosts) else nl = 1 + (nghosts - ng) nu = bcells - (nghosts - ng) end if do l = 1, dblocks write (blk_name, "('datablock_', i0)") l call append_datablock(pdata, status) if (status /= 0) then call print_message(loc, "Could not append new datablock!") go to 1000 end if call h5gopen_f(grp_id, blk_name, blk_id, status) if (status == 0) then call restore_attribute_h5(blk_id, 'meta', & H5T_NATIVE_INTEGER, 1, id, status) call link_blocks(block_array(id)%ptr, pdata) call read_dataset_h5(blk_id, 'primitive_variables', & H5T_NATIVE_DOUBLE, dims(1:4), array(:,:,:,:,1), status) if (ng >= nghosts) then #if NDIMS == 3 pdata%q(:,:,:,:) = array(:,nl:nu,nl:nu,nl:nu,1) #else /* NDIMS == 3 */ pdata%q(:,:,:,:) = array(:,nl:nu,nl:nu, : ,1) #endif /* NDIMS == 3 */ else #if NDIMS == 3 pdata%q(:,nl:nu,nl:nu,nl:nu) = array(:,:,:,:,1) #else /* NDIMS == 3 */ pdata%q(:,nl:nu,nl:nu, : ) = array(:,:,:,:,1) #endif /* NDIMS == 3 */ end if call read_dataset_h5(blk_id, 'conservative_variables', & H5T_NATIVE_DOUBLE, dims(1:5), array(:,:,:,:,:), status) if (ng >= nghosts) then #if NDIMS == 3 pdata%uu(:,:,:,:,1:nr) = array(:,nl:nu,nl:nu,nl:nu,1:nr) #else /* NDIMS == 3 */ pdata%uu(:,:,:,:,1:nr) = array(:,nl:nu,nl:nu, : ,1:nr) #endif /* NDIMS == 3 */ else #if NDIMS == 3 pdata%uu(:,nl:nu,nl:nu,nl:nu,1:nr) = array(:,:,:,:,1:nr) #else /* NDIMS == 3 */ pdata%uu(:,nl:nu,nl:nu, : ,1:nr) = array(:,:,:,:,1:nr) #endif /* NDIMS == 3 */ end if call h5gclose_f(blk_id, status) if (status /= 0) & call print_message(loc, & "Could not close group '" // trim(blk_name) // "'!") else call print_message(loc, & "Could not open group '" // trim(blk_name) // "'!") end if end do deallocate(array, stat=status) if (status /= 0) & call print_message(loc, & "Could not deallocate memory for the temporary arrays!") else call print_message(loc, & "Could not allocate memory for the temporary arrays!") end if 1000 continue call h5gclose_f(grp_id, status) if (status /= 0) & call print_message(loc, "Could not close group 'datablocks'!") !------------------------------------------------------------------------------- ! end subroutine restore_datablocks_h5 ! !=============================================================================== ! ! subroutine STORE_DATABLOCKS_H5: ! ------------------------------ ! ! Subroutine stores all data blocks in the group 'datablocks'. ! ! Arguments: ! ! loc_id - the location in which store the datablocks; ! status - the subroutine call status; ! !=============================================================================== ! subroutine store_datablocks_h5(loc_id, status) use blocks , only : block_meta, block_data, list_data, get_dblocks use helpers, only : print_message implicit none integer(hid_t), intent(in) :: loc_id integer , intent(out) :: status type(block_data), pointer :: pdata character(len=64) :: blk_name integer(hid_t) :: grp_id, blk_id integer(kind=4) :: l integer(hsize_t), dimension(4) :: pdims = 1 integer(hsize_t), dimension(5) :: cdims = 1 character(len=*), parameter :: loc = 'IO::store_datablocks_h5()' !------------------------------------------------------------------------------- ! status = 0 call h5gcreate_f(loc_id, 'datablocks', grp_id, status) if (status /= 0) then call print_message(loc, "Could not create group 'datablocks'!") end if if (get_dblocks() > 0) then l = 0 pdata => list_data do while(associated(pdata)) l = l + 1 write (blk_name, "('datablock_', i0)") l call h5gcreate_f(grp_id, blk_name, blk_id, status) if (status == 0) then call store_attribute_h5(blk_id, 'meta', & H5T_NATIVE_INTEGER, 1, pdata%meta%id, status) pdims = shape(pdata%q) cdims = shape(pdata%uu) call store_dataset_h5(blk_id, 'primitive_variables', & H5T_NATIVE_DOUBLE, pdims, pdata%q, .false., status) if (status /= 0) & call print_message(loc, & "Could not store the primitive variables in " // & trim(blk_name) // "!") call store_dataset_h5(blk_id, 'conservative_variables', & H5T_NATIVE_DOUBLE, cdims, pdata%uu, .false., status) if (status /= 0) & call print_message(loc, & "Could not store the conservative variables in " // & trim(blk_name) // "!") call h5gclose_f(blk_id, status) if (status /= 0) & call print_message(loc, & "Could not close group for " // trim(blk_name) // "!") else call print_message(loc, & "Could not create group for " // trim(blk_name) // "!") end if pdata => pdata%next end do end if call h5gclose_f(grp_id, status) if (status /= 0) & call print_message(loc, "Could not close group 'datablocks'!") !------------------------------------------------------------------------------- ! end subroutine store_datablocks_h5 ! !=============================================================================== ! ! subroutine STORE_COORDINATES_H5: ! ------------------------------- ! ! Subroutine stores blocks' data such as their IDs, levels, coordinates, etc. ! in a specific location. ! ! Arguments: ! ! loc_id - the location in which store the coordinates; ! status - the subroutine call status; ! !=============================================================================== ! subroutine store_coordinates_h5(loc_id, status) use blocks , only : block_meta, block_data, list_data use blocks , only : get_dblocks use coordinates, only : toplev use coordinates, only : adx, ady #if NDIMS == 3 use coordinates, only : adz #endif /* NDIMS == 3 */ use helpers , only : print_message implicit none integer(hid_t), intent(in) :: loc_id integer , intent(out) :: status integer(hid_t) :: grp_id integer :: n type(block_meta), pointer :: pmeta type(block_data), pointer :: pdata integer(hsize_t), dimension(1) :: am = 1, im = 1 integer(hsize_t), dimension(2) :: cm = 1 integer(hsize_t), dimension(3) :: bm = 1 integer(kind=4), dimension(:) , allocatable :: ids, levels integer(kind=4), dimension(:,:) , allocatable :: coords real (kind=8), dimension(:,:,:), allocatable :: bounds character(len=*), parameter :: loc = 'IO::store_coordinates_h5()' !------------------------------------------------------------------------------- ! status = 0 call h5gcreate_f(loc_id, 'coordinates', grp_id, status) if (status /= 0) then call print_message(loc, "Could not create group 'coordinates'!") return end if am(1) = toplev call store_dataset_h5(grp_id, 'dx', H5T_NATIVE_DOUBLE, & am, adx, .false., status) call store_dataset_h5(grp_id, 'dy', H5T_NATIVE_DOUBLE, & am, ady, .false., status) #if NDIMS == 3 call store_dataset_h5(grp_id, 'dz', H5T_NATIVE_DOUBLE, & am, adz, .false., status) #endif /* NDIMS == 3 */ if (get_dblocks() > 0) then n = get_dblocks() im(1) = n cm(1) = NDIMS cm(2) = n bm(1) = NDIMS bm(2) = 2 bm(3) = n allocate(ids(n), levels(n), coords(NDIMS,n), & bounds(NDIMS,2,n), stat=status) if (status /= 0) then call print_message(loc, "Could not allocate space for coordinates!") else n = 0 pdata => list_data do while(associated(pdata)) pmeta => pdata%meta n = n + 1 ids(n) = pmeta%id levels(n) = pmeta%level coords(:,n) = pmeta%coords(:) bounds(1,:,n) = [ pmeta%xmin, pmeta%xmax ] bounds(2,:,n) = [ pmeta%ymin, pmeta%ymax ] #if NDIMS == 3 bounds(3,:,n) = [ pmeta%zmin, pmeta%zmax ] #endif /* NDIMS == 3 */ pdata => pdata%next end do call store_dataset_h5(grp_id, 'ids', H5T_NATIVE_INTEGER, & im, ids, .false., status) call store_dataset_h5(grp_id, 'levels', H5T_NATIVE_INTEGER, & im, levels, .false., status) call store_dataset_h5(grp_id, 'coords', H5T_NATIVE_INTEGER, & cm, coords, .false., status) call store_dataset_h5(grp_id, 'bounds', H5T_NATIVE_DOUBLE, & bm, bounds, .false., status) deallocate(ids, levels, coords, bounds, stat=status) if (status > 0) & call print_message(loc, "Could not deallocate the coordinate space!") end if end if call h5gclose_f(grp_id, status) if (status < 0) & call print_message(loc, "Could not close group 'coordinates'!") !------------------------------------------------------------------------------- ! end subroutine store_coordinates_h5 ! !=============================================================================== ! ! subroutine STORE_VARIABLES_H5: ! ----------------------------- ! ! Subroutine stores primitive variables in a specific location. ! ! Arguments: ! ! loc_id - the location in which store the variables; ! status - the subroutine call status; ! !=============================================================================== ! subroutine store_variables_h5(loc_id, status) use blocks , only : block_data, list_data use blocks , only : get_dblocks use coordinates , only : bcells use equations , only : nv, pvars use helpers , only : print_message use iso_c_binding, only : c_loc implicit none integer(hid_t), intent(in) :: loc_id integer , intent(out) :: status integer(hid_t) :: grp_id integer :: n, p integer(hsize_t), dimension(4) :: dims = 1 type(block_data), pointer :: pdata real(kind=8), dimension(:,:,:,:), allocatable, target :: array character(len=*), parameter :: loc = 'IO::store_variables_h5()' !------------------------------------------------------------------------------- ! status = 0 call h5gcreate_f(loc_id, 'variables', grp_id, status) if (status /= 0) then call print_message(loc, "Could not create group 'variables'!") return end if if (get_dblocks() > 0) then dims(1:NDIMS) = bcells dims(4) = get_dblocks() allocate(array(dims(1),dims(2),dims(3),dims(4)), stat=status) if (status /= 0) then call print_message(loc, "Could not allocate space for variables!") else do p = 1, nv n = 0 pdata => list_data do while(associated(pdata)) n = n + 1 array(:,:,:,n) = pdata%q(p,:,:,:) pdata => pdata%next end do call store_dataset_h5(grp_id, trim(pvars(p)), & H5T_NATIVE_DOUBLE, dims, array, .true., status) end do deallocate(array, stat=status) if (status /= 0) & call print_message(loc, "Could not deallocate the variable space!") end if end if call h5gclose_f(grp_id, status) if (status /= 0) & call print_message(loc, "Could not close group 'variables'!") !------------------------------------------------------------------------------- ! end subroutine store_variables_h5 ! !=============================================================================== ! ! subroutine RESTORE_ATTRIBUTE_STRING_H5: ! -------------------------------------- ! ! Subroutine restores a string attribute from a given location. ! ! Arguments: ! ! loc_id - the location in which the dataset is stored; ! name - the attribute's name; ! string - the attribute's buffer; ! status - the subroutine call status; ! !=============================================================================== ! subroutine restore_attribute_string_h5(loc_id, name, string, status) use helpers , only : print_message use iso_c_binding, only : c_loc implicit none integer(hid_t) , intent(in) :: loc_id character(len=*) , intent(in) :: name character(len=*), target, intent(inout) :: string integer , intent(out) :: status integer(hid_t) :: attr_id, type_id, mem_id integer(hsize_t) :: length, attr_size logical :: flag type(c_ptr) :: str_ptr character(len=*), parameter :: loc = 'IO::restore_attribute_string_h5' !------------------------------------------------------------------------------- ! call h5aexists_by_name_f(loc_id, '.', trim(name), flag, status) if (status /= 0) then call print_message(loc, & "Could not check if attribute '" // trim(name) // "' exists!") return end if if (flag) then call h5aopen_by_name_f(loc_id, '.', trim(name), attr_id, status) if (status /= 0) then call print_message(loc, & "Could not open attribute '" // trim(name) // "'!") return end if call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, status) if (status /= 0) then call print_message(loc, & "Could not copy the datatype for attribute '" // trim(name) // "'!") go to 1000 end if call h5aget_storage_size_f(attr_id, attr_size, status) if (status /= 0) then call print_message(loc, & "Could not get the datatype size of attribute '" // & trim(name) // "'!") go to 1000 end if call h5tset_size_f(type_id, attr_size, status) if (status /= 0) then call print_message(loc, & "Could not set the datatype size for attribute '" // & trim(name) // "'!") go to 1000 end if call h5aget_type_f(attr_id, mem_id, status) if (status /= 0) then call print_message(loc, & "Could not get the datatype of attribute '" // trim(name) // "'!") go to 1000 end if call h5tequal_f(type_id, mem_id, flag, status) if (status /= 0) then call print_message(loc, & "The datatypes of the input string and attribute '" // & trim(name) // "' do not match!") go to 1000 end if length = len(string) if (length < attr_size) then call print_message(loc, & "The string is too small for storing attribute '" // & trim(name) // "'!") go to 1000 end if if (flag) then string = "" str_ptr = c_loc(string) call h5aread_f(attr_id, type_id, str_ptr, status) if (status /= 0) then call print_message(loc, & "Could not read attribute '" // trim(name) // "'!") end if end if 1000 continue call h5aclose_f(attr_id, status) if (status /= 0) & call print_message(loc, & "Could not close attribute '" // trim(name) // "'!") else call print_message(loc, "Attribute '" // trim(name) // "' not found!") end if !------------------------------------------------------------------------------- ! end subroutine restore_attribute_string_h5 ! !=============================================================================== ! ! subroutine RESTORE_ATTRIBUTE_NUMBER_H5: ! -------------------------------------- ! ! Subroutine restores a number (integer or real) attribute from a given ! location. Both scalar and vectors are supported. ! ! Arguments: ! ! loc_id - the location in which the dataset is stored; ! name - the attribute's name; ! type_id - the HDF5 type of attribute; ! length - the number of attribute's elements; ! buffer - the attribute's data; ! status - the subroutine call status; ! !=============================================================================== ! subroutine restore_attribute_number_h5(loc_id, name, type_id, & length, buffer, status) use helpers , only : print_message use iso_c_binding, only : c_loc implicit none integer(hid_t) , intent(in) :: loc_id, type_id character(len=*) , intent(in) :: name integer , intent(in) :: length type(*), target , dimension(..), intent(inout) :: buffer integer , intent(out) :: status integer(hid_t) :: attr_id, spc_id, mem_id integer(hsize_t), dimension(1) :: dims, mdims logical :: flag integer :: rank, cls_type type(c_ptr) :: buffer_ptr character(len=*), parameter :: loc = 'IO::restore_attribute_h5' !------------------------------------------------------------------------------- ! call h5aexists_by_name_f(loc_id, '.', trim(name), flag, status) if (status /= 0) then call print_message(loc, & "Could not check if attribute '" // trim(name) // "' exists!") return end if if (flag) then call h5aopen_by_name_f(loc_id, '.', trim(name), attr_id, status) if (status /= 0) then call print_message(loc, & "Could not open attribute '" // trim(name) // "'!") return end if call h5aget_type_f(attr_id, mem_id, status) if (status /= 0) then call print_message(loc, & "Could not get the datatype of attribute '" // trim(name) // "'!") go to 1000 end if call h5tequal_f(type_id, mem_id, flag, status) if (status /= 0) then call print_message(loc, & "The datatypes of the input buffer and attribute '" // & trim(name) // "' do not match!") go to 1000 end if if (flag) then call h5aget_space_f(attr_id, spc_id, status) if (status /= 0) then call print_message(loc, & "Could not get the dataspace of attribute '" // trim(name) // "'!") go to 1000 end if call h5sget_simple_extent_type_f(spc_id, cls_type, status) if (status /= 0) then call print_message(loc, & "Could not get the dataspace type for attribute '" // & trim(name) // "'!") go to 900 end if if (cls_type == H5S_SCALAR_F) then buffer_ptr = c_loc(buffer) call h5aread_f(attr_id, type_id, buffer_ptr, status) if (status /= 0) then call print_message(loc, & "Could not read attribute '" // trim(name) // "'!") end if else if (cls_type == H5S_SIMPLE_F) then call h5sget_simple_extent_dims_f(spc_id, dims, mdims, rank) if (rank /= 1) then call print_message(loc, "Only rank equal 1 is supported!") go to 800 end if mdims(1) = length if (dims(1) /= mdims(1)) then call print_message(loc, & "The dataspace dimensions the input buffer and attribute '" // & trim(name) // "' do not match!") go to 800 end if buffer_ptr = c_loc(buffer) call h5aread_f(attr_id, type_id, buffer_ptr, status) if (status /= 0) then call print_message(loc, & "Could not read attribute '" // trim(name) // "'!") end if 800 continue else call print_message(loc, & "The dataspace type of attribute '" // trim(name) // & "' is not supported!") end if 900 continue call h5sclose_f(spc_id, status) if (status /= 0) & call print_message(loc, & "Could not close the dataspace of attribute '" // trim(name) // "'!") end if 1000 continue call h5aclose_f(attr_id, status) if (status /= 0) & call print_message(loc, & "Could not close attribute '" // trim(name) // "'!") else call print_message(loc, "Attribute '" // trim(name) // "' not found!") end if !------------------------------------------------------------------------------- ! end subroutine restore_attribute_number_h5 ! !=============================================================================== ! ! subroutine STORE_ATTRIBUTE_STRING_H5: ! ------------------------------------ ! ! Subroutine stores a string attribute in a given location. ! ! Arguments: ! ! loc_id - the location in which the dataset is stored; ! name - the attribute's name; ! string - the attribute's text; ! status - the subroutine call status; ! !=============================================================================== ! subroutine store_attribute_string_h5(loc_id, name, string, status) use helpers , only : print_message use iso_c_binding, only : c_loc implicit none integer(hid_t) , intent(in) :: loc_id character(len=*) , intent(in) :: name character(len=*), target, intent(in) :: string integer , intent(out) :: status integer(hid_t) :: mem_id, spc_id, attr_id integer(hsize_t) :: length character(len=*), parameter :: loc = 'IO::store_attribute_string_h5()' !------------------------------------------------------------------------------- ! call h5tcopy_f(H5T_NATIVE_CHARACTER, mem_id, status) if (status /= 0) then call print_message(loc, & "Could not copy the datatype for attribute '" // trim(name) // "'!") return end if length = len(trim(string)) call h5tset_size_f(mem_id, length, status) if (status /= 0) then call print_message(loc, & "Could not set the datatype size for attribute '" // trim(name) // "'!") return end if call h5screate_f(H5S_SCALAR_F, spc_id, status) if (status /= 0) then call print_message(loc, & "Could not create the dataspace for attribute '" // trim(name) // "'!") return end if call h5acreate_f(loc_id, trim(name), mem_id, spc_id, attr_id, status) if (status /= 0) then call print_message(loc, & "Could not create attribute '" // trim(name) // "'!") go to 1000 end if call h5awrite_f(attr_id, mem_id, c_loc(string), status) if (status /= 0) & call print_message(loc, & "Could not write attribute " // trim(name) // "'!") call h5aclose_f(attr_id, status) if (status /= 0) & call print_message(loc, & "Could not close attribute '" // trim(name) // "'!") 1000 continue call h5sclose_f(spc_id, status) if (status /= 0) & call print_message(loc, & "Could not close the dataspace for attribute '" // trim(name) // "'!") !------------------------------------------------------------------------------- ! end subroutine store_attribute_string_h5 ! !=============================================================================== ! ! subroutine STORE_ATTRIBUTE_NUMBER_H5: ! ------------------------------------ ! ! Subroutine stores a number (integer or real) attribute in a given location. ! Both scalar and vectors are supported. ! ! Arguments: ! ! loc_id - the location in which the dataset is stored; ! name - the attribute's name; ! type_id - the HDF5 type of attribute; ! length - the number of attribute elements ! buffer - the attribute's data; ! status - the subroutine call status; ! !=============================================================================== ! subroutine store_attribute_number_h5(loc_id, name, type_id, & length, buffer, status) use helpers , only : print_message use iso_c_binding, only : c_loc implicit none integer(hid_t) , intent(in) :: loc_id, type_id character(len=*) , intent(in) :: name integer , intent(in) :: length type(*), target , dimension(..), intent(in) :: buffer integer , intent(out) :: status integer(hid_t) :: spc_id, attr_id integer(hsize_t), dimension(1) :: dims = 1 character(len=*), parameter :: loc = 'IO::store_attribute_number_h5()' !------------------------------------------------------------------------------- ! dims(1) = length if (length > 1) then call h5screate_simple_f(1, dims, spc_id, status) else call h5screate_f(H5S_SCALAR_F, spc_id, status) end if if (status /= 0) then call print_message(loc, & "Could not create the dataspace for attribute '" // trim(name) // "'!") return end if call h5acreate_f(loc_id, trim(name), type_id, spc_id, attr_id, status) if (status /= 0) then call print_message(loc, & "Could not create attribute '" // trim(name) // "'!") go to 1000 end if call h5awrite_f(attr_id, type_id, c_loc(buffer), status) if (status /= 0) & call print_message(loc, & "Could not write attribute " // trim(name) // "'!") call h5aclose_f(attr_id, status) if (status /= 0) & call print_message(loc, & "Could not close attribute '" // trim(name) // "'!") 1000 continue call h5sclose_f(spc_id, status) if (status /= 0) & call print_message(loc, & "Could not close the dataspace for attribute '" // trim(name) // "'!") !------------------------------------------------------------------------------- ! end subroutine store_attribute_number_h5 ! !=============================================================================== ! ! subroutine READ_DATASET_H5: ! --------------------------- ! ! Subroutine reads a generic dataset. ! ! Arguments: ! ! loc_id - the location in which the dataset is stored; ! name - the dataset name; ! type_id - the dataset type; ! dims - the dataset dimensions; ! buffer - the dataset buffer; ! status - the subroutine call status; ! !=============================================================================== ! subroutine read_dataset_h5(loc_id, name, type_id, dims, buffer, status) use helpers , only : print_message use iso_c_binding, only : c_loc implicit none integer(hid_t) , intent(in) :: loc_id, type_id character(len=*) , intent(in) :: name integer(hsize_t), dimension(:), intent(in) :: dims type(*), target, dimension(..), intent(inout) :: buffer integer , intent(out) :: status type(c_ptr) :: buffer_ptr logical :: flag integer :: rank integer(hid_t) :: space_id, dset_id, mem_id integer(hsize_t), dimension(size(dims)) :: ddims, mdims character(len=*), parameter :: loc = 'IO::read_dataset_h5()' !------------------------------------------------------------------------------- ! status = 0 call h5dopen_f(loc_id, trim(name), dset_id, status) if (status /= 0) then call print_message(loc, "Could not open dataset '" // trim(name) // "'!") status = 1 return end if call h5dget_type_f(dset_id, mem_id, status) if (status /= 0) then call print_message(loc, & "Could not get the datatype for dataset '" // trim(name) // "'!") go to 1000 end if call h5tequal_f(type_id, mem_id, flag, status) if (status < 0) then call print_message(loc, & "Could not compare the buffer and dataset '" // trim(name) // & "' types!") go to 1000 end if if (.not. flag) then call print_message(loc, & "Datatypes of the buffer and dataset '" // trim(name) // & "' do not match!") go to 1000 end if call h5dget_space_f(dset_id, space_id, status) if (status /= 0) then call print_message(loc, & "Could not get the dataspace for dataset '" // trim(name) // "'!") go to 1000 end if call h5sget_simple_extent_dims_f(space_id, ddims, mdims, rank) if (rank /= size(dims)) then call print_message(loc, "Wrong rank of dataset '" // trim(name) // "'!") status = 1 go to 900 end if if (any(ddims /= dims)) then call print_message(loc, & "Wrong dimensions of dataset '" // trim(name) // "'!") status = 1 go to 900 end if buffer_ptr = c_loc(buffer) call h5dread_f(dset_id, type_id, buffer_ptr, status) if (status /= 0) & call print_message(loc, "Could not read dataset '" // trim(name) // "'!") 900 continue call h5sclose_f(space_id, status) if (status /= 0) & call print_message(loc, & "Could not close the dataspace for dataset '" // trim(name) // "'!") 1000 continue call h5dclose_f(dset_id, status) if (status /= 0) & call print_message(loc, "Could not close dataset '" // trim(name) // "'!") !------------------------------------------------------------------------------- ! end subroutine read_dataset_h5 ! !=============================================================================== ! ! subroutine STORE_DATASET_H5: ! --------------------------- ! ! Subroutine stores a generic dataset. ! ! Arguments: ! ! loc_id - the location in which the dataset is stored; ! name - the dataset name; ! type_id - the dataset type; ! dims - the dataset dimensions; ! buffer - the dataset buffer to store; ! compress - the logical flag inficating is dataset should be compressed; ! status - the subroutine call status; ! !=============================================================================== ! subroutine store_dataset_h5(loc_id, name, type_id, dims, & buffer, compress, status) use helpers , only : print_message use iso_c_binding, only : c_loc implicit none integer(hid_t) , intent(in) :: loc_id, type_id character(len=*) , intent(in) :: name integer(hsize_t), dimension(:), intent(in) :: dims type(*), target, dimension(..), intent(in) :: buffer logical , intent(in) :: compress integer , intent(out) :: status integer :: rank integer(hid_t) :: space_id, dset_id integer(hsize_t), dimension(size(dims)) :: cdims character(len=*), parameter :: loc = 'IO::store_dataset_h5()' !------------------------------------------------------------------------------- ! rank = size(dims) cdims = dims if (compress .and. hcformat .eq. H5Z_ZFP) cdims(rank) = 1 call h5screate_simple_f(rank, dims, space_id, status) if (status /= 0) then call print_message(loc, & "Could not create the dataspace for dataset '" // trim(name) // "'!") return end if call h5pset_chunk_f(prp_id, rank, cdims, status) if (status /= 0) then call print_message(loc, & "Could not set the chunk size for dataset '" // trim(name) // "'!") go to 1000 end if if (compress) then call h5dcreate_f(loc_id, name, type_id, space_id, dset_id, status, prp_id) else call h5dcreate_f(loc_id, name, type_id, space_id, dset_id, status) end if if (status /= 0) then call print_message(loc, & "Could not create dataset '" // trim(name) // "'!") go to 1000 end if call h5dwrite_f(dset_id, type_id, c_loc(buffer), status) if (status /= 0) then call print_message(loc, "Could not store dataset '" // trim(name) // "'!") end if call h5dclose_f(dset_id, status) if (status /= 0) & call print_message(loc, "Could not close dataset '" // trim(name) // "'!") 1000 continue call h5sclose_f(space_id, status) if (status /= 0) & call print_message(loc, & "Could not close the dataspace for dataset '" // trim(name) // "'!") !------------------------------------------------------------------------------- ! end subroutine store_dataset_h5 ! !=============================================================================== ! ! XDMF SUBROUTINES ! !=============================================================================== ! ! subroutine WRITE_SNAPSHOT_XDMF: ! ------------------------------ ! ! Subroutine writes an XDMF file per snapshot per MPI process. ! XDMF file is just a wrapper which helps to load data in a visualization ! tools like Paraview or Visit. ! ! Based on the subroutine by Pierre Kestener ! (see https://bitbucket.org/pkestene/amun-code). ! ! !=============================================================================== ! subroutine write_snapshot_xdmf() use blocks , only : block_data, list_data use blocks , only : get_dblocks use equations , only : nv, pvars use mpitools , only : nproc use coordinates, only : ni => ncells, ng => nghosts use coordinates, only : adx, ady #if NDIMS == 3 use coordinates, only : adz #endif /* NDIMS == 3 */ use evolution , only : time implicit none type(block_data), pointer :: pdata character(len=64) :: fname, hname character(len=128) :: stmp, ttmp, sdim, bdim, pdim integer(kind=4) :: l, p integer(kind=4) :: ip, jp #if NDIMS == 3 integer(kind=4) :: kp #endif /* NDIMS == 3 */ integer, dimension(12) :: slab integer, parameter :: xdmf = 101 !------------------------------------------------------------------------------- ! write (fname, "('p',i6.6,'_',i5.5,'.xdmf')") isnap, nproc write (hname, "('p',i6.6,'_',i5.5,'.h5' )") isnap, nproc open (unit=xdmf, file=fname, status='replace') ! write the header ! write (xdmf, "(a)") '' write (xdmf, "(a)") '' write (xdmf, "(a)") ' ' write (stmp, "(1i16)") nproc write (xdmf, "(a)") ' ' write (stmp, "(1g15.8)") time write (xdmf, "(a)") ' ' write (xdmf, "(a)") ' ' write (xdmf, "(a)") '' close (xdmf) !------------------------------------------------------------------------------- ! end subroutine write_snapshot_xdmf ! !=============================================================================== ! ! subroutine WRITE_SNAPSHOT_XDMF_MASTER: ! ------------------------------------- ! ! Subroutine writes one XDMF file per snapshot in root MPI process to gather ! all MPI subdomains. ! ! Based on the subroutine by Pierre Kestener ! (see https://bitbucket.org/pkestene/amun-code). ! ! !=============================================================================== ! subroutine write_snapshot_xdmf_master() use mpitools, only : npmax implicit none character(len=64) :: fname, pname integer(kind=4) :: np integer, parameter :: xdmf = 102 !------------------------------------------------------------------------------- ! write (fname, "('p',i6.6,'.xdmf')") isnap open (unit=xdmf, file=fname, status='replace') ! write the header ! write (xdmf, "(a)") '' write (xdmf, "(a)") '' write (xdmf, "(a)") ' ' write (xdmf, "(a)") ' ' ! write references to MPI subdomain files ! do np = 0, npmax write (pname, "('p',i6.6,'_',i5.5,'.xdmf')") isnap, np write (xdmf, "(a)") ' ' end do ! close the XDMF structures ! write (xdmf, "(a)") ' ' write (xdmf, "(a)") ' ' write (xdmf, "(a)") '' close (xdmf) !------------------------------------------------------------------------------- ! end subroutine write_snapshot_xdmf_master #endif /* HDF5 */ !=============================================================================== ! end module