gkowal/amun-code
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
amun-code/sources/io.F90
Grzegorz Kowal ec16bdff05 IO: Fix restart from XML format when nghosts becomes smaller. 
Signed-off-by: Grzegorz Kowal <grzegorz@amuncode.org>
2021-03-18 17:26:52 -03:00

9343 lines
276 KiB
Fortran
Raw Blame History

!!******************************************************************************
!!
!! 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-2021 Grzegorz Kowal <grzegorz@amuncode.org>
!!
!! 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 <http://www.gnu.org/licenses/>.
!!
!!******************************************************************************
!!
!! module: IO
!!
!! This module handles data storage and job restart from restart files.
!!
!!
!!******************************************************************************
!
module io
! import external subroutines
!
use blocks, only : pointer_meta
#ifdef HDF5
use hdf5 , only : hid_t
#endif /* HDF5 */
use timers, only : set_timer, start_timer, stop_timer
! module variables are not implicit by default
!
implicit none
! subroutine interfaces
!
interface read_snapshot_parameter
module procedure read_snapshot_parameter_string
module procedure read_snapshot_parameter_integer
module procedure read_snapshot_parameter_double
end interface
interface write_attribute_xml
module procedure write_attribute_xml_string
module procedure write_attribute_xml_integer
module procedure write_attribute_xml_double
module procedure write_attribute_xml_file
end interface
#ifdef HDF5
interface read_snapshot_parameter_h5
module procedure read_snapshot_parameter_string_h5
module procedure read_snapshot_parameter_integer_h5
module procedure read_snapshot_parameter_double_h5
end interface
#endif /* HDF5 */
interface write_attribute
#ifdef HDF5
module procedure write_scalar_attribute_string_h5
module procedure write_scalar_attribute_integer_h5
module procedure write_scalar_attribute_double_h5
module procedure write_vector_attribute_integer_h5
module procedure write_array_attribute_long_h5
module procedure write_array_attribute_complex_h5
#endif /* HDF5 */
end interface
interface read_attribute
#ifdef HDF5
module procedure read_scalar_attribute_integer_h5
module procedure read_scalar_attribute_double_h5
module procedure read_array_attribute_long_h5
module procedure read_array_attribute_complex_h5
#endif /* HDF5 */
end interface
interface write_array
#ifdef HDF5
module procedure write_1d_array_integer_h5
module procedure write_2d_array_integer_h5
#if NDIMS == 2
module procedure write_3d_array_integer_h5
#endif /* NDIMS == 2 */
module procedure write_4d_array_integer_h5
#if NDIMS == 3
module procedure write_5d_array_integer_h5
#endif /* NDIMS == 3 */
module procedure write_1d_array_double_h5
module procedure write_3d_array_double_h5
module procedure write_4d_array_double_h5
#endif /* HDF5 */
end interface
interface read_array
#ifdef HDF5
module procedure read_1d_array_integer_h5
module procedure read_2d_array_integer_h5
#if NDIMS == 2
module procedure read_3d_array_integer_h5
#endif /* NDIMS == 2 */
module procedure read_4d_array_integer_h5
#if NDIMS == 3
module procedure read_5d_array_integer_h5
#endif /* NDIMS == 3 */
module procedure read_1d_array_double_h5
module procedure read_4d_array_double_h5
#endif /* HDF5 */
end interface
! timer indices
!
integer , save :: iio
#ifdef PROFILE
integer , save :: ioi, iow, ios
#endif /* PROFILE */
! 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;
! ftype - the type of snapshots to write:
! 'p' -> all primitive variables (default);
! 'c' -> all conserved variables;
! 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 = "./"
character , save :: ftype = "p"
character(len=64) , save :: ftype_name = "primitive"
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.
! flags to determine the way of data writing
!
logical , save :: with_ghosts = .true.
! a flag to determine if XDMF files should be generated
!
logical , save :: with_xdmf = .false.
! the compression format and level of the XML+binary files
!
character(len=255), save :: cformat = "none" ! compression format
integer , save :: clevel = 3 ! compression level
! the suffix of binary files in the XML+binary format
!
character(len=8) , save :: binary_file_suffix = ".bin"
#ifdef HDF5
! compression type
!
integer , parameter :: H5Z_DEFLATE = 1, H5Z_ZSTANDARD = 32015
! compression type (0 for no compressions, 1 for deflate, 32015 for zstandard)
!
integer , save :: compression = 0, hclevel = 3
! HDF5 property object identifier
!
integer(hid_t) , save :: pid
! local variables to store the number of processors
!
integer(kind=4) , save :: nfiles = 1
! array of pointer used during job restart
!
type(pointer_meta), dimension(:), allocatable, save :: block_array
#endif /* HDF5 */
! by default everything is private
!
private
! declare public subroutines
!
public :: initialize_io, finalize_io, print_io
public :: restart_snapshot_number, restart_from_snapshot
public :: read_snapshot_parameter
public :: read_restart_snapshot, write_restart_snapshot, write_snapshot
public :: next_tout, precise_snapshots
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
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)
! import external procedures
!
use compression , only : set_compression, get_compression
#ifdef HDF5
use hdf5 , only : hsize_t
use hdf5 , only : H5P_DATASET_CREATE_F, H5Z_FLAG_OPTIONAL_F
use hdf5 , only : h5open_f, h5zfilter_avail_f, h5pcreate_f
use hdf5 , only : h5pset_deflate_f, h5pset_filter_f
#endif /* HDF5 */
use iso_fortran_env, only : error_unit
use mpitools , only : nproc
use parameters , only : get_parameter
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
logical, intent(in) :: verbose
integer, intent(out) :: status
! local variables
!
logical :: test
character(len=255) :: dname
character(len=255) :: sformat = "xml"
character(len=255) :: precise = "off"
character(len=255) :: ghosts = "on"
character(len=255) :: xdmf = "off"
character(len=255) :: suffix = "" ! compression file suffix
#ifdef HDF5
logical :: cmpstatus = .false.
integer(hsize_t) :: cd_nelmts = 1
integer, dimension(1) :: cd_values = 3
#endif /* HDF5 */
#ifdef HDF5
! local parameters
!
character(len=*), parameter :: loc = 'IO::initialize_io()'
#endif /* HDF5 */
!
!-------------------------------------------------------------------------------
!
! set timer descriptions
!
call set_timer('SNAPSHOTS I/O' , iio)
#ifdef PROFILE
call set_timer('io:: initialization' , ioi)
call set_timer('io:: snapshot writing', iow)
call set_timer('io:: snapshot reading', ios)
! start accounting time for module initialization/finalization
!
call start_timer(ioi)
#endif /* PROFILE */
! reset the status flag
!
status = 0
! get module parameters
!
call get_parameter("restart_path" , respath)
call get_parameter("restart_number" , nrest )
call get_parameter("restart_interval" , hrest )
call get_parameter("snapshot_type" , ftype )
call get_parameter("snapshot_interval", hsnap )
call get_parameter("precise_snapshots", precise)
call get_parameter("include_ghosts" , ghosts )
call get_parameter("generate_xdmf" , xdmf )
! add slash at the end of respath if not present
!
if (index(respath, '/', back = .true.) /= len(trim(respath))) then
write(respath,"(a)") trim(adjustl(respath)) // '/'
end if
! check the snapshot format
!
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
! check the restart snapshot format
!
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
! check the last available restart snapshot
!
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
! get compression format and level for XML+binary files
!
call get_parameter("compression_format", cformat)
call get_parameter("compression_level" , clevel)
call set_compression(cformat, clevel, suffix)
if (get_compression() > 0) then
binary_file_suffix = ".bin" // trim(adjustl(suffix))
end if
! check the snapshot type
!
select case(ftype)
case('c')
ftype_name = 'conservative variables'
case('p')
ftype_name = 'primitive variables'
case default
if (verbose) then
write(*,*)
write(*,"(1x,a)") "ERROR!"
write(*,"(1x,a)") "The selected snapshot type is not " // &
"implemented: '" // trim(ftype) // "'."
write(*,"(1x,a)") "Available snapshot types: 'p' for primitive " // &
"variables, 'c' for conservative variables."
end if
status = 1
end select
if (status == 0) then
! check ghost cell storing flag
!
select case(trim(precise))
case ("off", "OFF", "n", "N", "false", "FALSE", "no", "NO")
precise_snapshots = .false.
case default
precise_snapshots = .true.
end select
! check ghost cell storing flag
!
select case(trim(ghosts))
case ("off", "OFF", "n", "N", "false", "FALSE", "no", "NO")
with_ghosts = .false.
case default
with_ghosts = .true.
end select
! check flag for generating XDMF files
!
select case(trim(xdmf))
case ("off", "OFF", "n", "N", "false", "FALSE", "no", "NO")
with_xdmf = .false.
case default
with_xdmf = .true.
end select
#ifdef HDF5
! initialize the FORTRAN interface
!
call h5open_f(status)
! in the case of error, print a message and quit the subroutine
!
if (status < 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot initialize the HDF5 Fortran interface!"
else
! prepare the property object for compression
!
call h5pcreate_f(H5P_DATASET_CREATE_F, pid, status)
! check if the object has been created properly, if not quit
!
if (status < 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create the compression property for datasets!"
else
! detect available compressions
!
cmpstatus = .false.
if (.not. cmpstatus) then
call h5zfilter_avail_f(H5Z_ZSTANDARD, cmpstatus, status)
if (cmpstatus) compression = H5Z_ZSTANDARD
end if
if (.not. cmpstatus) then
call h5zfilter_avail_f(H5Z_DEFLATE, cmpstatus, status)
if (cmpstatus) compression = H5Z_DEFLATE
end if
! get compression_level
!
call get_parameter("compression_level", hclevel)
! initialize proper compressor
!
if (status == 0) then
select case(compression)
case(H5Z_ZSTANDARD)
if (hclevel < 1 .or. hclevel > 20) hclevel = 3
cd_values(:) = hclevel
call h5pset_filter_f(pid, H5Z_ZSTANDARD, H5Z_FLAG_OPTIONAL_F, &
cd_nelmts, cd_values, status)
case(H5Z_DEFLATE)
if (hclevel < 1 .or. hclevel > 9) hclevel = 6
call h5pset_deflate_f(pid, hclevel, status)
case default
end select
end if
end if
end if
#endif /* HDF5 */
end if ! status
#ifdef PROFILE
! stop accounting time for module initialization/finalization
!
call stop_timer(ioi)
#endif /* PROFILE */
!-------------------------------------------------------------------------------
!
end subroutine initialize_io
!
!===============================================================================
!
! subroutine FINALIZE_IO:
! ----------------------
!
! Subroutine releases memory used by the module.
!
! Arguments:
!
! status - an integer flag for error return value;
!
!===============================================================================
!
subroutine finalize_io(status)
! import external procedures
!
#ifdef HDF5
use hdf5 , only : h5pclose_f, h5close_f
use iso_fortran_env, only : error_unit
#endif /* HDF5 */
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer, intent(out) :: status
#ifdef HDF5
! local parameters
!
character(len=*), parameter :: loc = 'IO::finalize_io()'
#endif /* HDF5 */
!
!-------------------------------------------------------------------------------
!
#ifdef PROFILE
! start accounting time for module initialization/finalization
!
call start_timer(ioi)
#endif /* PROFILE */
! reset the status flag
!
status = 0
#ifdef HDF5
! close the property object for compression
!
call h5pclose_f(pid, status)
! check if the object has been closed properly
!
if (status < 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the compression property for datasets!"
end if
! close the FORTRAN interface
!
call h5close_f(status)
! check if the interface has been closed successfuly
!
if (status > 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the HDF5 Fortran interface!"
return
end if
#endif /* HDF5 */
#ifdef PROFILE
! stop accounting time for module initialization/finalization
!
call stop_timer(ioi)
#endif /* PROFILE */
!-------------------------------------------------------------------------------
!
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)
! import external procedures and variables
!
use helpers, only : print_section, print_parameter
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
logical, intent(in) :: verbose
! local variables
!
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, "compression format", cformat)
call print_parameter(verbose, "compression level", clevel)
end select
if (precise_snapshots) then
call print_parameter(verbose, "precise snapshot intervals", "on" )
else
call print_parameter(verbose, "precise snapshot intervals", "off")
end if
call print_parameter(verbose, "snapshot type", ftype_name)
if (with_ghosts) then
call print_parameter(verbose, "with ghosts cells", "on" )
else
call print_parameter(verbose, "with ghosts cells", "off")
end if
#ifdef HDF5
select case(compression)
case(H5Z_ZSTANDARD)
call print_parameter(verbose, "HDF5 compression" , "zstd" )
call print_parameter(verbose, "compression level", hclevel )
case(H5Z_DEFLATE)
call print_parameter(verbose, "HDF5 compression" , "deflate")
call print_parameter(verbose, "compression level", hclevel )
case default
call print_parameter(verbose, "HDF5 compression" , "none" )
end select
#endif /* HDF5 */
if (with_xdmf) then
call print_parameter(verbose, "generate XDMF files", "on" )
else
call print_parameter(verbose, "generate XDMF files", "off")
end if
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()
! local variables are not implicit by default
!
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()
! local variables are not implicit by default
!
implicit none
!
!-------------------------------------------------------------------------------
!
restart_from_snapshot = (nrest > 0)
!-------------------------------------------------------------------------------
!
end function restart_from_snapshot
!
!===============================================================================
!
! 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 evolution, only : time
implicit none
integer, intent(out) :: status
!
!-------------------------------------------------------------------------------
!
#ifdef PROFILE
call start_timer(ios)
#endif /* PROFILE */
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
! 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)
#ifdef PROFILE
call stop_timer(ios)
#endif /* PROFILE */
!-------------------------------------------------------------------------------
!
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;
! nrun - the run number;
! status - the status flag;
!
!===============================================================================
!
subroutine write_restart_snapshot(thrs, nrun, status)
! local variables are not implicit by default
!
implicit none
! input and output arguments
!
real(kind=8), intent(in) :: thrs
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
#ifdef PROFILE
call start_timer(iow)
#endif /* PROFILE */
call start_timer(iio)
select case(snapshot_format)
#ifdef HDF5
case(snapshot_hdf5)
call write_restart_snapshot_h5(nrun, status)
#endif /* HDF5 */
case default
call write_restart_snapshot_xml(nrun, status)
end select
! increase the restart snapshot counter
!
irest = irest + 1
call stop_timer(iio)
#ifdef PROFILE
call stop_timer(iow)
#endif /* PROFILE */
!-------------------------------------------------------------------------------
!
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.
!
!
!===============================================================================
!
subroutine write_snapshot()
use evolution, only : time
#ifdef HDF5
use mpitools , only : master
#endif /* HDF5 */
implicit none
! local variables
!
integer :: status
!
!-------------------------------------------------------------------------------
!
if (hsnap <= 0.0e+00 .or. time < tsnap) return
#ifdef PROFILE
call start_timer(iow)
#endif /* PROFILE */
call start_timer(iio)
select case(snapshot_format)
#ifdef HDF5
case(snapshot_hdf5)
call write_snapshot_h5()
if (with_xdmf) then
call write_snapshot_xdmf()
if (master) call write_snapshot_xdmf_master()
end if
#endif /* HDF5 */
case default
call write_snapshot_xml(status)
end select
! increase the snapshot counter and calculate the next snapshot time
!
isnap = isnap + 1
tsnap = (ishift + isnap) * hsnap
call stop_timer(iio)
#ifdef PROFILE
call stop_timer(iow)
#endif /* PROFILE */
!-------------------------------------------------------------------------------
!
end subroutine write_snapshot
!
!===============================================================================
!
! function NEXT_TOUT:
! ------------------
!
! Function returns the next data snapshot time.
!
!
!===============================================================================
!
real(kind=8) function next_tout()
! local variables are not implicit by default
!
implicit none
!
!-------------------------------------------------------------------------------
!
if (hsnap > 0.0d+00) then
next_tout = tsnap
else
next_tout = huge(hsnap)
end if
!-------------------------------------------------------------------------------
!
end function next_tout
!
!===============================================================================
!!
!!*** PRIVATE SUBROUTINES ****************************************************
!!
!===============================================================================
!
!===============================================================================
!
! subroutine READ_SNAPSHOT_PARAMETER_STRING:
! -----------------------------------------
!
! Subroutine reads a string parameter from the restart snapshot.
!
! Arguments:
!
! pname - the parameter name;
! pvalue - the parameter value;
! status - the status flag (the success is 0, failure otherwise);
!
!===============================================================================
!
subroutine read_snapshot_parameter_string(pname, pvalue, status)
use iso_fortran_env, only : error_unit
implicit none
! subroutine arguments
!
character(len=*), intent(in) :: pname
character(len=*), intent(inout) :: pvalue
integer , intent(inout) :: status
! local variables
!
logical :: test
character(len=255) :: dname, fname, line
integer(kind=4) :: lun = 103
integer :: l, u
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_snapshot_parameter_string'
!
!-------------------------------------------------------------------------------
!
status = 0
select case(restart_format)
#ifdef HDF5
case(snapshot_hdf5)
call read_snapshot_parameter_h5(pname, pvalue, status)
#endif /* HDF5 */
case default
! check if the snapshot directory and metafile exist
!
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 */
if (.not. test) then
write(error_unit,"('[',a,']: ',a)") trim(loc), &
trim(dname) // " does not exists!"
status = 121
return
end if
write(fname,"(a,'/metadata.xml')") trim(dname)
inquire(file = fname, exist = test)
if (.not. test) then
write(error_unit,"('[',a,']: ',a)") trim(loc), &
trim(fname) // " does not exists!"
status = 121
return
end if
! read requested parameter from the file
!
open(newunit = lun, file = fname, status = 'old')
10 read(lun, fmt = "(a)", end = 20) line
l = index(line, trim(adjustl(pname)))
if (l > 0) then
l = index(line, '>') + 1
u = index(line, '<', back = .true.) - 1
pvalue = trim(adjustl(line(l:u)))
end if
go to 10
20 close(lun)
end select
!-------------------------------------------------------------------------------
!
end subroutine read_snapshot_parameter_string
!
!===============================================================================
!
! subroutine READ_SNAPSHOT_PARAMETER_INTEGER:
! ------------------------------------------
!
! Subroutine reads an integer parameter from the restart snapshot.
!
! Arguments:
!
! pname - the parameter name;
! pvalue - the parameter value;
! status - the status flag (the success is 0, failure otherwise);
!
!===============================================================================
!
subroutine read_snapshot_parameter_integer(pname, pvalue, status)
use iso_fortran_env, only : error_unit
implicit none
! subroutine arguments
!
character(len=*), intent(in) :: pname
integer , intent(inout) :: pvalue
integer , intent(inout) :: status
! local variables
!
logical :: test
character(len=255) :: dname, fname, line, svalue
integer(kind=4) :: lun = 103
integer :: l, u
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_snapshot_parameter_integer'
!
!-------------------------------------------------------------------------------
!
status = 0
select case(restart_format)
#ifdef HDF5
case(snapshot_hdf5)
call read_snapshot_parameter_h5(pname, pvalue, status)
#endif /* HDF5 */
case default
! check if the snapshot directory and metafile exist
!
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 */
if (.not. test) then
write(error_unit,"('[',a,']: ',a)") trim(loc), &
trim(dname) // " does not exists!"
status = 121
return
end if
write(fname,"(a,'/metadata.xml')") trim(dname)
inquire(file = fname, exist = test)
if (.not. test) then
write(error_unit,"('[',a,']: ',a)") trim(loc), &
trim(fname) // " does not exists!"
status = 121
return
end if
! read parameter from the file
!
open(newunit = lun, file = fname, status = 'old')
10 read(lun, fmt = "(a)", end = 20) line
l = index(line, trim(adjustl(pname)))
if (l > 0) then
l = index(line, '>') + 1
u = index(line, '<', back = .true.) - 1
svalue = trim(adjustl(line(l:u)))
read(svalue, fmt = *) pvalue
end if
go to 10
20 close(lun)
end select
!-------------------------------------------------------------------------------
!
end subroutine read_snapshot_parameter_integer
!
!===============================================================================
!
! subroutine READ_SNAPSHOT_PARAMETER_DOUBLE:
! -----------------------------------------
!
! Subroutine reads a floating point parameter from the restart snapshot.
!
! Arguments:
!
! pname - the parameter name;
! pvalue - the parameter value;
! status - the status flag (the success is 0, failure otherwise);
!
!===============================================================================
!
subroutine read_snapshot_parameter_double(pname, pvalue, status)
use iso_fortran_env, only : error_unit
implicit none
! subroutine arguments
!
character(len=*), intent(in) :: pname
real(kind=8) , intent(inout) :: pvalue
integer , intent(inout) :: status
! local variables
!
logical :: test
character(len=255) :: dname, fname, line, svalue
integer(kind=4) :: lun = 103
integer :: l, u
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_snapshot_parameter_double'
!
!-------------------------------------------------------------------------------
!
status = 0
select case(restart_format)
#ifdef HDF5
case(snapshot_hdf5)
call read_snapshot_parameter_h5(pname, pvalue, status)
#endif /* HDF5 */
case default
! check if the snapshot directory and metafile exist
!
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 */
if (.not. test) then
write(error_unit,"('[',a,']: ',a)") trim(loc), &
trim(dname) // " does not exists!"
status = 121
return
end if
write(fname,"(a,'/metadata.xml')") trim(dname)
inquire(file = fname, exist = test)
if (.not. test) then
write(error_unit,"('[',a,']: ',a)") trim(loc), &
trim(fname) // " does not exists!"
status = 121
return
end if
! read parameter from the file
!
open(newunit = lun, file = fname, status = 'old')
10 read(lun, fmt = "(a)", end = 20) line
l = index(line, trim(adjustl(pname)))
if (l > 0) then
l = index(line, '>') + 1
u = index(line, '<', back = .true.) - 1
svalue = trim(adjustl(line(l:u)))
read(svalue, fmt = *) pvalue
end if
go to 10
20 close(lun)
end select
!-------------------------------------------------------------------------------
!
end subroutine read_snapshot_parameter_double
!
!===============================================================================
!
! 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
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, zmin, zmax
use evolution , only : step, time, dt, dtn, dte
use evolution , only : niterations, nrejections, errs
use forcing , only : nmodes, fcoefs, einj
use hash , only : xxh64
use iso_fortran_env, only : error_unit
#ifdef MPI
use mesh , only : redistribute_blocks
#endif /* MPI */
use mpitools , only : nprocs, nproc
use random , only : gentype, set_seeds
implicit none
integer, intent(out) :: status
! local variables
!
logical :: test
character(len=255) :: dname, fname, line, sname, svalue
integer :: il, iu, nl, nx, nm, nd, nv, i, j, k, l, n, p, nu
integer(kind=4) :: lndims, lnprocs, lnproc, lmblocks, lnleafs, llast_id
integer(kind=4) :: ldblocks, lncells, lnghosts, lnseeds, lnmodes
real(kind=8) :: deinj
! local pointers
!
type(block_meta), pointer :: pmeta
type(block_data), pointer :: pdata
! local variables
!
integer(kind=4) :: lun = 104
integer(kind=8) :: digest, bytes
! hash strings
!
character(len=16) :: hfield, hchild, hface, hedge, hcorner, hbound
character(len=16) :: hids, harray, hseed, hforce
! local arrays
!
integer(kind=4), dimension(:) , allocatable :: ids
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 */
integer(kind=8), dimension(:,:) , allocatable :: seeds
real(kind=8) , dimension(:,:,:) , allocatable :: bounds
real(kind=8) , dimension(:,:,:,:,:,:), allocatable :: arrays
! array of pointer used during job restart
!
type(pointer_meta), dimension(:), allocatable :: barray
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_restart_snapshot_xml()'
character(len=*), parameter :: fmt = "(a,a,'_',i6.6,'.',a)"
!
!-------------------------------------------------------------------------------
!
status = 0
! check if the snapshot directory exists
!
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 */
if (.not. test) then
write(*,*) trim(dname) // " does not exists!"
status = 121
return
end if
dname = trim(dname) // "/"
write(fname,"(a,'metadata.xml')") trim(dname)
inquire(file = fname, exist = test)
if (.not. test) then
write(*,*) trim(fname) // " does not exists!"
status = 121
return
end if
! read attributes from the metadata file
!
open(newunit = lun, file = fname, status = 'old')
10 read(lun, fmt = "(a)", end = 20) line
if (index(line, '<Attribute') > 0) then
il = index(line, 'name="')
if (il > 0) then
il = il + 6
iu = index(line(il:), '"') + il - 2
write(sname,*) line(il:iu)
il = index(line, '>') + 1
iu = index(line, '<', back = .true.) - 1
write(svalue,*) line(il:iu)
select case(trim(adjustl(sname)))
case('ndims')
read(svalue, fmt = *) lndims
case('nprocs')
read(svalue, fmt = *) lnprocs
case('nproc')
read(svalue, fmt = *) lnproc
case('mblocks')
read(svalue, fmt = *) lmblocks
case('dblocks')
read(svalue, fmt = *) ldblocks
case('nleafs')
read(svalue, fmt = *) lnleafs
case('last_id')
read(svalue, fmt = *) llast_id
case('ncells')
read(svalue, fmt = *) lncells
case('nghosts')
read(svalue, fmt = *) lnghosts
case('nseeds')
read(svalue, fmt = *) lnseeds
case('step')
read(svalue, fmt = *) step
case('isnap')
read(svalue, fmt = *) isnap
case('nvars')
read(svalue, fmt = *) nv
case('nmodes')
read(svalue, fmt = *) lnmodes
case('xmin')
read(svalue, fmt = *) xmin
case('xmax')
read(svalue, fmt = *) xmax
case('ymin')
read(svalue, fmt = *) ymin
case('ymax')
read(svalue, fmt = *) ymax
case('zmin')
read(svalue, fmt = *) zmin
case('zmax')
read(svalue, fmt = *) zmax
case('time')
read(svalue, fmt = *) time
case('dt')
read(svalue, fmt = *) dt
case('dtn')
read(svalue, fmt = *) dtn
case('dte')
read(svalue, fmt = *) dte
case('niterations')
read(svalue, fmt = *) niterations
case('nrejections')
read(svalue, fmt = *) nrejections
case('errs(1)')
read(svalue, fmt = *) errs(1)
case('errs(2)')
read(svalue, fmt = *) errs(2)
case('errs(3)')
read(svalue, fmt = *) errs(3)
case('fields')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hfield
case('children')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hchild
case('faces')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hface
case('edges')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hedge
case('corners')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hcorner
case('bounds')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hbound
case('forcing')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hforce
end select
end if
end if
go to 10
20 close(lun)
! check the number of dimensions
!
if (lndims /= NDIMS) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "The number of dimensions does not match!"
return
end if
! check the block dimensions
!
if (lncells /= ncells) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "The block dimensions do not match!"
return
end if
! allocate all metablocks
!
do l = 1, lmblocks
call append_metablock(pmeta, status)
end do
! check if the number of created metablocks is equal to lbmcloks
!
if (lmblocks /= get_mblocks()) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Number of metablocks does not match!"
end if
! set the last_id
!
call set_last_id(llast_id)
! get numbers of meta and data blocks
!
nx = llast_id
nm = lmblocks
! prepare and store metablocks
!
allocate(barray(nx), fields(nm,14), children(nm,nc), bounds(nm,3,2), &
#if NDIMS == 3
faces(nm,NDIMS,ns,ns,ns), &
edges(nm,NDIMS,ns,ns,ns), corners(nm,ns,ns,ns), &
#else /* NDIMS == 3 */
edges(nm,NDIMS,ns,ns), corners(nm,ns,ns), &
#endif /* NDIMS == 3 */
stat = status)
if (status == 0) then
fields(:,:) = -1
children(:,:) = -1
#if NDIMS == 3
faces(:,:,:,:,:) = -1
edges(:,:,:,:,:) = -1
corners(:,:,:,:) = -1
#else /* NDIMS == 3 */
edges(:,:,:,:) = -1
corners(:,:,:) = -1
#endif /* NDIMS == 3 */
bounds(:,:,:) = 0.0d+00
! read metablocks from binary files and check hashes
!
bytes = size(transfer(fields, [ 0_1 ]), kind=8)
write(fname,"(a,'metablock_fields.bin')") trim(dname)
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) fields
close(lun)
read(hfield, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(fields, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
write(fname,"(a,'metablock_children.bin')") trim(dname)
bytes = size(transfer(children, [ 0_1 ]), kind=8)
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) children
close(lun)
read(hchild, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(children, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
#if NDIMS == 3
bytes = size(transfer(faces, [ 0_1 ]), kind=8)
write(fname,"(a,'metablock_faces.bin')") trim(dname)
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) faces
close(lun)
read(hface, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(faces, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
#endif /* NDIMS == 3 */
bytes = size(transfer(edges, [ 0_1 ]), kind=8)
write(fname,"(a,'metablock_edges.bin')") trim(dname)
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) edges
close(lun)
read(hedge, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(edges, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
bytes = size(transfer(corners, [ 0_1 ]), kind=8)
write(fname,"(a,'metablock_corners.bin')") trim(dname)
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) corners
close(lun)
read(hcorner, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(corners, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
bytes = size(transfer(bounds, [ 0_1 ]), kind=8)
write(fname,"(a,'metablock_bounds.bin')") trim(dname)
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) bounds
close(lun)
read(hbound, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(bounds, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
! iterate over all meta blocks and restore their fields
!
l = 0
pmeta => list_meta
do while(associated(pmeta))
l = l + 1
barray(fields(l,1))%ptr => pmeta
call metablock_set_id (pmeta, fields(l, 1))
call metablock_set_process (pmeta, fields(l, 2))
call metablock_set_level (pmeta, fields(l, 3))
call metablock_set_configuration(pmeta, fields(l, 4))
call metablock_set_refinement (pmeta, fields(l, 5))
call metablock_set_position (pmeta, fields(l, 6:8))
call metablock_set_coordinates (pmeta, fields(l, 9:11))
call metablock_set_bounds (pmeta, bounds(l,1,1), bounds(l,1,2), &
bounds(l,2,1), bounds(l,2,2), &
bounds(l,3,1), bounds(l,3,2))
if (fields(l,12) == 1) call metablock_set_leaf(pmeta)
pmeta => pmeta%next
end do ! over all meta blocks
! iterate over all meta blocks and restore their pointers
!
l = 0
pmeta => list_meta
do while(associated(pmeta))
l = l + 1
if (fields(l,14) > 0) pmeta%parent => barray(fields(l,14))%ptr
do p = 1, nc
if (children(l,p) > 0) then
pmeta%child(p)%ptr => barray(children(l,p))%ptr
end if
end do ! p = 1, nc
#if NDIMS == 2
do j = 1, ns
do i = 1, ns
do n = 1, NDIMS
if (edges(l,n,i,j) > 0) &
pmeta%edges(i,j,n)%ptr => barray(edges(l,n,i,j))%ptr
end do ! NDIMS
if (corners(l,i,j) > 0) &
pmeta%corners(i,j)%ptr => barray(corners(l,i,j))%ptr
end do ! i = 1, ns
end do ! j = 1, ns
#endif /* NDIMS == 2 */
#if NDIMS == 3
do k = 1, ns
do j = 1, ns
do i = 1, ns
do n = 1, NDIMS
if (faces(l,n,i,j,k) > 0) &
pmeta%faces(i,j,k,n)%ptr => barray(faces(l,n,i,j,k))%ptr
if (edges(l,n,i,j,k) > 0) &
pmeta%edges(i,j,k,n)%ptr => barray(edges(l,n,i,j,k))%ptr
end do ! NDIMS
if (corners(l,i,j,k) > 0) &
pmeta%corners(i,j,k)%ptr => barray(corners(l,i,j,k))%ptr
end do ! i = 1, ns
end do ! j = 1, ns
end do ! k = 1, ns
#endif /* NDIMS == 3 */
pmeta => pmeta%next
end do ! over all meta blocks
if (allocated(fields)) deallocate(fields)
if (allocated(children)) deallocate(children)
if (allocated(bounds)) deallocate(bounds)
#if NDIMS == 3
if (allocated(faces)) deallocate(faces)
#endif /* NDIMS == 3 */
if (allocated(edges)) deallocate(edges)
if (allocated(corners)) deallocate(corners)
end if ! allocation
! check the number of forcing modes
!
if (lnmodes == nmodes) then
if (lnmodes > 0) then
bytes = size(transfer(fcoefs, [ 0_1 ]), kind=8)
write(fname,"(a,'forcing_coefficients.bin')") trim(dname)
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) fcoefs
close(lun)
read(hforce, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(fcoefs, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "The number of forcing modes does not match!"
end if
! if the number of processes is bigger after the restart than before
!
if (nprocs >= lnprocs) then
if (nproc < lnprocs) then
write(fname,fmt) trim(dname), "datablocks", nproc, "xml"
inquire(file = fname, exist = test)
if (.not. test) then
write(*,*) trim(fname) // " does not exists!"
status = 121
return
end if
! read attributes from the metadata file
!
open(newunit = lun, file = fname, status = 'old')
30 read(lun, fmt = "(a)", end = 40) line
if (index(line, '<Attribute') > 0) then
il = index(line, 'name="')
if (il > 0) then
il = il + 6
iu = index(line(il:), '"') + il - 2
write(sname,*) line(il:iu)
il = index(line, '>') + 1
iu = index(line, '<', back = .true.) - 1
write(svalue,*) line(il:iu)
select case(trim(adjustl(sname)))
case('dblocks')
read(svalue, fmt = *) nd
case('einj')
read(svalue, fmt = *) einj
case('ids')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hids
case('arrays')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) harray
case('seeds')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hseed
end select
end if
end if
go to 30
40 close(lun)
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 NDIMS == 3
allocate(ids(nd), arrays(nd,3,nv,nm,nm,nm), stat = status)
#else /* NDIMS == 3 */
allocate(ids(nd), arrays(nd,3,nv,nm,nm, 1), stat = status)
#endif /* NDIMS == 3 */
if (status == 0) then
bytes = size(transfer(ids, [ 0_1 ]), kind=8)
write(fname, fmt) trim(dname), "datablock_ids", nproc, "bin"
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) ids
close(lun)
read(hids, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(ids, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
bytes = size(transfer(arrays, [ 0_1 ]), kind=8)
write(fname, fmt) trim(dname), "datablock_arrays", nproc, "bin"
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) arrays
close(lun)
read(harray, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(arrays, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
do l = 1, nd
call append_datablock(pdata, status)
call link_blocks(barray(ids(l))%ptr, pdata)
if (lnghosts >= nghosts) then
#if NDIMS == 3
pdata%q (:,:,:,:) = arrays(l,1,:,il:iu,il:iu,il:iu)
pdata%u0(:,:,:,:) = arrays(l,2,:,il:iu,il:iu,il:iu)
pdata%u1(:,:,:,:) = arrays(l,3,:,il:iu,il:iu,il:iu)
#else /* NDIMS == 3 */
pdata%q (:,:,:,:) = arrays(l,1,:,il:iu,il:iu,:)
pdata%u0(:,:,:,:) = arrays(l,2,:,il:iu,il:iu,:)
pdata%u1(:,:,:,:) = arrays(l,3,:,il:iu,il:iu,:)
#endif /* NDIMS == 3 */
else
#if NDIMS == 3
pdata%q (:,il:iu,il:iu,il:iu) = arrays(l,1,:,:,:,:)
pdata%u0(:,il:iu,il:iu,il:iu) = arrays(l,2,:,:,:,:)
pdata%u1(:,il:iu,il:iu,il:iu) = arrays(l,3,:,:,:,:)
#else /* NDIMS == 3 */
pdata%q (:,il:iu,il:iu,:) = arrays(l,1,:,:,:,:)
pdata%u0(:,il:iu,il:iu,:) = arrays(l,2,:,:,:,:)
pdata%u1(:,il:iu,il:iu,:) = arrays(l,3,:,:,:,:)
#endif /* NDIMS == 3 */
end if
end do
if (allocated(ids)) deallocate(ids)
if (allocated(arrays)) deallocate(arrays)
end if ! allocation
! restore PRNG seeds
!
allocate(seeds(4,lnseeds), stat = status)
if (status == 0) then
bytes = size(transfer(seeds, [ 0_1 ]), kind=8)
write(fname, fmt) trim(dname), "random_seeds", nproc, "bin"
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) seeds
close(lun)
read(hseed, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(seeds, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
call set_seeds(lnseeds, seeds(:,:), .false.)
if (allocated(seeds)) deallocate(seeds)
end if ! allocation
else ! nproc < lnprocs
write(fname,fmt) trim(dname), "datablocks", 0, "xml"
inquire(file = fname, exist = test)
if (.not. test) then
write(*,*) trim(fname) // " does not exists!"
status = 121
return
end if
! read attributes from the metadata file
!
open(newunit = lun, file = fname, status = 'old')
50 read(lun, fmt = "(a)", end = 60) line
if (index(line, '<Attribute') > 0) then
il = index(line, 'name="')
if (il > 0) then
il = il + 6
iu = index(line(il:), '"') + il - 2
write(sname,*) line(il:iu)
il = index(line, '>') + 1
iu = index(line, '<', back = .true.) - 1
write(svalue,*) line(il:iu)
select case(trim(adjustl(sname)))
case('seeds')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hseed
end select
end if
end if
go to 50
60 close(lun)
! restore PRNG seeds for remaining processes
!
if (trim(gentype) == "same") then
allocate(seeds(4,lnseeds), stat = status)
if (status == 0) then
bytes = size(transfer(seeds, [ 0_1 ]), kind=8)
write(fname, fmt) trim(dname), "random_seeds", 0, "bin"
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) seeds
close(lun)
read(hseed, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(seeds, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
call set_seeds(lnseeds, seeds(:,:), .false.)
if (allocated(seeds)) deallocate(seeds)
end if ! allocation
end if ! gentype == "same"
end if ! nproc < nprocs
else ! nprocs < lnprocs
! divide files between processes
!
nl = 0
i = mod(lnprocs, nprocs)
j = lnprocs / nprocs
do p = 0, nprocs
k = 0
do n = 0, p
nl = k
if (n < i) then
nu = k + j
else
nu = k + j - 1
end if
k = nu + 1
end do
do n = nl, nu
call change_blocks_process(n, p)
end do
end do
k = 0
do n = 0, nproc
nl = k
if (n < i) then
nu = k + j
else
nu = k + j - 1
end if
k = nu + 1
end do
do n = nl, nu
write(fname,fmt) trim(dname), "datablocks", n, "xml"
inquire(file = fname, exist = test)
if (.not. test) then
write(*,*) trim(fname) // " does not exists!"
status = 121
return
end if
! read attributes from the metadata file
!
open(newunit = lun, file = fname, status = 'old')
70 read(lun, fmt = "(a)", end = 80) line
if (index(line, '<Attribute') > 0) then
il = index(line, 'name="')
if (il > 0) then
il = il + 6
iu = index(line(il:), '"') + il - 2
write(sname,*) line(il:iu)
il = index(line, '>') + 1
iu = index(line, '<', back = .true.) - 1
write(svalue,*) line(il:iu)
select case(trim(adjustl(sname)))
case('dblocks')
read(svalue, fmt = *) nd
case('einj')
read(svalue, fmt = *) deinj
case('ids')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hids
case('arrays')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) harray
case('seeds')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
read(line(il:iu), fmt = *) hseed
end select
end if
end if
go to 70
80 close(lun)
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 NDIMS == 3
allocate(ids(nd), arrays(nd,3,nv,nm,nm,nm), stat = status)
#else /* NDIMS == 3 */
allocate(ids(nd), arrays(nd,3,nv,nm,nm, 1), stat = status)
#endif /* NDIMS == 3 */
if (status == 0) then
bytes = size(transfer(ids, [ 0_1 ]), kind=8)
write(fname, fmt) trim(dname), "datablock_ids", n, "bin"
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) ids
close(lun)
read(hids, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(ids, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
bytes = size(transfer(arrays, [ 0_1 ]), kind=8)
write(fname, fmt) trim(dname), "datablock_arrays", n, "bin"
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) arrays
close(lun)
read(harray, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(arrays, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
do l = 1, nd
call append_datablock(pdata, status)
call link_blocks(barray(ids(l))%ptr, pdata)
if (lnghosts >= nghosts) then
#if NDIMS == 3
pdata%q (:,:,:,:) = arrays(l,1,:,il:iu,il:iu,il:iu)
pdata%u0(:,:,:,:) = arrays(l,2,:,il:iu,il:iu,il:iu)
pdata%u1(:,:,:,:) = arrays(l,3,:,il:iu,il:iu,il:iu)
#else /* NDIMS == 3 */
pdata%q (:,:,:,:) = arrays(l,1,:,il:iu,il:iu,:)
pdata%u0(:,:,:,:) = arrays(l,2,:,il:iu,il:iu,:)
pdata%u1(:,:,:,:) = arrays(l,3,:,il:iu,il:iu,:)
#endif /* NDIMS == 3 */
else
#if NDIMS == 3
pdata%q (:,il:iu,il:iu,il:iu) = arrays(l,1,:,:,:,:)
pdata%u0(:,il:iu,il:iu,il:iu) = arrays(l,2,:,:,:,:)
pdata%u1(:,il:iu,il:iu,il:iu) = arrays(l,3,:,:,:,:)
#else /* NDIMS == 3 */
pdata%q (:,il:iu,il:iu,:) = arrays(l,1,:,:,:,:)
pdata%u0(:,il:iu,il:iu,:) = arrays(l,2,:,:,:,:)
pdata%u1(:,il:iu,il:iu,:) = arrays(l,3,:,:,:,:)
#endif /* NDIMS == 3 */
end if
end do
if (allocated(ids)) deallocate(ids)
if (allocated(arrays)) deallocate(arrays)
end if ! allocation
end do ! n = nl, nu
! restore seeds
!
allocate(seeds(4,lnseeds), stat = status)
if (status == 0) then
bytes = size(transfer(seeds, [ 0_1 ]), kind=8)
write(fname, fmt) trim(dname), "random_seeds", nproc, "bin"
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream')
read(lun) seeds
close(lun)
read(hseed, fmt = "(1z16)") digest
if (digest /= xxh64(transfer(seeds, 1_1, bytes))) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "'" // trim(fname) // "' seems to be corrupted!"
end if
call set_seeds(lnseeds, seeds(:,:), .false.)
if (allocated(seeds)) deallocate(seeds)
end if ! allocation
end if ! nprocs >= lnprocs
if (allocated(barray)) deallocate(barray)
#ifdef MPI
! redistribute blocks between processors
!
call redistribute_blocks()
#endif /* MPI */
!-------------------------------------------------------------------------------
!
end subroutine read_restart_snapshot_xml
!
!===============================================================================
!
! subroutine WRITE_RESTART_SNAPSHOT_XML:
! -------------------------------------
!
! Subroutine saves 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:
!
! nrun - the snapshot number;
! status - the status flag to inform if subroutine succeeded or failed;
!
!===============================================================================
!
subroutine write_restart_snapshot_xml(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
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
use evolution , only : step, time, dt, dtn, dte, cfl, glm_alpha, errs
use evolution , only : atol, rtol, mrej, niterations, nrejections
use forcing , only : nmodes, fcoefs, einj
use iso_fortran_env, only : error_unit
use mpitools , only : nprocs, nproc
use parameters , only : get_parameter_file
use problems , only : problem_name
use random , only : gentype, nseeds, get_seeds
implicit none
! input and output arguments
!
integer, intent(in) :: nrun
integer, intent(out) :: status
! local variables
!
logical :: test
character(len=64) :: dname, fname
integer(kind=8) :: digest, bytes
integer(kind=4) :: lun = 103
integer :: nd, nl, nm, nx, i, j, l, n, p
#if NDIMS == 3
integer :: k
#endif /* NDIMS == 3 */
! local pointers
!
type(block_meta), pointer :: pmeta
type(block_data), pointer :: pdata
! local arrays
!
integer(kind=4), dimension(:) , allocatable :: ids
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 */
integer(kind=8), dimension(:,:) , allocatable :: seeds
real(kind=8) , dimension(:,:,:) , allocatable :: bounds
real(kind=8) , dimension(:,:,:,:,:,:), allocatable :: arrays
! local parameters
!
character(len=*), parameter :: loc = "IO::write_restart_snapshot_xml()"
character(len=*), parameter :: fmt = "(a,a,'_',i6.6,'.',a)"
!
!-------------------------------------------------------------------------------
!
status = 0
! create snapshot directory, if it does not exists
!
write(dname, "('restart-',i5.5)") nrun
#ifdef __INTEL_COMPILER
inquire(directory = dname, exist = test)
do while(.not. test)
if (.not. test) call system("mkdir -p " // trim(dname))
inquire(directory = dname, exist = test)
end do
#else /* __INTEL_COMPILER */
inquire(file = dname, exist = test)
do while(.not. test)
if (.not. test) call system("mkdir -p " // trim(dname))
inquire(file = dname, exist = test)
end do
#endif /* __INTEL_COMPILER */
dname = trim(dname) // "/"
! get numbers of meta and data blocks
!
nx = get_last_id()
nm = get_mblocks()
nd = get_dblocks()
nl = get_nleafs()
! only process 0 stores the metadata
!
if (nproc == 0) then
! copy the parameter file to the restart directory
!
call get_parameter_file(fname, status)
if (status == 0) then
call system("cp -a " // trim(fname) // " " // trim(dname))
else
write(error_unit,"('[',a,']: ',a)") trim(loc), &
"Cannot get the location of parameter file!"
return
end if
! store metadata (parameters and attributes)
!
write(fname,"(a,'metadata.xml')") trim(dname)
open(newunit = lun, file = fname, status = 'replace')
write(lun,"(a)") "<?xml version='1.0' encoding='utf-8'?>"
write(lun,"(a)") '<AMUNFile version="1.0" byte_order="LittleEndian">'
write(lun,"(a)") '<Problem>'
call write_attribute_xml(lun, "problem" , problem_name)
write(lun,"(a)") '</Problem>'
write(lun,"(a)") '<Parallelization>'
call write_attribute_xml(lun, "nprocs" , nprocs)
call write_attribute_xml(lun, "nproc" , nproc)
write(lun,"(a)") '</Parallelization>'
write(lun,"(a)") '<Physics>'
call write_attribute_xml(lun, "eqsys" , eqsys)
call write_attribute_xml(lun, "eos" , eos)
call write_attribute_xml(lun, "nvars" , nv)
write(lun,"(a)") '</Physics>'
write(lun,"(a)") '<Geometry>'
call write_attribute_xml(lun, "ndims" , NDIMS)
call write_attribute_xml(lun, "xblocks" , bdims(1))
call write_attribute_xml(lun, "yblocks" , bdims(2))
#if NDIMS == 3
call write_attribute_xml(lun, "zblocks" , bdims(3))
#endif /* NDIMS */
call write_attribute_xml(lun, "xmin" , xmin)
call write_attribute_xml(lun, "xmax" , xmax)
call write_attribute_xml(lun, "ymin" , ymin)
call write_attribute_xml(lun, "ymax" , ymax)
#if NDIMS == 3
call write_attribute_xml(lun, "zmin" , zmin)
call write_attribute_xml(lun, "zmax" , zmax)
#endif /* NDIMS */
write(lun,"(a)") '</Geometry>'
write(lun,"(a)") '<Mesh>'
call write_attribute_xml(lun, "minlev" , minlev)
call write_attribute_xml(lun, "maxlev" , maxlev)
call write_attribute_xml(lun, "ncells" , ncells)
call write_attribute_xml(lun, "nghosts" , nghosts)
call write_attribute_xml(lun, "bcells" , nn)
call write_attribute_xml(lun, "nchildren", nc)
call write_attribute_xml(lun, "mblocks" , nm)
call write_attribute_xml(lun, "nleafs" , nl)
call write_attribute_xml(lun, "last_id" , nx)
write(lun,"(a)") '</Mesh>'
write(lun,"(a)") '<Evolution>'
call write_attribute_xml(lun, "step" , step)
call write_attribute_xml(lun, "time" , time)
call write_attribute_xml(lun, "dt" , dt)
call write_attribute_xml(lun, "dtn" , dtn)
call write_attribute_xml(lun, "dte" , dte)
call write_attribute_xml(lun, "cfl" , cfl)
call write_attribute_xml(lun, "glm_alpha", glm_alpha)
call write_attribute_xml(lun, "absolute_tolerance", atol)
call write_attribute_xml(lun, "relative_tolerance", rtol)
call write_attribute_xml(lun, "maximum_rejections", mrej)
call write_attribute_xml(lun, "niterations", niterations)
call write_attribute_xml(lun, "nrejections", nrejections)
call write_attribute_xml(lun, "errs(1)", errs(1))
call write_attribute_xml(lun, "errs(2)", errs(2))
call write_attribute_xml(lun, "errs(3)", errs(3))
write(lun,"(a)") '</Evolution>'
write(lun,"(a)") '<Forcing>'
call write_attribute_xml(lun, "nmodes" , nmodes)
write(lun,"(a)") '</Forcing>'
write(lun,"(a)") '<Random>'
call write_attribute_xml(lun, "gentype" , gentype)
call write_attribute_xml(lun, "nseeds" , nseeds)
write(lun,"(a)") '</Random>'
write(lun,"(a)") '<Snapshots>'
call write_attribute_xml(lun, "isnap" , isnap)
write(lun,"(a)") '</Snapshots>'
write(lun,"(a)") '<BinaryFiles>'
! prepare and store metablocks
!
allocate(fields(nm,14), children(nm,nc), bounds(nm,3,2), &
#if NDIMS == 3
faces(nm,NDIMS,ns,ns,ns), &
edges(nm,NDIMS,ns,ns,ns), corners(nm,ns,ns,ns), &
#else /* NDIMS == 3 */
edges(nm,NDIMS,ns,ns), corners(nm,ns,ns), &
#endif /* NDIMS == 3 */
stat = status)
if (status == 0) then
fields(:,:) = -1
children(:,:) = -1
#if NDIMS == 3
faces(:,:,:,:,:) = -1
edges(:,:,:,:,:) = -1
corners(:,:,:,:) = -1
#else /* NDIMS == 3 */
edges(:,:,:,:) = -1
corners(:,:,:) = -1
#endif /* NDIMS == 3 */
bounds(:,:,:) = 0.0d+00
l = 0
pmeta => list_meta
do while(associated(pmeta))
l = l + 1
fields(l, 1) = pmeta%id
fields(l, 2) = pmeta%process
fields(l, 3) = pmeta%level
fields(l, 4) = pmeta%conf
fields(l, 5) = pmeta%refine
fields(l, 6) = pmeta%pos(1)
fields(l, 7) = pmeta%pos(2)
#if NDIMS == 3
fields(l, 8) = pmeta%pos(3)
#endif /* NDIMS == 3 */
fields(l, 9) = pmeta%coords(1)
fields(l,10) = pmeta%coords(2)
#if NDIMS == 3
fields(l,11) = pmeta%coords(3)
#endif /* NDIMS == 3 */
if (pmeta%leaf) fields(l,12) = 1
if (associated(pmeta%data) ) fields(l,13) = 1
if (associated(pmeta%parent)) fields(l,14) = pmeta%parent%id
do p = 1, nc
if (associated(pmeta%child(p)%ptr)) &
children(l,p) = 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(l,n,i,j) = pmeta%edges(i,j,n)%ptr%id
end do ! NDIMS
if (associated(pmeta%corners(i,j)%ptr)) &
corners(l,i,j) = pmeta%corners(i,j)%ptr%id
end do ! i = 1, ns
end do ! j = 1, ns
#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(l,n,i,j,k) = pmeta%faces(i,j,k,n)%ptr%id
if (associated(pmeta%edges(i,j,k,n)%ptr)) &
edges(l,n,i,j,k) = pmeta%edges(i,j,k,n)%ptr%id
end do ! NDIMS
if (associated(pmeta%corners(i,j,k)%ptr)) &
corners(l,i,j,k) = pmeta%corners(i,j,k)%ptr%id
end do ! i = 1, ns
end do ! j = 1, ns
end do ! k = 1, ns
#endif /* NDIMS == 3 */
bounds(l,1,1) = pmeta%xmin
bounds(l,1,2) = pmeta%xmax
bounds(l,2,1) = pmeta%ymin
bounds(l,2,2) = pmeta%ymax
#if NDIMS == 3
bounds(l,3,1) = pmeta%zmin
bounds(l,3,2) = pmeta%zmax
#endif /* NDIMS == 3 */
pmeta => pmeta%next
end do ! metablocks
! store metablock data
!
write(fname,"(a,'.bin')") "metablock_fields"
call write_binary_xml(trim(dname), trim(fname), &
transfer(fields, [ 0_1 ]), bytes, digest)
call write_attribute_xml(lun, "fields", trim(fname), bytes, digest)
write(fname,"(a,'.bin')") "metablock_children"
call write_binary_xml(trim(dname), trim(fname), &
transfer(children, [ 0_1 ]), bytes, digest)
call write_attribute_xml(lun, "children", trim(fname), bytes, digest)
#if NDIMS == 3
write(fname,"(a,'.bin')") "metablock_faces"
call write_binary_xml(trim(dname), trim(fname), &
transfer(faces, [ 0_1 ]), bytes, digest)
call write_attribute_xml(lun, "faces", trim(fname), bytes, digest)
#endif /* NDIMS == 3 */
write(fname,"(a,'.bin')") "metablock_edges"
call write_binary_xml(trim(dname), trim(fname), &
transfer(edges, [ 0_1 ]), bytes, digest)
call write_attribute_xml(lun, "edges", trim(fname), bytes, digest)
write(fname,"(a,'.bin')") "metablock_corners"
call write_binary_xml(trim(dname), trim(fname), &
transfer(corners, [ 0_1 ]), bytes, digest)
call write_attribute_xml(lun, "corners", trim(fname), bytes, digest)
write(fname,"(a,'.bin')") "metablock_bounds"
call write_binary_xml(trim(dname), trim(fname), &
transfer(bounds, [ 0_1 ]), bytes, digest)
call write_attribute_xml(lun, "bounds", trim(fname), bytes, digest)
if (nmodes > 0) then
write(fname,"(a,'.bin')") "forcing_coefficients"
call write_binary_xml(trim(dname), trim(fname), &
transfer(fcoefs, [ 0_1 ]), bytes, digest)
call write_attribute_xml(lun, "forcing", trim(fname), bytes, digest)
end if
if (allocated(fields)) deallocate(fields)
if (allocated(children)) deallocate(children)
if (allocated(bounds)) deallocate(bounds)
#if NDIMS == 3
if (allocated(faces)) deallocate(faces)
#endif /* NDIMS == 3 */
if (allocated(edges)) deallocate(edges)
if (allocated(corners)) deallocate(corners)
else
write(error_unit,"('[',a,']: ',a)") trim(loc), &
"Cannot allocate space for metablocks!"
status = 1001
return
end if ! allocation
#if NDIMS == 3
#endif /* NDIMS == 3 */
write(lun,"(a)") '</BinaryFiles>'
write(lun,"(a)") '</AMUNFile>'
close(lun)
end if ! meta data file is stored only on the master process
! prepare and store data block info
!
write(fname,fmt) trim(dname), "datablocks", nproc, "xml"
open(newunit = lun, file = fname, status = 'replace')
write(lun,"(a)") "<?xml version='1.0' encoding='utf-8'?>"
write(lun,"(a)") '<AMUNFile version="1.0" byte_order="LittleEndian">'
write(lun,"(a)") '<DataBlocks>'
call write_attribute_xml(lun, "nprocs" , nprocs)
call write_attribute_xml(lun, "nproc" , nproc)
call write_attribute_xml(lun, "ndims" , NDIMS)
call write_attribute_xml(lun, "ncells" , ncells)
call write_attribute_xml(lun, "nghosts", nghosts)
call write_attribute_xml(lun, "bcells" , nn)
call write_attribute_xml(lun, "dblocks", nd)
write(lun,"(a)") '</DataBlocks>'
write(lun,"(a)") '<Forcing>'
call write_attribute_xml(lun, "einj" , einj)
write(lun,"(a)") '</Forcing>'
write(lun,"(a)") '<Random>'
call write_attribute_xml(lun, "gentype", gentype)
call write_attribute_xml(lun, "nseeds" , nseeds)
write(lun,"(a)") '</Random>'
write(lun,"(a)") '<BinaryFiles>'
if (nd > 0) then
#if NDIMS == 3
allocate(ids(nd), arrays(nd,3,nv,nn,nn,nn), stat = status)
#else /* NDIMS == 3 */
allocate(ids(nd), arrays(nd,3,nv,nn,nn, 1), stat = status)
#endif /* NDIMS == 3 */
if (status == 0) then
arrays = 0.0d+00
l = 0
pdata => list_data
do while(associated(pdata))
l = l + 1
ids(l) = pdata%meta%id
arrays(l,1,:,:,:,:) = pdata%q (:,:,:,:)
arrays(l,2,:,:,:,:) = pdata%u0(:,:,:,:)
arrays(l,3,:,:,:,:) = pdata%u1(:,:,:,:)
pdata => pdata%next
end do ! data blocks
! store block IDs and arrays
!
write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "ids", nproc
call write_binary_xml(trim(dname), trim(fname), &
transfer(ids, [ 0_1 ]), bytes, digest)
call write_attribute_xml(lun, "ids", trim(fname), bytes, digest)
write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "arrays", nproc
call write_binary_xml(trim(dname), trim(fname), &
transfer(arrays, [ 0_1 ]), bytes, digest)
call write_attribute_xml(lun, "arrays", trim(fname), bytes, digest)
if (allocated(ids)) deallocate(ids)
if (allocated(arrays)) deallocate(arrays)
else
write(error_unit,"('[',a,']: ',a)") trim(loc), &
"Cannot allocate space for datablocks!"
status = 1001
return
end if ! allocation
end if
! store PRNG seeds
!
allocate(seeds(4,nseeds), stat = status)
if (status == 0) then
call get_seeds(seeds(:,:))
! store seeds
!
write(fname,"(a,'_',a,'_',i6.6,'.bin')") "random", "seeds", nproc
call write_binary_xml(trim(dname), trim(fname), &
transfer(seeds, [ 0_1 ]), bytes, digest)
call write_attribute_xml(lun, "seeds", trim(fname), bytes, digest)
if (allocated(seeds)) deallocate(seeds)
else
write(error_unit,"('[',a,']: ',a)") trim(loc), &
"Cannot allocate space for random generator seeds!"
status = 1001
return
end if
write(lun,"(a)") '</BinaryFiles>'
write(lun,"(a)") '</AMUNFile>'
close(lun)
!-------------------------------------------------------------------------------
!
end subroutine write_restart_snapshot_xml
!
!===============================================================================
!
! subroutine WRITE_SNAPSHOT_XML:
! -----------------------------
!
! Subroutine saves 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:
!
! status - the status flag to inform if subroutine succeeded or failed;
!
!===============================================================================
!
subroutine write_snapshot_xml(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 iso_fortran_env, only : error_unit
use mpitools , only : nprocs, nproc
use parameters , only : get_parameter_file
use problems , only : problem_name
use sources , only : viscosity, resistivity
implicit none
! input and output arguments
!
integer, intent(out) :: status
! local variables
!
logical :: test
character(len=64) :: dname, fname
character(len=256) :: vars
integer(kind=8) :: dbytes = 0_8, ddigest = 0_8
integer(kind=8) :: cbytes = 0_8, cdigest = 0_8
integer(kind=4) :: lun = 103
integer :: nd, nl, l, p
! local pointers
!
type(block_meta), pointer :: pmeta
type(block_data), pointer :: pdata
! local arrays
!
integer(kind=4), dimension(:) , allocatable :: ids
integer(kind=4), dimension(:,:) , allocatable :: fields
real(kind=8) , dimension(:,:,:) , allocatable :: bounds
real(kind=8) , dimension(:,:,:,:,:), allocatable :: arrays
! local parameters
!
character(len=*), parameter :: loc = "IO::write_snapshot_xml()"
character(len=*), parameter :: fmt = "(a,a,'_',i6.6,'.',a)"
!
!-------------------------------------------------------------------------------
!
status = 0
! create snapshot directory, if it does not exists
!
write(dname, "('snapshot-',i9.9)") isnap
#ifdef __INTEL_COMPILER
inquire(directory = dname, exist = test)
do while(.not. test)
if (.not. test) call system("mkdir -p " // trim(dname))
inquire(directory = dname, exist = test)
end do
#else /* __INTEL_COMPILER */
inquire(file = dname, exist = test)
do while(.not. test)
if (.not. test) call system("mkdir -p " // trim(dname))
inquire(file = dname, exist = test)
end do
#endif /* __INTEL_COMPILER */
dname = trim(dname) // "/"
! get numbers of meta and data blocks, leafs, and prepare stored variables
!
nd = get_dblocks()
nl = get_nleafs()
vars = ""
do l = 1, nv
vars = trim(vars) // " " // trim(pvars(l))
end do
! only process 0 stores the metadata
!
if (nproc == 0) then
! copy the parameter file to the restart directory
!
call get_parameter_file(fname, status)
if (status == 0) then
call system("cp -a " // trim(fname) // " " // trim(dname))
else
write(error_unit,"('[',a,']: ',a)") trim(loc), &
"Cannot get the location of parameter file!"
return
end if
! store metadata (parameters and attributes)
!
write(fname,"(a,'metadata.xml')") trim(dname)
open(newunit = lun, file = fname, status = 'replace')
write(lun,"(a)") "<?xml version='1.0' encoding='utf-8'?>"
write(lun,"(a)") '<AMUNFile version="1.0" byte_order="LittleEndian">'
write(lun,"(a)") '<Problem>'
call write_attribute_xml(lun, "problem" , problem_name)
write(lun,"(a)") '</Problem>'
write(lun,"(a)") '<Parallelization>'
call write_attribute_xml(lun, "nprocs" , nprocs)
call write_attribute_xml(lun, "nproc" , nproc)
write(lun,"(a)") '</Parallelization>'
write(lun,"(a)") '<Physics>'
call write_attribute_xml(lun, "eqsys" , eqsys)
call write_attribute_xml(lun, "eos" , eos)
call write_attribute_xml(lun, "nvars" , nv)
call write_attribute_xml(lun, "adiabatic_index", adiabatic_index)
call write_attribute_xml(lun, "sound_speed" , csnd)
call write_attribute_xml(lun, "viscosity" , viscosity)
call write_attribute_xml(lun, "resistivity" , resistivity)
write(lun,"(a)") '</Physics>'
write(lun,"(a)") '<Geometry>'
call write_attribute_xml(lun, "ndims" , NDIMS)
call write_attribute_xml(lun, "xblocks" , bdims(1))
call write_attribute_xml(lun, "yblocks" , bdims(2))
#if NDIMS == 3
call write_attribute_xml(lun, "zblocks" , bdims(3))
#endif /* NDIMS */
call write_attribute_xml(lun, "xmin" , xmin)
call write_attribute_xml(lun, "xmax" , xmax)
call write_attribute_xml(lun, "ymin" , ymin)
call write_attribute_xml(lun, "ymax" , ymax)
#if NDIMS == 3
call write_attribute_xml(lun, "zmin" , zmin)
call write_attribute_xml(lun, "zmax" , zmax)
#endif /* NDIMS */
write(lun,"(a)") '</Geometry>'
write(lun,"(a)") '<Mesh>'
call write_attribute_xml(lun, "minlev" , minlev)
call write_attribute_xml(lun, "maxlev" , maxlev)
call write_attribute_xml(lun, "ncells" , ncells)
call write_attribute_xml(lun, "nghosts" , nghosts)
call write_attribute_xml(lun, "bcells" , nn)
call write_attribute_xml(lun, "nleafs" , nl)
write(lun,"(a)") '</Mesh>'
write(lun,"(a)") '<Evolution>'
call write_attribute_xml(lun, "step" , step)
call write_attribute_xml(lun, "time" , time)
call write_attribute_xml(lun, "dt" , dt)
call write_attribute_xml(lun, "cfl" , cfl)
call write_attribute_xml(lun, "glm_alpha", glm_alpha)
write(lun,"(a)") '</Evolution>'
write(lun,"(a)") '<Snapshots>'
call write_attribute_xml(lun, "isnap" , isnap)
call write_attribute_xml(lun, "variables", trim(vars))
write(lun,"(a)") '</Snapshots>'
write(lun,"(a)") '<BinaryFiles>'
! prepare and store metablocks
!
allocate(fields(nl,5), bounds(nl,3,2), 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(l,1) = pmeta%id
fields(l,2) = pmeta%level
fields(l,3) = pmeta%coords(1)
fields(l,4) = pmeta%coords(2)
#if NDIMS == 3
fields(l,5) = pmeta%coords(3)
#endif /* NDIMS == 3 */
bounds(l,1,1) = pmeta%xmin
bounds(l,1,2) = pmeta%xmax
bounds(l,2,1) = pmeta%ymin
bounds(l,2,2) = pmeta%ymax
#if NDIMS == 3
bounds(l,3,1) = pmeta%zmin
bounds(l,3,2) = pmeta%zmax
#endif /* NDIMS == 3 */
end if ! leaf
pmeta => pmeta%next
end do ! metablocks
! store metablock data
!
write(fname,"(a,a)") "metablock_fields", trim(binary_file_suffix)
call write_binary_xml(trim(dname), trim(fname), &
transfer(fields, [ 0_1 ]), &
dbytes, ddigest, cbytes, cdigest)
call write_attribute_xml(lun, "fields", trim(fname), &
dbytes, ddigest, cbytes, cdigest)
write(fname,"(a,a)") "metablock_bounds", trim(binary_file_suffix)
call write_binary_xml(trim(dname), trim(fname), &
transfer(bounds, [ 0_1 ]), &
dbytes, ddigest, cbytes, cdigest)
call write_attribute_xml(lun, "bounds", trim(fname), &
dbytes, ddigest, cbytes, cdigest)
if (allocated(fields)) deallocate(fields)
if (allocated(bounds)) deallocate(bounds)
else
write(error_unit,"('[',a,']: ',a)") trim(loc), &
"Cannot allocate space for metablocks!"
status = 1001
return
end if ! allocation
write(lun,"(a)") '</BinaryFiles>'
write(lun,"(a)") '</AMUNFile>'
close(lun)
end if ! meta data file is stored only on the master process
! prepare and store data block info
!
write(fname,fmt) trim(dname), "datablocks", nproc, "xml"
open(newunit = lun, file = fname, status = 'replace')
write(lun,"(a)") "<?xml version='1.0' encoding='utf-8'?>"
write(lun,"(a)") '<AMUNFile version="1.0" byte_order="LittleEndian">'
write(lun,"(a)") '<DataBlocks>'
call write_attribute_xml(lun, "nprocs" , nprocs)
call write_attribute_xml(lun, "nproc" , nproc)
call write_attribute_xml(lun, "ndims" , NDIMS)
call write_attribute_xml(lun, "ncells" , ncells)
call write_attribute_xml(lun, "nghosts" , nghosts)
call write_attribute_xml(lun, "bcells" , nn)
call write_attribute_xml(lun, "nvars" , nv)
call write_attribute_xml(lun, "dblocks" , nd)
call write_attribute_xml(lun, "variables", trim(vars))
write(lun,"(a)") '</DataBlocks>'
write(lun,"(a)") '<BinaryFiles>'
if (nd > 0) then
#if NDIMS == 3
allocate(ids(nd), arrays(nv,nd,nn,nn,nn), stat = status)
#else /* NDIMS == 3 */
allocate(ids(nd), arrays(nv,nd,nn,nn, 1), 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
arrays(:,l,:,:,:) = pdata%q(:,:,:,:)
pdata => pdata%next
end do ! data blocks
write(fname,"(a,'_',a,'_',i6.6,a)") "datablock", "ids", &
nproc, trim(binary_file_suffix)
call write_binary_xml(trim(dname), trim(fname), &
transfer(ids, [ 0_1 ]), &
dbytes, ddigest, cbytes, cdigest)
call write_attribute_xml(lun, "ids", trim(fname), &
dbytes, ddigest, cbytes, cdigest)
do p = 1, nv
write(fname,"(a,'_',a,'_',i6.6,a)") "datablock", trim(pvars(p)), &
nproc, trim(binary_file_suffix)
call write_binary_xml(trim(dname), trim(fname), &
transfer(arrays(p,:,:,:,:), [ 0_1 ]), &
dbytes, ddigest, cbytes, cdigest)
call write_attribute_xml(lun, trim(pvars(p)), trim(fname), &
dbytes, ddigest, cbytes, cdigest)
end do
if (allocated(ids)) deallocate(ids)
if (allocated(arrays)) deallocate(arrays)
else
write(error_unit,"('[',a,']: ',a)") trim(loc), &
"Cannot allocate space for datablocks!"
status = 1001
return
end if ! allocation
end if
write(lun,"(a)") '</BinaryFiles>'
write(lun,"(a)") '</AMUNFile>'
close(lun)
!-------------------------------------------------------------------------------
!
end subroutine write_snapshot_xml
!
!===============================================================================
!
! subroutine WRITE_ATTRIBUTE_XML_STRING:
! -------------------------------------
!
! Subroutine writes a string attribute in XML format to specified
! file handler.
!
! Arguments:
!
! lun - the file handler to write to;
! aname - the name of attribute;
! avalue - the value of attribute;
!
!===============================================================================
!
subroutine write_attribute_xml_string(lun, aname, avalue)
implicit none
! input and output arguments
!
integer , intent(in) :: lun
character(len=*), intent(in) :: aname
character(len=*), intent(in) :: avalue
! local parameters
!
character(len=*), parameter :: afmt = "('<Attribute type=" // '"' // &
"',a,'" // '"' // " name=" // '"' // "',a,'" // '"' // &
">',a,'</Attribute>')"
!
!-------------------------------------------------------------------------------
!
write(lun,afmt) "string", trim(adjustl(aname)), trim(adjustl(avalue))
!-------------------------------------------------------------------------------
!
end subroutine write_attribute_xml_string
!
!===============================================================================
!
! subroutine WRITE_ATTRIBUTE_XML_INTEGER:
! --------------------------------------
!
! Subroutine writes an integer attribute in XML format to specified
! file handler.
!
! Arguments:
!
! lun - the file handler to write to;
! aname - the name of attribute;
! avalue - the value of attribute;
!
!===============================================================================
!
subroutine write_attribute_xml_integer(lun, aname, avalue)
implicit none
! input and output arguments
!
integer , intent(in) :: lun
character(len=*), intent(in) :: aname
integer(kind=4) , intent(in) :: avalue
! local variables
!
character(len=32) :: svalue
! local parameters
!
character(len=*), parameter :: afmt = "('<Attribute type=" // '"' // &
"',a,'" // '"' // " name=" // '"' // "',a,'" // '"' // &
">',a,'</Attribute>')"
!
!-------------------------------------------------------------------------------
!
write(svalue,"(1i32)") avalue
write(lun,afmt) "integer", trim(adjustl(aname)), trim(adjustl(svalue))
!-------------------------------------------------------------------------------
!
end subroutine write_attribute_xml_integer
!
!===============================================================================
!
! subroutine WRITE_ATTRIBUTE_XML_DOUBLE:
! --------------------------------------
!
! Subroutine writes a double precision attribute in XML format to specified
! file handler.
!
! Arguments:
!
! lun - the file handler to write to;
! aname - the name of attribute;
! avalue - the value of attribute;
!
!===============================================================================
!
subroutine write_attribute_xml_double(lun, aname, avalue)
implicit none
! input and output arguments
!
integer , intent(in) :: lun
character(len=*), intent(in) :: aname
real(kind=8) , intent(in) :: avalue
! local variables
!
character(len=32) :: svalue
! local parameters
!
character(len=*), parameter :: afmt = "('<Attribute type=" // '"' // &
"',a,'" // '"' // " name=" // '"' // "',a,'" // '"' // &
">',a,'</Attribute>')"
!
!-------------------------------------------------------------------------------
!
write(svalue,"(1es32.20)") avalue
write(lun,afmt) "double", trim(adjustl(aname)), trim(adjustl(svalue))
!-------------------------------------------------------------------------------
!
end subroutine write_attribute_xml_double
!
!===============================================================================
!
! subroutine WRITE_ATTRIBUTE_XML_FILE:
! -----------------------------------
!
! Subroutine writes a file attribute in XML format to specified file handler.
!
! Arguments:
!
! lun - the file handler to write to;
! aname - the file attribute name;
! filename - the file name;
! data_bytes - the file size in bytes;
! data_digest - the digest of the file content;
! compressed_bytes - the size of the compressed data in bytes;
! compressed_digest - the digest of the compressed data;
!
!===============================================================================
!
subroutine write_attribute_xml_file(lun, aname, filename, &
data_bytes, data_digest, &
compressed_bytes, compressed_digest)
implicit none
! input and output arguments
!
integer , intent(in) :: lun
character(len=*) , intent(in) :: aname, filename
integer(kind=8) , intent(in) :: data_bytes, data_digest
integer(kind=8) , optional, intent(in) :: compressed_bytes, compressed_digest
! local variables
!
character(len=256) :: fname
character(len=32) :: digest_string, bytes_string
character(len=1024) :: string
integer :: l
!
!-------------------------------------------------------------------------------
!
fname = filename
string = '<Attribute type="string" name="' // trim(adjustl(aname)) // '"'
write(bytes_string,"(1i32)") data_bytes
string = trim(string) // ' size="' // trim(adjustl(bytes_string)) // '"'
string = trim(string) // ' digest_type="xxh64"'
write(digest_string,"(1z0.16)") data_digest
string = trim(string) // ' digest="' // trim(adjustl(digest_string)) // '"'
if (present(compressed_bytes)) then
if (compressed_bytes > 0) then
write(bytes_string,"(1i32)") compressed_bytes
string = trim(string) // &
' compression_format="' // trim(adjustl(cformat)) // '"' // &
' compressed_size="' // trim(adjustl(bytes_string)) // '"'
if (present(compressed_digest)) then
if (compressed_digest /= 0) then
write(digest_string,"(1z0.16)") compressed_digest
string = trim(string) // ' compressed_digest="' // &
trim(adjustl(digest_string)) // '"'
end if
end if
else
l = index(fname, '.bin') + 3
fname = filename(1:l)
end if
end if
string = trim(string) // '>' // trim(adjustl(fname)) // '</Attribute>'
write(lun,'(a)') trim(adjustl(string))
!-------------------------------------------------------------------------------
!
end subroutine write_attribute_xml_file
!
!===============================================================================
!
! subroutine WRITE_BINARY_XML:
! ---------------------------
!
! Subroutine writes the input array of bytes in a binary file with
! the provided path and name, and returns the digest of written data.
!
! Arguments:
!
! path, name - the path and name where the array should be written to;
! array - the array of bytes to be written;
! array_bytes - the size of the array in bytes;
! array_digest - the digest of the input array;
! compressed_bytes - the size of the compressed array in bytes;
! compressed_digest - the digest of the compressed array;
!
!===============================================================================
!
subroutine write_binary_xml(path, name, array, array_bytes, array_digest, &
compressed_bytes, compressed_digest)
use compression, only : get_compression, compress
use hash , only : xxh64
implicit none
! input and output arguments
!
character(len=*) , intent(in) :: path, name
integer(kind=1), dimension(:), intent(in) :: array
integer(kind=8), optional , intent(out) :: array_bytes, compressed_bytes
integer(kind=8), optional , intent(out) :: array_digest, compressed_digest
! local variables
!
character(len=512) :: fname
integer :: lun = 123
logical :: written
integer :: l, status
! compression buffer
!
integer(kind=1), dimension(:), allocatable :: buffer
!
!-------------------------------------------------------------------------------
!
status = 0
written = .false.
array_bytes = size(array, kind=8)
if (present(array_digest)) array_digest = xxh64(array)
write(fname,"(a,'/',a)") trim(path), trim(name)
! try to compress array and write it
!
if (present(compressed_bytes) .and. get_compression() > 0) then
allocate(buffer(array_bytes), stat = status)
if (status == 0) then
call compress(array, buffer, compressed_bytes)
if (compressed_bytes > 0) then
open(newunit = lun, file = fname, form = 'unformatted', &
access = 'stream', status = 'replace')
write(lun) buffer(1:compressed_bytes)
close(lun)
written = .true.
if (present(compressed_digest)) &
compressed_digest = xxh64(buffer(1:compressed_bytes))
end if
deallocate(buffer)
end if
end if
! compression failed of no compression is used, so writhe the uncompressed array
!
if (.not. written) then
l = index(fname, '.bin') + 3
open(newunit = lun, file = fname(:l), form = 'unformatted', &
access = 'stream', status = 'replace')
write(lun) array
close(lun)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_binary_xml
#ifdef HDF5
!
!===============================================================================
!
! subroutine READ_SNAPSHOT_PARAMETER_STRING_H5:
! --------------------------------------------
!
! Subroutine reads a string parameter from the restart snapshot.
!
! Arguments:
!
! pname - the parameter name;
! pvalue - the parameter value;
! iret - the success flag (the success is 0, failure otherwise);
!
!===============================================================================
!
subroutine read_snapshot_parameter_string_h5(pname, pvalue, iret)
! import external procedures
!
use hdf5 , only : hid_t
use hdf5 , only : H5F_ACC_RDONLY_F
use hdf5 , only : H5T_NATIVE_CHARACTER
use hdf5 , only : hid_t, hsize_t, size_t
use hdf5 , only : h5fopen_f, h5fclose_f
use hdf5 , only : h5gopen_f, h5gclose_f
use hdf5 , only : h5aexists_by_name_f
use hdf5 , only : h5tcopy_f, h5tset_size_f
use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f
use iso_fortran_env, only : error_unit
use mpitools , only : nproc
use parameters , only : get_parameter
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
character(len=*), intent(in) :: pname
character(len=*), intent(inout) :: pvalue
integer , intent(inout) :: iret
! local variables
!
logical :: info
character(len=255) :: rname
integer :: np
integer(hid_t) :: fid, gid, tid, aid
integer(size_t) :: aln
integer(hsize_t) :: am(1) = 1
! local parameters
!
character(len=*), parameter :: loc = &
'IO::read_snapshot_parameter_string_h5()'
!
!-------------------------------------------------------------------------------
!
! reset the success flag
!
iret = 0
! generate the filename of the restart snapshot
!
info = .false.
np = nproc + 1
do while (.not. info .and. np >= 0)
np = np - 1
write (rname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, np
inquire(file = rname, exist = info)
end do
! procees if file exists
!
if (info) then
call h5fopen_f(rname, H5F_ACC_RDONLY_F, fid, iret)
if (iret >= 0) then
call h5gopen_f(fid, 'attributes', gid, iret)
if (iret >= 0) then
call h5aexists_by_name_f(gid, '.', trim(pname), info, iret)
if (info .and. iret >= 0) then
call h5aopen_by_name_f(gid, '.', trim(pname), aid, iret)
if (iret >= 0) then
aln = len(pvalue)
call h5tcopy_f(H5T_NATIVE_CHARACTER, tid, iret)
call h5tset_size_f(tid, aln, iret)
call h5aread_f(aid, tid, pvalue, am(:), iret)
call h5aclose_f(aid, iret)
end if
end if
call h5gclose_f(gid, iret)
end if
call h5fclose_f(fid, iret)
end if
else
write(error_unit,"('[', a, ']: ', a)") trim(loc) &
, "Snapshot " // trim(rname) // " file does not exist!"
iret = 1
end if
!-------------------------------------------------------------------------------
!
end subroutine read_snapshot_parameter_string_h5
!
!===============================================================================
!
! subroutine READ_SNAPSHOT_PARAMETER_INTEGER_H5:
! ---------------------------------------------
!
! Subroutine reads an integer parameter from the restart snapshot.
!
! Arguments:
!
! pname - the parameter name;
! pvalue - the parameter value;
! iret - the success flag (the success is 0, failure otherwise);
!
!===============================================================================
!
subroutine read_snapshot_parameter_integer_h5(pname, pvalue, iret)
! import external procedures
!
use hdf5 , only : hid_t
use hdf5 , only : H5F_ACC_RDONLY_F
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5fopen_f, h5fclose_f
use hdf5 , only : h5gopen_f, h5gclose_f
use hdf5 , only : h5aexists_by_name_f
use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f
use iso_fortran_env, only : error_unit
use mpitools , only : nproc
use parameters , only : get_parameter
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
character(len=*), intent(in) :: pname
integer , intent(inout) :: pvalue
integer , intent(inout) :: iret
! local variables
!
logical :: info
character(len=255) :: rname
integer :: np
integer(hid_t) :: fid, gid, aid
integer(hsize_t) :: am(1) = 1
! local parameters
!
character(len=*), parameter :: loc = &
'IO::read_snapshot_parameter_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! reset the success flag
!
iret = 0
! generate the filename of the restart snapshot
!
info = .false.
np = nproc + 1
do while (.not. info .and. np >= 0)
np = np - 1
write (rname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, np
inquire(file = rname, exist = info)
end do
! procees if file exists
!
if (info) then
call h5fopen_f(rname, H5F_ACC_RDONLY_F, fid, iret)
if (iret >= 0) then
call h5gopen_f(fid, 'attributes', gid, iret)
if (iret >= 0) then
call h5aexists_by_name_f(gid, '.', trim(pname), info, iret)
if (info .and. iret >= 0) then
call h5aopen_by_name_f(gid, '.', trim(pname), aid, iret)
if (iret >= 0) then
call h5aread_f(aid, H5T_NATIVE_INTEGER, pvalue, am(:), iret)
call h5aclose_f(aid, iret)
end if
end if
call h5gclose_f(gid, iret)
end if
call h5fclose_f(fid, iret)
end if
else
write(error_unit,"('[', a, ']: ', a)") trim(loc) &
, "Snapshot " // trim(rname) // " file does not exist!"
iret = 1
end if
!-------------------------------------------------------------------------------
!
end subroutine read_snapshot_parameter_integer_h5
!
!===============================================================================
!
! subroutine READ_SNAPSHOT_PARAMETER_DOUBLE_H5:
! --------------------------------------------
!
! Subroutine reads a double precision real parameter from the restart
! snapshot.
!
! Arguments:
!
! pname - the parameter name;
! pvalue - the parameter value;
! iret - the success flag (the success is 0, failure otherwise);
!
!===============================================================================
!
subroutine read_snapshot_parameter_double_h5(pname, pvalue, iret)
! import external procedures
!
use hdf5 , only : hid_t
use hdf5 , only : H5F_ACC_RDONLY_F
use hdf5 , only : H5T_NATIVE_DOUBLE
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5fopen_f, h5fclose_f
use hdf5 , only : h5gopen_f, h5gclose_f
use hdf5 , only : h5aexists_by_name_f
use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f
use iso_fortran_env, only : error_unit
use mpitools , only : nproc
use parameters , only : get_parameter
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
character(len=*), intent(in) :: pname
real(kind=8) , intent(inout) :: pvalue
integer , intent(inout) :: iret
! local variables
!
logical :: info
character(len=255) :: rname
integer :: np
integer(hid_t) :: fid, gid, aid
integer(hsize_t) :: am(1) = 1
! local parameters
!
character(len=*), parameter :: loc = &
'IO::read_snapshot_parameter_double_h5()'
!
!-------------------------------------------------------------------------------
!
! reset the success flag
!
iret = 0
! generate the filename of the restart snapshot
!
info = .false.
np = nproc + 1
do while (.not. info .and. np >= 0)
np = np - 1
write (rname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, np
inquire(file = rname, exist = info)
end do
! procees if file exists
!
if (info) then
call h5fopen_f(rname, H5F_ACC_RDONLY_F, fid, iret)
if (iret >= 0) then
call h5gopen_f(fid, 'attributes', gid, iret)
if (iret >= 0) then
call h5aexists_by_name_f(gid, '.', trim(pname), info, iret)
if (info .and. iret >= 0) then
call h5aopen_by_name_f(gid, '.', trim(pname), aid, iret)
if (iret >= 0) then
call h5aread_f(aid, H5T_NATIVE_DOUBLE, pvalue, am(:), iret)
call h5aclose_f(aid, iret)
end if
end if
call h5gclose_f(gid, iret)
end if
call h5fclose_f(fid, iret)
end if
else
write(error_unit,"('[', a, ']: ', a)") trim(loc) &
, "Snapshot " // trim(rname) // " file does not exist!"
iret = 1
end if
!-------------------------------------------------------------------------------
!
end subroutine read_snapshot_parameter_double_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:
!
! iret - the return flag to inform if subroutine succeeded or failed;
!
!===============================================================================
!
subroutine read_restart_snapshot_h5(iret)
! import external procedures and variables
!
use blocks , only : change_blocks_process
use forcing , only : einj
use hdf5 , only : hid_t
use hdf5 , only : H5F_ACC_RDONLY_F
use hdf5 , only : h5fis_hdf5_f, h5fopen_f, h5fclose_f
use hdf5 , only : h5gopen_f, h5gclose_f
use iso_fortran_env, only : error_unit
#ifdef MPI
use mesh , only : redistribute_blocks
#endif /* MPI */
use mpitools , only : nprocs, npmax, nproc
! local variables are not implicit by default
!
implicit none
! input and output arguments
!
integer, intent(out) :: iret
! local variables
!
character(len=255) :: fl, msg
integer(hid_t) :: fid, gid
integer :: err, lfile
logical :: info
real(kind=8) :: deinj
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_restart_snapshot_h5()'
!
!-------------------------------------------------------------------------------
!
! initialize success flag
!
iret = 0
!! 1. RESTORE PARAMETERS AND META BLOCKS FROM THE FIRST FILE
!!
! prepare the filename using the current process number; in case the file does
! not exist decrease it until the file corresponding to lower process number
! is found;
!
write (fl, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, 0
inquire(file = fl, exist = info)
! quit, if file does not exist
!
if (.not. info) then
iret = 121
msg = "File " // trim(fl) // " does not exist!"
else ! file does exist
! check if this file is in the HDF5 format
!
call h5fis_hdf5_f(fl, info, err)
! quit, if the format verification failed or file is not in HDF5 format
!
if (err < 0 .or. .not. info) then
iret = 122
if (err < 0) msg = "Cannot check the file format!"
if (.not. info) msg = "File " // trim(fl) // " is not an HDF5 file!"
else ! file is HDF5
! open the HDF5 file
!
call h5fopen_f(fl, H5F_ACC_RDONLY_F, fid, err)
! quit, if file could not be opened
!
if (err < 0) then
iret = 123
msg = "Cannot open file: " // trim(fl)
else ! file is opened
! read global attributes
!
call read_attributes_h5(fid)
! read meta blocks and recreate the meta block hierarchy
!
call read_metablocks_h5(fid)
! close the file
!
call h5fclose_f(fid, err)
! quit, if file could not be closed
!
if (err > 0) then
iret = 124
msg = "Cannot close file: " // trim(fl)
end if
end if ! file is opened
end if ! file is HDF5
end if ! file does exist
!! 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
!
! first, read data blocks to processes which have corresponding restart file
!
if (nproc < nfiles) then
! prepare the filename
!
write (fl, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, nproc
! check if the HDF5 file exists
!
inquire(file = fl, exist = info)
! quit, if file does not exist
!
if (.not. info) then
iret = 121
msg = "File " // trim(fl) // " does not exist!"
else ! file does exist
! check if this file is in the HDF5 format
!
call h5fis_hdf5_f(fl, info, err)
! quit, if the format verification failed or file is not in HDF5 format
!
if (err < 0 .or. .not. info) then
iret = 122
if (err < 0) msg = "Cannot check the file format!"
if (.not. info) msg = "File " // trim(fl) // " is not an HDF5 file!"
else ! file is HDF5
! open the HDF5 file
!
call h5fopen_f(fl, H5F_ACC_RDONLY_F, fid, err)
! quit, if file could not be opened
!
if (err < 0) then
iret = 123
msg = "Cannot open file: " // trim(fl)
else ! file is opened
! restore injected energy
!
call h5gopen_f(fid, 'attributes', gid, err)
if (err >= 0) then
call read_attribute(gid, 'einj', einj)
call h5gclose_f(gid, err)
if (err /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the group!"
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open the group!"
end if
! read data blocks
!
call read_datablocks_h5(fid)
! close the file
!
call h5fclose_f(fid, err)
! quit, if file could not be closed
!
if (err > 0) then
iret = 124
msg = "Cannot close file: " // trim(fl)
end if
end if ! file is opened
end if ! file is HDF5
end if ! file exists
end if ! nproc < nfiles
! if there are more files than processes, read the remaining files by
! the last process and redistribute blocks after each processed file,
! otherwise only redistribute blocks
!
if (nprocs < nfiles) then
! iterate over remaining files and read one by one to the last block
!
do lfile = nprocs, nfiles - 1
! switch meta blocks from the read file to belong to the reading process
!
call change_blocks_process(lfile, npmax)
! read the remaining files by the last process only
!
if (nproc == npmax) then
! prepare the filename
!
write (fl, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, lfile
! check if the HDF5 file exists
!
inquire(file = fl, exist = info)
! quit, if file does not exist
!
if (.not. info) then
iret = 121
msg = "File " // trim(fl) // " does not exist!"
else ! file does exist
! check if this file is in the HDF5 format
!
call h5fis_hdf5_f(fl, info, err)
! quit, if the format verification failed or file is not in HDF5 format
!
if (err < 0 .or. .not. info) then
iret = 122
if (err < 0) msg = "Cannot check the file format!"
if (.not. info) msg = "File " // trim(fl) // &
" is not an HDF5 file!"
else ! file is HDF5
! open the HDF5 file
!
call h5fopen_f(fl, H5F_ACC_RDONLY_F, fid, err)
! quit, if file could not be opened
!
if (err < 0) then
iret = 123
msg = "Cannot open file: " // trim(fl)
else ! file is opened
! restore injected energy
!
call h5gopen_f(fid, 'attributes', gid, err)
if (err >= 0) then
call read_attribute(gid, 'einj', deinj)
einj = einj + deinj
call h5gclose_f(gid, err)
if (err /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the group!"
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open the group!"
end if
! read data blocks
!
call read_datablocks_h5(fid)
! close the file
!
call h5fclose_f(fid, err)
! quit, if file could not be closed
!
if (err > 0) then
iret = 124
msg = "Cannot close file: " // trim(fl)
end if
end if ! file is opened
end if ! file is HDF5
end if ! file exists
end if ! nproc == npmax
#ifdef MPI
! redistribute blocks between processors
!
call redistribute_blocks()
#endif /* MPI */
end do ! lfile = nprocs, nfiles - 1
else ! nprocs < nfiles
#ifdef MPI
! redistribute blocks between processors
!
call redistribute_blocks()
#endif /* MPI */
end if ! nprocs < nfiles
! deallocate the array of block pointers
!
if (allocated(block_array)) deallocate(block_array)
! if there was any problem, print the message
!
if (iret > 0) write(error_unit,"('[',a,']: ',a)") trim(loc), trim(msg)
!-------------------------------------------------------------------------------
!
end subroutine read_restart_snapshot_h5
!
!===============================================================================
!
! subroutine WRITE_RESTART_SNAPSHOT_H5:
! ------------------------------------
!
! Subroutine writes restart snapshot, i.e. parameters, meta and data blocks
! to the HDF5 format restart files in order to resume a terminated job later.
!
! Arguments:
!
! nrun - the snapshot number;
! iret - the return flag to inform if subroutine succeeded or failed;
!
!===============================================================================
!
subroutine write_restart_snapshot_h5(nrun, iret)
! import external procedures and variables
!
use hdf5 , only : hid_t
use hdf5 , only : H5F_ACC_TRUNC_F, H5F_SCOPE_GLOBAL_F
use hdf5 , only : h5fcreate_f, h5fflush_f, h5fclose_f
use iso_fortran_env, only : error_unit
use mpitools , only : nproc
! local variables are not implicit by default
!
implicit none
! input and output arguments
!
integer, intent(in) :: nrun
integer, intent(out) :: iret
! local variables
!
character(len=64) :: fl
integer(hid_t) :: fid
integer :: err
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_restart_snapshot_h5()'
!
!-------------------------------------------------------------------------------
!
! prepare the restart snapshot filename
!
write (fl, "('r',i6.6,'_',i5.5,'.h5')") nrun, nproc
! create the new HDF5 file to store the snapshot
!
call h5fcreate_f(fl, H5F_ACC_TRUNC_F, fid, err)
! if the file could not be created, print message and quit
!
if (err < 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create file: " // trim(fl)
iret = 201
return
end if
! write the global attributes
!
call write_attributes_h5(fid)
! write all metablocks which represent the internal structure of domain
!
call write_metablocks_h5(fid)
! write all datablocks which represent the all variables
!
call write_datablocks_h5(fid)
! flush the file
!
call h5fflush_f(fid, H5F_SCOPE_GLOBAL_F, err)
! close the file
!
call h5fclose_f(fid, err)
! if the file could not be closed print message and quit
!
if (err > 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close file: " // trim(fl)
iret = 203
return
end if
!-------------------------------------------------------------------------------
!
end subroutine write_restart_snapshot_h5
!
!===============================================================================
!
! subroutine WRITE_SNAPSHOT_H5:
! ----------------------------
!
! Subroutine writes the current simulation snapshot, i.e. parameters,
! coordinates and variables to the HDF5 format files for further processing.
!
!
!===============================================================================
!
subroutine write_snapshot_h5()
! import external procedures and variables
!
use hdf5 , only : hid_t
use hdf5 , only : H5F_ACC_TRUNC_F, H5F_SCOPE_GLOBAL_F
use hdf5 , only : h5fcreate_f, h5fflush_f, h5fclose_f
use iso_fortran_env, only : error_unit
use mpitools , only : nproc
! local variables are not implicit by default
!
implicit none
! local variables
!
character(len=64) :: fl
integer(hid_t) :: fid
integer :: err
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_snapshot_h5()'
!
!-------------------------------------------------------------------------------
!
! prepare the restart snapshot filename
!
write (fl, "(a1,i6.6,'_',i5.5,'.h5')") ftype, isnap, nproc
! create the new HDF5 file to store the snapshot
!
call h5fcreate_f(fl, H5F_ACC_TRUNC_F, fid, err)
! if the file could not be created, print message and quit
!
if (err < 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create file: " // trim(fl)
return
end if
! write the global attributes
!
call write_attributes_h5(fid)
! write the coordinates (data block bounds, refinement levels, etc.)
!
call write_coordinates_h5(fid)
! depending on the selected type of output file write the right groups
!
select case(ftype)
case('c')
! write the variables stored in data blocks (leafs)
!
call write_conservative_variables_h5(fid)
case('p')
! write the variables stored in data blocks (leafs)
!
call write_primitive_variables_h5(fid)
case default
! print information about unsupported file format and quit
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "File type is not suppoerted!"
call h5fclose_f(fid, err)
return
end select
! flush the file
!
call h5fflush_f(fid, H5F_SCOPE_GLOBAL_F, err)
! close the file
!
call h5fclose_f(fid, err)
! if the file could not be closed print message and quit
!
if (err > 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close file: " // trim(fl)
return
end if
!-------------------------------------------------------------------------------
!
end subroutine write_snapshot_h5
!
!===============================================================================
!
! subroutine WRITE_ATTRIBUTES_H5:
! ------------------------------
!
! Subroutine stores global attributes in the HDF5 file provided by an
! identifier.
!
! Arguments:
!
! fid - the HDF5 file identifier;
!
!===============================================================================
!
subroutine write_attributes_h5(fid)
! import external procedures and variables
!
use blocks , only : get_mblocks, get_dblocks, get_nleafs
use blocks , only : get_last_id
use coordinates , only : minlev, maxlev
use coordinates , only : 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
use evolution , only : step, time, dt, dtn, dte, cfl, glm_alpha, errs
use evolution , only : atol, rtol, mrej, niterations, nrejections
use forcing , only : nmodes, einj, fcoefs
use hdf5 , only : hid_t
use hdf5 , only : h5gcreate_f, h5gclose_f
use iso_fortran_env, only : error_unit
use mpitools , only : nprocs, nproc
use problems , only : problem_name
use random , only : nseeds, get_seeds
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t), intent(in) :: fid
! local variables
!
integer(hid_t) :: gid
integer :: err
! local vectors
!
integer, dimension(3) :: dims = 1
integer, dimension(3) :: per
! local allocatable arrays
!
integer(kind=8), dimension(:,:), allocatable :: seeds
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_attributes_h5()'
!
!-------------------------------------------------------------------------------
!
! store the code name in order to determine the format of data
!
call write_attribute(fid, 'code' , 'AMUN')
call write_attribute(fid, 'version', 'v1.0')
! create a group to store the global attributes
!
call h5gcreate_f(fid, 'attributes', gid, err)
! check if the group has been created successfuly
!
if (err < 0) then
! print error about the problem with creating the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create the group!"
! return from the subroutine
!
return
end if
! convert periodic(:) to an integer vector
!
per(:) = merge(1, 0, periodic(:))
! store string attributes
!
call write_attribute(gid, 'problem', problem_name )
call write_attribute(gid, 'eqsys' , eqsys )
call write_attribute(gid, 'eos' , eos )
! store the integer attributes
!
call write_attribute(gid, 'ndims' , NDIMS )
call write_attribute(gid, 'last_id' , get_last_id())
call write_attribute(gid, 'mblocks' , get_mblocks())
call write_attribute(gid, 'dblocks' , get_dblocks())
call write_attribute(gid, 'nleafs' , get_nleafs() )
call write_attribute(gid, 'ncells' , ncells )
call write_attribute(gid, 'nghosts' , nghosts )
call write_attribute(gid, 'minlev' , minlev )
call write_attribute(gid, 'maxlev' , maxlev )
call write_attribute(gid, 'nprocs' , nprocs )
call write_attribute(gid, 'nproc' , nproc )
call write_attribute(gid, 'nseeds' , nseeds )
call write_attribute(gid, 'step' , step )
call write_attribute(gid, 'isnap' , isnap )
call write_attribute(gid, 'periodic', per(:) )
call write_attribute(gid, 'niterations', niterations)
call write_attribute(gid, 'nrejections', nrejections)
call write_attribute(gid, 'maximum_rejections', mrej)
! store the real attributes
!
call write_attribute(gid, 'xmin', xmin)
call write_attribute(gid, 'xmax', xmax)
call write_attribute(gid, 'ymin', ymin)
call write_attribute(gid, 'ymax', ymax)
call write_attribute(gid, 'zmin', zmin)
call write_attribute(gid, 'zmax', zmax)
call write_attribute(gid, 'time', time)
call write_attribute(gid, 'dt' , dt )
call write_attribute(gid, 'dtn' , dtn )
call write_attribute(gid, 'dte' , dte )
call write_attribute(gid, 'cfl' , cfl )
call write_attribute(gid, 'glm_alpha', glm_alpha)
if (eos == 'adi') then
call write_attribute(gid, 'adiabatic_index', adiabatic_index)
end if
if (eos == 'iso') then
call write_attribute(gid, 'sound_speed', csnd)
end if
call write_attribute(gid, 'absolute_tolerance', atol)
call write_attribute(gid, 'relative_tolerance', rtol)
call write_attribute(gid, 'errs(1)', errs(1))
call write_attribute(gid, 'errs(2)', errs(2))
call write_attribute(gid, 'errs(3)', errs(3))
! store the vector attributes
!
dims(1:NDIMS) = ncells
call write_attribute(gid, 'dims' , dims)
call write_attribute(gid, 'bdims' , bdims)
call write_attribute(gid, 'xblocks', bdims(1))
call write_attribute(gid, 'yblocks', bdims(2))
call write_attribute(gid, 'zblocks', bdims(3))
! store forcing parameters
!
call write_attribute(gid, 'nmodes', nmodes)
call write_attribute(gid, 'einj' , einj)
if (nmodes > 0) then
call write_attribute(gid, 'fcoefs', fcoefs)
end if
! store random number generator seed values
!
if (nseeds > 0) then
! allocate space for seeds
!
allocate(seeds(4,nseeds))
! get the seed values
!
call get_seeds(seeds(:,:))
! store them in the current group
!
call write_attribute(gid, 'seeds', seeds(:,:))
! deallocate seed array
!
deallocate(seeds)
end if ! nseeds > 0
! close the group
!
call h5gclose_f(gid, err)
! check if the group has been closed successfuly
!
if (err < 0) then
! print error about the problem with closing the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the group!"
end if
!-------------------------------------------------------------------------------
!
end subroutine write_attributes_h5
!
!===============================================================================
!
! subroutine READ_ATTRIBUTES_H5:
! -----------------------------
!
! Subroutine restores global attributes from an HDF5 file provided by its
! identifier.
!
! Arguments:
!
! fid - the HDF5 file identifier;
!
!===============================================================================
!
subroutine read_attributes_h5(fid)
! import external procedures and variables
!
use blocks , only : block_meta
use blocks , only : append_metablock
use blocks , only : set_last_id, get_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 evolution , only : step, time, dt, dtn, dte
use evolution , only : niterations, nrejections, errs
use forcing , only : nmodes, fcoefs
use hdf5 , only : hid_t
use hdf5 , only : h5gopen_f, h5gclose_f
use iso_fortran_env, only : error_unit
use random , only : set_seeds, gentype
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t), intent(in) :: fid
! local variables
!
integer(hid_t) :: gid
integer :: ierr, l
integer :: lndims, lmblocks, lnleafs, llast_id
integer :: lncells, lnproc, lnseeds, lnmodes
integer :: status
! local pointers
!
type(block_meta), pointer :: pmeta
! allocatable arrays
!
integer(kind=8), dimension(:,:), allocatable :: seeds
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_attributes_h5()'
!
!-------------------------------------------------------------------------------
!
! open the global attributes group
!
call h5gopen_f(fid, 'attributes', gid, ierr)
! check if the group has been opened successfuly
!
if (ierr < 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open the group!"
return
end if
! restore integer attributes
!
call read_attribute(gid, 'ndims' , lndims )
call read_attribute(gid, 'nprocs' , nfiles )
call read_attribute(gid, 'nproc' , lnproc )
call read_attribute(gid, 'mblocks', lmblocks)
call read_attribute(gid, 'nleafs' , lnleafs )
call read_attribute(gid, 'last_id', llast_id)
call read_attribute(gid, 'ncells' , lncells )
call read_attribute(gid, 'nseeds' , lnseeds )
call read_attribute(gid, 'step' , step )
call read_attribute(gid, 'isnap' , isnap )
call read_attribute(gid, 'niterations', niterations)
call read_attribute(gid, 'nrejections', nrejections)
! restore double precision attributes
!
call read_attribute(gid, 'xmin', xmin)
call read_attribute(gid, 'xmax', xmax)
call read_attribute(gid, 'ymin', ymin)
call read_attribute(gid, 'ymax', ymax)
call read_attribute(gid, 'zmin', zmin)
call read_attribute(gid, 'zmax', zmax)
call read_attribute(gid, 'time', time)
call read_attribute(gid, 'dt' , dt )
call read_attribute(gid, 'dtn' , dtn )
call read_attribute(gid, 'dte' , dte )
call read_attribute(gid, 'errs(1)', errs(1))
call read_attribute(gid, 'errs(2)', errs(2))
call read_attribute(gid, 'errs(3)', errs(3))
! check the number of dimensions
!
if (lndims /= NDIMS) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "The number of dimensions does not match!"
return
end if
! check the block dimensions
!
if (lncells /= ncells) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "The block dimensions do not match!"
end if
! restore forcing coefficients
!
call read_attribute(gid, 'nmodes', lnmodes)
if (lnmodes == nmodes) then
if (lnmodes > 0) call read_attribute(gid, 'fcoefs', fcoefs)
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "The number of driving modes does not match!"
end if
! restore seeds
!
if (trim(gentype) == "same") then
allocate(seeds(4,0:lnseeds-1))
call read_attribute(gid, 'seeds', seeds(:,:))
call set_seeds(lnseeds, seeds(:,:), .false.)
deallocate(seeds)
end if
! allocate all metablocks
!
do l = 1, lmblocks
call append_metablock(pmeta, status)
end do
! check if the number of created metablocks is equal to lbmcloks
!
if (lmblocks /= get_mblocks()) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Number of metablocks does not match!"
end if
! allocate an array of pointers with the size llast_id
!
allocate(block_array(llast_id))
! set the last_id
!
call set_last_id(llast_id)
! close the group
!
call h5gclose_f(gid, ierr)
! check if the group has been closed successfuly
!
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the group!"
end if
!-------------------------------------------------------------------------------
!
end subroutine read_attributes_h5
!
!===============================================================================
!
! subroutine WRITE_METABLOCKS_H5:
! ------------------------------
!
! Subroutine stores all meta blocks with their complete fields in 'metablock'
! group in a provided file identifier.
!
! Arguments:
!
! fid - the HDF5 file identifier;
!
!===============================================================================
!
subroutine write_metablocks_h5(fid)
! import procedures and variables from other modules
!
use blocks , only : block_meta, list_meta
use blocks , only : ndims, nchildren, nsides
use blocks , only : get_last_id, get_mblocks
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5gcreate_f, h5gclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t), intent(in) :: fid
! local variables
!
integer(hid_t) :: gid
integer(kind=4) :: i, j, l, n, p
#if NDIMS == 3
integer(kind=4) :: k
#endif /* NDIMS == 3 */
integer :: iret
integer(hsize_t), dimension(1) :: am, cm
integer(hsize_t), dimension(2) :: dm, pm
#if NDIMS == 2
integer(hsize_t), dimension(4) :: nm
#endif /* NDIMS == 2 */
#if NDIMS == 3
integer(hsize_t), dimension(5) :: nm
#endif /* NDIMS == 3 */
! local allocatable arrays
!
integer(kind=4), dimension(:) , allocatable :: idx
integer(kind=4), dimension(:) , allocatable :: par, dat
integer(kind=4), dimension(:) , allocatable :: id, cpu, lev, cfg, ref, lea
real (kind=8), dimension(:) , allocatable :: xmn, xmx, ymn, ymx, zmn, zmx
integer(kind=4), dimension(:,:), allocatable :: chl, pos, cor
#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 */
! local pointers
!
type(block_meta), pointer :: pmeta
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_metablocks_h5()'
!
!-------------------------------------------------------------------------------
!
! create the group for metadata
!
call h5gcreate_f(fid, 'metablocks', gid, iret)
! check if the group has been created successfuly
!
if (iret >= 0) then
! prepate dimensions
!
am(1) = get_mblocks()
cm(1) = get_last_id()
dm(1) = get_mblocks()
dm(2) = nchildren
pm(1) = get_mblocks()
pm(2) = NDIMS
nm(1) = get_mblocks()
nm(2) = nsides
nm(3) = nsides
#if NDIMS == 2
nm(4) = ndims
#endif /* NDIMS == 2 */
#if NDIMS == 3
nm(4) = nsides
nm(5) = ndims
#endif /* NDIMS == 3 */
! only store data from processes that have any meta blocks
!
if (am(1) > 0) then
! allocate arrays to store meta block fields
!
allocate(idx(cm(1)))
allocate(par(am(1)))
allocate(dat(am(1)))
allocate(id (am(1)))
allocate(cpu(am(1)))
allocate(lev(am(1)))
allocate(cfg(am(1)))
allocate(ref(am(1)))
allocate(lea(am(1)))
allocate(xmn(am(1)))
allocate(xmx(am(1)))
allocate(ymn(am(1)))
allocate(ymx(am(1)))
allocate(zmn(am(1)))
allocate(zmx(am(1)))
allocate(chl(dm(1),dm(2)))
allocate(pos(pm(1),pm(2)))
allocate(cor(pm(1),pm(2)))
#if NDIMS == 2
allocate(edges (nm(1),nm(2),nm(3),nm(4)))
allocate(corners(nm(1),nm(2),nm(3)))
#endif /* NDIMS == 2 */
#if NDIMS == 3
allocate(faces (nm(1),nm(2),nm(3),nm(4),nm(5)))
allocate(edges (nm(1),nm(2),nm(3),nm(4),nm(5)))
allocate(corners(nm(1),nm(2),nm(3),nm(4)))
#endif /* NDIMS == 3 */
! reset stored arrays
!
idx(:) = -1
par(:) = -1
dat(:) = -1
lea(:) = -1
chl(:,:) = -1
#if NDIMS == 2
edges(:,:,:,:) = -1
corners(:,:,:) = -1
#endif /* NDIMS == 2 */
#if NDIMS == 3
faces(:,:,:,:,:) = -1
edges(:,:,:,:,:) = -1
corners(:,:,:,:) = -1
#endif /* NDIMS == 3 */
! reset the block counter
!
l = 0
! associate pmeta with the first block on the meta block list
!
pmeta => list_meta
! iterate over all meta blocks and fill in the arrays for storage
!
do while(associated(pmeta))
! increase the block counter
!
l = l + 1
! store meta block fields
!
idx(pmeta%id) = l
if (associated(pmeta%parent)) par(l) = pmeta%parent%id
if (associated(pmeta%data) ) dat(l) = 1
id (l) = pmeta%id
cpu(l) = pmeta%process
lev(l) = pmeta%level
cfg(l) = pmeta%conf
ref(l) = pmeta%refine
pos(l,:) = pmeta%pos(:)
cor(l,:) = pmeta%coords(:)
if (pmeta%leaf) lea(l) = 1
xmn(l) = pmeta%xmin
xmx(l) = pmeta%xmax
ymn(l) = pmeta%ymin
ymx(l) = pmeta%ymax
zmn(l) = pmeta%zmin
zmx(l) = pmeta%zmax
do p = 1, nchildren
if (associated(pmeta%child(p)%ptr)) chl(l,p) = pmeta%child(p)%ptr%id
end do
! store face, edge and corner neighbor pointers
!
#if NDIMS == 2
do i = 1, nsides
do j = 1, nsides
do n = 1, ndims
if (associated(pmeta%edges(i,j,n)%ptr)) &
edges(l,i,j,n) = pmeta%edges(i,j,n)%ptr%id
end do ! ndims
if (associated(pmeta%corners(i,j)%ptr)) &
corners(l,i,j) = pmeta%corners(i,j)%ptr%id
end do ! i = 1, nsides
end do ! j = 1, nsides
#endif /* NDIMS == 2 */
#if NDIMS == 3
do i = 1, nsides
do j = 1, nsides
do k = 1, nsides
do n = 1, ndims
if (associated(pmeta%faces(i,j,k,n)%ptr)) &
faces(l,i,j,k,n) = pmeta%faces(i,j,k,n)%ptr%id
if (associated(pmeta%edges(i,j,k,n)%ptr)) &
edges(l,i,j,k,n) = pmeta%edges(i,j,k,n)%ptr%id
end do ! ndims
if (associated(pmeta%corners(i,j,k)%ptr)) &
corners(l,i,j,k) = pmeta%corners(i,j,k)%ptr%id
end do ! i = 1, nsides
end do ! j = 1, nsides
end do ! k = 1, nsides
#endif /* NDIMS == 3 */
! associate pmeta with the next block on the list
!
pmeta => pmeta%next
end do ! over all meta blocks
! store meta block data in the HDF5 file
!
call write_array(gid, 'indices', cm(1) , idx)
call write_array(gid, 'parent' , am(1) , par)
call write_array(gid, 'data' , am(1) , dat)
call write_array(gid, 'id' , am(1) , id )
call write_array(gid, 'cpu' , am(1) , cpu)
call write_array(gid, 'level' , am(1) , lev)
call write_array(gid, 'config' , am(1) , cfg)
call write_array(gid, 'refine' , am(1) , ref)
call write_array(gid, 'leaf' , am(1) , lea)
call write_array(gid, 'xmin' , am(1) , xmn)
call write_array(gid, 'xmax' , am(1) , xmx)
call write_array(gid, 'ymin' , am(1) , ymn)
call write_array(gid, 'ymax' , am(1) , ymx)
call write_array(gid, 'zmin' , am(1) , zmn)
call write_array(gid, 'zmax' , am(1) , zmx)
call write_array(gid, 'child' , dm(:) , chl(:,:))
call write_array(gid, 'pos' , pm(:) , pos(:,:))
call write_array(gid, 'coord' , pm(:) , cor(:,:))
#if NDIMS == 2
call write_array(gid, 'edges' , nm(1:4), edges(:,:,:,:))
call write_array(gid, 'corners', nm(1:3), corners(:,:,:))
#endif /* NDIMS == 2 */
#if NDIMS == 3
call write_array(gid, 'faces' , nm(1:5), faces(:,:,:,:,:))
call write_array(gid, 'edges' , nm(1:5), edges(:,:,:,:,:))
call write_array(gid, 'corners', nm(1:4), corners(:,:,:,:))
#endif /* NDIMS == 3 */
! deallocate allocated arrays
!
if (allocated(idx)) deallocate(idx)
if (allocated(par)) deallocate(par)
if (allocated(dat)) deallocate(dat)
if (allocated(id) ) deallocate(id)
if (allocated(cpu)) deallocate(cpu)
if (allocated(lev)) deallocate(lev)
if (allocated(cfg)) deallocate(cfg)
if (allocated(ref)) deallocate(ref)
if (allocated(lea)) deallocate(lea)
if (allocated(xmn)) deallocate(xmn)
if (allocated(xmx)) deallocate(xmx)
if (allocated(ymn)) deallocate(ymn)
if (allocated(ymx)) deallocate(ymx)
if (allocated(zmn)) deallocate(zmn)
if (allocated(zmx)) deallocate(zmx)
if (allocated(chl)) deallocate(chl)
if (allocated(cor)) deallocate(cor)
#if NDIMS == 3
if (allocated(faces)) deallocate(faces)
#endif /* NDIMS == 3 */
if (allocated(edges)) deallocate(edges)
if (allocated(corners)) deallocate(corners)
end if ! meta blocks > 0
! close the group
!
call h5gclose_f(gid, iret)
! check if the group has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the group!"
end if
else
! print error about the problem with creating the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create the group!"
end if
!-------------------------------------------------------------------------------
!
end subroutine write_metablocks_h5
!
!===============================================================================
!
! subroutine READ_METABLOCKS_H5:
! -----------------------------
!
! Subroutine restores all meta blocks with their complete fields from
! 'metablock' group in a provided restart file identifier.
!
! Arguments:
!
! fid - the HDF5 file identifier;
!
!===============================================================================
!
subroutine read_metablocks_h5(fid)
! import procedures and variables from other modules
!
use blocks , only : block_meta, list_meta
use blocks , only : ndims, nchildren, nsides
use blocks , only : 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 hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5gopen_f, h5gclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t), intent(in) :: fid
! local variables
!
integer(hid_t) :: gid
integer(kind=4) :: i, j, l, p, n, ip
#if NDIMS == 3
integer(kind=4) :: k
#endif /* NDIMS == 3 */
integer :: err
integer(hsize_t), dimension(1) :: am
integer(hsize_t), dimension(2) :: dm, pm
#if NDIMS == 2
integer(hsize_t), dimension(4) :: nm
#endif /* NDIMS == 2 */
#if NDIMS == 3
integer(hsize_t), dimension(5) :: nm
#endif /* NDIMS == 3 */
! local allocatable arrays
!
integer(kind=4), dimension(:) , allocatable :: par, dat
integer(kind=4), dimension(:) , allocatable :: id, cpu, lev, cfg, ref, lea
real (kind=8), dimension(:) , allocatable :: xmn, xmx, ymn, ymx, zmn, zmx
integer(kind=4), dimension(:,:), allocatable :: chl, pos, cor
#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 */
! local pointers
!
type(block_meta), pointer :: pmeta
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_metablocks_h5()'
!
!-------------------------------------------------------------------------------
!
! open metablock group
!
call h5gopen_f(fid, 'metablocks', gid, err)
! check if the group has been opened successfuly
!
if (err >= 0) then
! prepate dimensions
!
am(1) = get_mblocks()
dm(1) = get_mblocks()
dm(2) = nchildren
pm(1) = get_mblocks()
pm(2) = NDIMS
nm(1) = get_mblocks()
nm(2) = nsides
nm(3) = nsides
#if NDIMS == 2
nm(4) = ndims
#endif /* NDIMS == 2 */
#if NDIMS == 3
nm(4) = nsides
nm(5) = ndims
#endif /* NDIMS == 3 */
! allocate arrays to restore metablocks data
!
allocate(id (am(1)))
allocate(cpu(am(1)))
allocate(lev(am(1)))
allocate(par(am(1)))
allocate(dat(am(1)))
allocate(cfg(am(1)))
allocate(ref(am(1)))
allocate(lea(am(1)))
allocate(xmn(am(1)))
allocate(xmx(am(1)))
allocate(ymn(am(1)))
allocate(ymx(am(1)))
allocate(zmn(am(1)))
allocate(zmx(am(1)))
allocate(chl(dm(1),dm(2)))
allocate(pos(pm(1),pm(2)))
allocate(cor(pm(1),pm(2)))
#if NDIMS == 2
allocate(edges (nm(1),nm(2),nm(3),nm(4)))
allocate(corners(nm(1),nm(2),nm(3)))
#endif /* NDIMS == 2 */
#if NDIMS == 3
allocate(faces (nm(1),nm(2),nm(3),nm(4),nm(5)))
allocate(edges (nm(1),nm(2),nm(3),nm(4),nm(5)))
allocate(corners(nm(1),nm(2),nm(3),nm(4)))
#endif /* NDIMS == 3 */
! reset vectors
!
par(:) = -1
dat(:) = -1
lea(:) = -1
chl(:,:) = -1
#if NDIMS == 2
edges(:,:,:,:) = -1
corners(:,:,:) = -1
#endif /* NDIMS == 2 */
#if NDIMS == 3
faces(:,:,:,:,:) = -1
edges(:,:,:,:,:) = -1
corners(:,:,:,:) = -1
#endif /* NDIMS == 3 */
! read metablock fields from the HDF5 file
!
call read_array(gid, 'id' , am(:), id (:))
call read_array(gid, 'cpu' , am(:), cpu(:))
call read_array(gid, 'level' , am(:), lev(:))
call read_array(gid, 'config' , am(:), cfg(:))
call read_array(gid, 'refine' , am(:), ref(:))
call read_array(gid, 'leaf' , am(:), lea(:))
call read_array(gid, 'parent' , am(:), par(:))
call read_array(gid, 'xmin' , am(:), xmn(:))
call read_array(gid, 'xmax' , am(:), xmx(:))
call read_array(gid, 'ymin' , am(:), ymn(:))
call read_array(gid, 'ymax' , am(:), ymx(:))
call read_array(gid, 'zmin' , am(:), zmn(:))
call read_array(gid, 'zmax' , am(:), zmx(:))
call read_array(gid, 'pos' , pm(:), pos(:,:))
call read_array(gid, 'coord' , pm(:), cor(:,:))
call read_array(gid, 'child' , dm(:), chl(:,:))
#if NDIMS == 2
call read_array(gid, 'edges' , nm(1:4), edges(:,:,:,:))
call read_array(gid, 'corners', nm(1:3), corners(:,:,:))
#endif /* NDIMS == 2 */
#if NDIMS == 3
call read_array(gid, 'faces' , nm(1:5), faces(:,:,:,:,:))
call read_array(gid, 'edges' , nm(1:5), edges(:,:,:,:,:))
call read_array(gid, 'corners', nm(1:4), corners(:,:,:,:))
#endif /* NDIMS == 3 */
! reset the block counter
!
l = 0
! associate pmeta with the first block on the meta block list
!
pmeta => list_meta
! iterate over all meta blocks and restore their fields
!
do while(associated(pmeta))
! increase the block counter
!
l = l + 1
! restore meta block fields
!
block_array(id(l))%ptr => pmeta
call metablock_set_id (pmeta, id (l))
call metablock_set_process (pmeta, cpu(l))
call metablock_set_refinement (pmeta, ref(l))
call metablock_set_configuration(pmeta, cfg(l))
call metablock_set_level (pmeta, lev(l))
call metablock_set_position (pmeta, pos(l,:))
call metablock_set_coordinates (pmeta, cor(l,:))
call metablock_set_bounds (pmeta, xmn(l), xmx(l), ymn(l), ymx(l) &
, zmn(l), zmx(l))
if (lea(l) == 1) call metablock_set_leaf(pmeta)
! associate pmeta with the next block on the list
!
pmeta => pmeta%next
end do ! over all meta blocks
! reset the block counter
!
l = 0
! associate pmeta with the first block on the meta block list
!
pmeta => list_meta
! iterate over all meta blocks and restore their pointers
!
do while(associated(pmeta))
! increase the block counter
!
l = l + 1
! restore %parent pointer
!
if (par(l) > 0) pmeta%parent => block_array(par(l))%ptr
! restore %child pointers
!
do p = 1, nchildren
if (chl(l,p) > 0) then
pmeta%child(p)%ptr => block_array(chl(l,p))%ptr
end if
end do ! p = 1, nchildren
! restore %faces, %edges and %corners neighbor pointers
!
#if NDIMS == 2
do i = 1, nsides
do j = 1, nsides
do n = 1, ndims
ip = edges(l,i,j,n)
if (ip > 0) pmeta%edges(i,j,n)%ptr => block_array(ip)%ptr
end do ! n = 1, ndims
ip = corners(l,i,j)
if (ip > 0) pmeta%corners(i,j)%ptr => block_array(ip)%ptr
end do ! i = 1, nsides
end do ! j = 1, nsides
#endif /* NDIMS == 2 */
#if NDIMS == 3
do i = 1, nsides
do j = 1, nsides
do k = 1, nsides
do n = 1, ndims
ip = faces(l,i,j,k,n)
if (ip > 0) pmeta%faces(i,j,k,n)%ptr => block_array(ip)%ptr
ip = edges(l,i,j,k,n)
if (ip > 0) pmeta%edges(i,j,k,n)%ptr => block_array(ip)%ptr
end do ! n = 1, ndims
ip = corners(l,i,j,k)
if (ip > 0) pmeta%corners(i,j,k)%ptr => block_array(ip)%ptr
end do ! i = 1, nsides
end do ! j = 1, nsides
end do ! k = 1, nsides
#endif /* NDIMS == 3 */
! associate pmeta with the next block on the list
!
pmeta => pmeta%next
end do ! over all meta blocks
! deallocate allocatable arrays
!
if (allocated(id) ) deallocate(id )
if (allocated(par)) deallocate(par)
if (allocated(dat)) deallocate(dat)
if (allocated(cpu)) deallocate(cpu)
if (allocated(lev)) deallocate(lev)
if (allocated(cfg)) deallocate(cfg)
if (allocated(ref)) deallocate(ref)
if (allocated(lea)) deallocate(lea)
if (allocated(xmn)) deallocate(xmn)
if (allocated(xmx)) deallocate(xmx)
if (allocated(ymn)) deallocate(ymn)
if (allocated(ymx)) deallocate(ymx)
if (allocated(zmn)) deallocate(zmn)
if (allocated(zmx)) deallocate(zmx)
if (allocated(chl)) deallocate(chl)
if (allocated(cor)) deallocate(cor)
#if NDIMS == 3
if (allocated(faces)) deallocate(faces)
#endif /* NDIMS == 3 */
if (allocated(edges)) deallocate(edges)
if (allocated(corners)) deallocate(corners)
! close the group
!
call h5gclose_f(gid, err)
! check if the group has been closed successfuly
!
if (err > 0) then
! print error about the problem with closing the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the metablock group!"
end if
else
! print error about the problem with opening the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open the metablock group!"
end if
!-------------------------------------------------------------------------------
!
end subroutine read_metablocks_h5
!
!===============================================================================
!
! subroutine WRITE_DATABLOCKS_H5:
! ------------------------------
!
! Subroutine writes all data block fields in the new group 'datablocks'
! in the provided handler to the HDF5 file.
!
! Arguments:
!
! fid - the HDF5 file identifier;
!
!===============================================================================
!
subroutine write_datablocks_h5(fid)
! import external procedures and variables
!
use blocks , only : block_meta, block_data, list_data
use blocks , only : get_dblocks
use coordinates , only : nn => bcells
use equations , only : nv
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5gcreate_f, h5gclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine variables
!
integer(hid_t), intent(in) :: fid
! local pointers
!
type(block_data), pointer :: pdata
! local variables
!
character(len=16) :: bname
integer(hid_t) :: gid, bid
integer(kind=4) :: l
integer :: err
! local arrays
!
integer(hsize_t), dimension(4) :: dm = 1
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_datablocks_h5()'
!
!-------------------------------------------------------------------------------
!
! create a new group for storing data blocks
!
call h5gcreate_f(fid, 'datablocks', gid, err)
! check if the group has been created successfuly
!
if (err >= 0) then
! store data blocks only if there is at least one belonging to
! the current process
!
if (get_dblocks() > 0) then
! prepate the dimensions
!
dm(1) = nv
dm(2) = nn
dm(3) = nn
#if NDIMS == 3
dm(4) = nn
#endif /* NDIMS == 3 */
! reset the block counter
!
l = 0
! associate the pointer with the first block in the data block list
!
pdata => list_data
! iterate over all data blocks and fill in the arrays id, u, and q
!
do while(associated(pdata))
! increase the block counter
!
l = l + 1
! create name for the current block
!
write(bname, "('dblk_', i11.11)") l
! create a group for storing the current data block fields
!
call h5gcreate_f(gid, bname, bid, err)
! store the corresponding meta block index
!
call write_attribute(bid, 'meta', pdata%meta%id)
! store the primitive and conservative variables
!
call write_array(bid, 'pvar' , dm(:), pdata%q (:,:,:,:))
call write_array(bid, 'cvar0', dm(:), pdata%u0(:,:,:,:))
call write_array(bid, 'cvar1', dm(:), pdata%u1(:,:,:,:))
! close the block group
!
call h5gclose_f(bid, err)
! associate the pointer with the next data block on the list
!
pdata => pdata%next
end do ! data blocks
end if ! dblocks > 0
! close the group
!
call h5gclose_f(gid, err)
! check if the group has been closed successfuly
!
if (err > 0) then
! print error about the problem with closing the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the group!"
end if
else
! print error about the problem with creating the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create the group!"
end if
!-------------------------------------------------------------------------------
!
end subroutine write_datablocks_h5
!
!===============================================================================
!
! subroutine READ_DATABLOCKS_H5:
! -----------------------------
!
! Subroutine reads all data blocks stored in the group 'datablocks' of
! the provided handler to the HDF5 restart file.
!
! Arguments:
!
! fid - the HDF5 file identifier;
!
!===============================================================================
!
subroutine read_datablocks_h5(fid)
! import external procedures and variables
!
use blocks , only : block_meta, block_data
use blocks , only : append_datablock, link_blocks
use coordinates , only : nn => bcells, ng => nghosts
use equations , only : nv
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5gopen_f, h5gclose_f, h5lexists_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine variables
!
integer(hid_t), intent(in) :: fid
! local pointers
!
type(block_data), pointer :: pdata
! local variables
!
character(len=16) :: bname
integer(hid_t) :: gid, bid
integer(hsize_t) :: l
integer(kind=4) :: i
integer :: dblocks, ncells, nghosts, nc, nb, ne, status
! local arrays
!
integer(hsize_t), dimension(5) :: dm = 1
! local allocatable arrays
!
real(kind=8), dimension(:,:,:,:,:), allocatable :: uu
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_datablocks_h5()'
!
!-------------------------------------------------------------------------------
!
! read the number of data blocks
!
call h5gopen_f(fid, 'attributes', gid, status)
if (status /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open the attribute group!"
return
end if
call read_attribute(gid, 'dblocks', dblocks)
call read_attribute(gid, 'ncells' , ncells )
call read_attribute(gid, 'nghosts', nghosts)
call h5gclose_f(gid, status)
if (status /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the attribute group!"
return
end if
! restore data blocks only if there are any
!
if (dblocks > 0) then
! open the group 'datablocks'
!
call h5gopen_f(fid, 'datablocks', gid, status)
if (status /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open the data block group!"
else
! prepare the number of cells in the stored blocks and corresponding indices
!
nc = ncells + 2 * nghosts
if (nghosts >= ng) then
nb = 1 + (nghosts - ng)
ne = nc - (nghosts - ng)
else
nb = 1 + (ng - nghosts)
ne = nn - (ng - nghosts)
end if
! fill out dimensions
!
dm(1) = dblocks
dm(2) = nv
dm(3) = nc
dm(4) = nc
#if NDIMS == 3
dm(5) = nc
#endif /* NDIMS == 3 */
! allocate arrays for input data
!
allocate(uu(3,dm(2),dm(3),dm(4),dm(5)), stat = status)
! check if allocation was successful
!
if (status == 0) then
! iterate over data blocks
!
do l = 1, dm(1)
! allocate and append to the end of the list a new datablock
!
call append_datablock(pdata, status)
! create name for the current block
!
write(bname, "('dblk_', i11.11)") l
! open the group for the current block fields
!
call h5gopen_f(gid, bname, bid, status)
if (status == 0) then
! get the id of the linked meta block
!
call read_attribute(bid, 'meta', i)
! associate the corresponding meta block with the current data block
!
call link_blocks(block_array(i)%ptr, pdata)
! read the data
!
call read_array(bid, 'pvar' , dm(2:5), uu(1,:,:,:,:))
call read_array(bid, 'cvar0', dm(2:5), uu(2,:,:,:,:))
call read_array(bid, 'cvar1', dm(2:5), uu(3,:,:,:,:))
! fill out the block arrays taking into account the change of nghosts
!
if (nghosts >= ng) then
#if NDIMS == 3
pdata%q (:,:,:,:) = uu(1,:,nb:ne,nb:ne,nb:ne)
pdata%u0(:,:,:,:) = uu(2,:,nb:ne,nb:ne,nb:ne)
pdata%u1(:,:,:,:) = uu(3,:,nb:ne,nb:ne,nb:ne)
#else /* NDIMS == 3 */
pdata%q (:,:,:,:) = uu(1,:,nb:ne,nb:ne, : )
pdata%u0(:,:,:,:) = uu(2,:,nb:ne,nb:ne, : )
pdata%u1(:,:,:,:) = uu(3,:,nb:ne,nb:ne, : )
#endif /* NDIMS == 3 */
else
#if NDIMS == 3
pdata%q (:,nb:ne,nb:ne,nb:ne) = uu(1,:,:,:,:)
pdata%u0(:,nb:ne,nb:ne,nb:ne) = uu(2,:,:,:,:)
pdata%u1(:,nb:ne,nb:ne,nb:ne) = uu(3,:,:,:,:)
#else /* NDIMS == 3 */
pdata%q (:,nb:ne,nb:ne, : ) = uu(1,:,:,:,:)
pdata%u0(:,nb:ne,nb:ne, : ) = uu(2,:,:,:,:)
pdata%u1(:,nb:ne,nb:ne, : ) = uu(3,:,:,:,:)
#endif /* NDIMS == 3 */
end if
! close the current data block group
!
call h5gclose_f(bid, status)
if (status /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close group '", trim(bname), "'!"
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open group '", trim(bname), "'!"
end if
end do ! l = 1, dm(1)
else ! allocate
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot allocate temporary array!"
end if ! allocate
! deallocate allocatable arrays
!
if (allocated(uu)) deallocate(uu)
! close the data block group
!
call h5gclose_f(gid, status)
if (status /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the data block group!"
end if
end if
end if ! dblocks > 0
!-------------------------------------------------------------------------------
!
end subroutine read_datablocks_h5
!
!===============================================================================
!
! write_coordinates_h5: subroutine writes data block coordinates and other
! variables which determine geometrical position of
! the blocks
!
! info: this subroutine stores coordinates
!
! arguments:
! fid - the HDF5 file identifier;
!
!===============================================================================
!
subroutine write_coordinates_h5(fid)
! references to other modules
!
use blocks , only : block_meta, block_data, list_data
use blocks , only : nsides
use blocks , only : get_dblocks
use coordinates , only : maxlev
use coordinates , only : adx, ady, adz
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5gcreate_f, h5gclose_f
use iso_fortran_env, only : error_unit
! declare variables
!
implicit none
! input variables
!
integer(hid_t), intent(in) :: fid
! HDF5 variables
!
integer(hid_t) :: gid
! local variables
!
integer :: err
integer(kind=4) :: l
integer(hsize_t) :: am(1), cm(2), rm(2), dm(3)
! local allocatable arrays
!
integer(kind=4), dimension(:) , allocatable :: ids, lev, ref
integer(kind=4), dimension(:,:) , allocatable :: cor
real (kind=8), dimension(:,:,:), allocatable :: bnd
! local pointers
!
type(block_data), pointer :: pdata
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_coordinates_h5()'
!
!-------------------------------------------------------------------------------
!
! create a group to store global attributes
!
call h5gcreate_f(fid, 'coordinates', gid, err)
! check if the group has been created successfuly
!
if (err .ge. 0) then
! store coordinates only if there are some data blocks on the current processor
!
if (get_dblocks() .gt. 0) then
! prepare dimensions
!
am(1) = maxlev
cm(1) = get_dblocks()
cm(2) = NDIMS
rm(1) = maxlev
rm(2) = NDIMS
dm(1) = get_dblocks()
dm(2) = NDIMS
dm(3) = nsides
! allocate arrays to store coordinates
!
allocate(ids(cm(1)))
allocate(lev(cm(1)))
allocate(ref(cm(1)))
allocate(cor(cm(1),cm(2)))
allocate(bnd(dm(1),dm(2),dm(3)))
! iterate over all data blocks and fill in the arrays
!
l = 1
pdata => list_data
do while(associated(pdata))
! fill in the IDs array
!
ids(l) = pdata%meta%id
! fill in the level array
!
lev(l) = pdata%meta%level
! fill in the refinement flag
!
ref(l) = pdata%meta%refine
! fill in the coordinate array
!
cor(l,:) = pdata%meta%coords(:)
! fill in the bounds array
!
bnd(l,1,1) = pdata%meta%xmin
bnd(l,1,2) = pdata%meta%xmax
bnd(l,2,1) = pdata%meta%ymin
bnd(l,2,2) = pdata%meta%ymax
#if NDIMS == 3
bnd(l,3,1) = pdata%meta%zmin
bnd(l,3,2) = pdata%meta%zmax
#endif /* NDIMS == 3 */
l = l + 1
pdata => pdata%next
end do
! write the arrays to the HDF5 file
!
call write_array(gid, 'ids' , cm(1), ids)
call write_array(gid, 'levels', cm(1), lev)
call write_array(gid, 'refine', cm(1), ref)
call write_array(gid, 'coords', cm(:), cor)
call write_array(gid, 'bounds', dm(:), bnd)
call write_array(gid, 'dx' , am(1), adx(1:maxlev))
call write_array(gid, 'dy' , am(1), ady(1:maxlev))
call write_array(gid, 'dz' , am(1), adz(1:maxlev))
! deallocate temporary arrays
!
if (allocated(ids)) deallocate(ids)
if (allocated(lev)) deallocate(lev)
if (allocated(ref)) deallocate(ref)
if (allocated(cor)) deallocate(cor)
if (allocated(bnd)) deallocate(bnd)
end if ! dblocks > 0
! close the attribute group
!
call h5gclose_f(gid, err)
! check if the group has been closed successfuly
!
if (err .gt. 0) then
! print error about the problem with closing the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the group!"
end if
else
! print error about the problem with creating the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create the group!"
end if
!-------------------------------------------------------------------------------
!
end subroutine write_coordinates_h5
!
!===============================================================================
!
! subroutine WRITE_PRIMITIVE_VARIABLES_H5:
! ---------------------------------------
!
! Subroutine groups each primitive variable from all data blocks and writes
! it as an array in the HDF5 dataset connected to the input HDF file
! identifier.
!
! Arguments:
!
! fid - the HDF5 file identifier;
!
!===============================================================================
!
subroutine write_primitive_variables_h5(fid)
! references to other modules
!
use blocks , only : block_data, list_data
use blocks , only : get_dblocks
use coordinates , only : ni => ncells, nn => bcells
use coordinates , only : nb, ne
use equations , only : nv, pvars
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5gcreate_f, h5gclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t), intent(in) :: fid
! HDF5 variables
!
integer(hid_t) :: gid
integer(hsize_t) :: dm(4) = 1
! local variables
!
integer :: err
integer(kind=4) :: l, n
integer(kind=4) :: il, jl, kl = 1
integer(kind=4) :: iu, ju, ku = 1
! local allocatable arrays
!
real(kind=8), dimension(:,:,:,:), allocatable :: qarr
! local pointers
!
type(block_data), pointer :: pdata
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_primitive_variables_h5()'
!
!-------------------------------------------------------------------------------
!
! create a group to store variables
!
call h5gcreate_f(fid, 'variables', gid, err)
! check if the group was created successfuly
!
if (err >= 0) then
! store variables only if there is at least one data block associated with
! the current process
!
if (get_dblocks() > 0) then
! prepare dimensions and index limits
!
dm(1) = get_dblocks()
if (with_ghosts) then
dm(2) = nn
dm(3) = nn
#if NDIMS == 3
dm(4) = nn
#endif /* NDIMS == 3 */
il = 1
jl = 1
#if NDIMS == 3
kl = 1
#endif /* NDIMS == 3 */
iu = nn
ju = nn
#if NDIMS == 3
ku = nn
#endif /* NDIMS == 3 */
else
dm(2) = ni
dm(3) = ni
#if NDIMS == 3
dm(4) = ni
#endif /* NDIMS == 3 */
il = nb
jl = nb
#if NDIMS == 3
kl = nb
#endif /* NDIMS == 3 */
iu = ne
ju = ne
#if NDIMS == 3
ku = ne
#endif /* NDIMS == 3 */
end if
! allocate array to group a variable from all data blocks
!
allocate(qarr(dm(1),dm(2),dm(3),dm(4)))
! iterate over all variables
!
do n = 1, nv
! reset the block counter
!
l = 0
! assosiate the block pointer with the first data block on the list
!
pdata => list_data
! iterate over all data blocks and copy the variable from each of them to
! the allocate array
!
do while(associated(pdata))
! increase the data block counter
!
l = l + 1
! copy the variable from the current data block
!
qarr(l,1:dm(2),1:dm(3),1:dm(4)) = pdata%q(n,il:iu,jl:ju,kl:ku)
! assign the pointer with the next data block on the list
!
pdata => pdata%next
end do ! pdata=>list_data
! write the variable array to the HDF5 file
!
call write_array(gid, trim(pvars(n)), dm, qarr)
end do ! n = 1, nv
! deallocate allocatable array
!
if (allocated(qarr)) deallocate(qarr)
end if ! dblocks > 0
! close the variable group
!
call h5gclose_f(gid, err)
! check if the group has been closed successfuly
!
if (err > 0) then
! print error about the problem with closing the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the group!"
end if
else ! error with creating a group
! print error about the problem with creating the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create the group!"
end if
!-------------------------------------------------------------------------------
!
end subroutine write_primitive_variables_h5
!
!===============================================================================
!
! subroutine WRITE_CONSERVATIVE_VARIABLES_H5:
! ------------------------------------------
!
! Subroutine groups each conservative variable from all data blocks and writes
! it as an array in the HDF5 dataset connected to the input HDF file
! identifier.
!
! Arguments:
!
! fid - the HDF5 file identifier;
!
!===============================================================================
!
subroutine write_conservative_variables_h5(fid)
! references to other modules
!
use blocks , only : block_data, list_data
use blocks , only : get_dblocks
use coordinates , only : ni => ncells, nn => bcells
use coordinates , only : nb, ne
use equations , only : nv, cvars
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5gcreate_f, h5gclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t), intent(in) :: fid
! HDF5 variables
!
integer(hid_t) :: gid
integer(hsize_t) :: dm(4) = 1
! local variables
!
integer :: err
integer(kind=4) :: l, n
integer(kind=4) :: il, jl, kl = 1
integer(kind=4) :: iu, ju, ku = 1
! local allocatable arrays
!
real(kind=8), dimension(:,:,:,:), allocatable :: qarr
! local pointers
!
type(block_data), pointer :: pdata
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_conservative_variables_h5()'
!
!-------------------------------------------------------------------------------
!
! create a group to store variables
!
call h5gcreate_f(fid, 'variables', gid, err)
! check if the group was created successfuly
!
if (err >= 0) then
! store variables only if there is at least one data block associated with
! the current process
!
if (get_dblocks() > 0) then
! prepare dimensions and index limits
!
dm(1) = get_dblocks()
if (with_ghosts) then
dm(2) = nn
dm(3) = nn
#if NDIMS == 3
dm(4) = nn
#endif /* NDIMS == 3 */
il = 1
jl = 1
#if NDIMS == 3
kl = 1
#endif /* NDIMS == 3 */
iu = nn
ju = nn
#if NDIMS == 3
ku = nn
#endif /* NDIMS == 3 */
else
dm(2) = ni
dm(3) = ni
#if NDIMS == 3
dm(4) = ni
#endif /* NDIMS == 3 */
il = nb
jl = nb
#if NDIMS == 3
kl = nb
#endif /* NDIMS == 3 */
iu = ne
ju = ne
#if NDIMS == 3
ku = ne
#endif /* NDIMS == 3 */
end if
! allocate array to group a variable from all data blocks
!
allocate(qarr(dm(1),dm(2),dm(3),dm(4)))
! iterate over all variables
!
do n = 1, nv
! reset the block counter
!
l = 0
! assosiate the block pointer with the first data block on the list
!
pdata => list_data
! iterate over all data blocks and copy the variable from each of them to
! the allocate array
!
do while(associated(pdata))
! increase the data block counter
!
l = l + 1
! copy the variable from the current data block
!
qarr(l,1:dm(2),1:dm(3),1:dm(4)) = pdata%u(n,il:iu,jl:ju,kl:ku)
! assign the pointer with the next data block on the list
!
pdata => pdata%next
end do ! pdata=>list_data
! write the variable array to the HDF5 file
!
call write_array(gid, trim(cvars(n)), dm, qarr)
end do ! n = 1, nv
! deallocate allocatable array
!
if (allocated(qarr)) deallocate(qarr)
end if ! dblocks > 0
! close the variable group
!
call h5gclose_f(gid, err)
! check if the group has been closed successfuly
!
if (err > 0) then
! print error about the problem with closing the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the group!"
end if
else ! error with creating a group
! print error about the problem with creating the group
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create the group!"
end if
!-------------------------------------------------------------------------------
!
end subroutine write_conservative_variables_h5
!
!===============================================================================
!
! WRITE_ATTRIBUTE SUBROUTINES
!
!===============================================================================
!
! subroutine WRITE_SCALAR_ATTRIBUTE_STRING_H5:
! --------------------------------------------
!
! Subroutine stores a value of the string attribute in the group provided
! by an identifier and the attribute name.
!
! Arguments:
!
! gid - the group identifier to which the attribute should be linked;
! aname - the attribute name;
! avalue - the attribute value;
!
!===============================================================================
!
subroutine write_scalar_attribute_string_h5(gid, aname, avalue)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_CHARACTER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f
use hdf5 , only : h5tcopy_f, h5tset_size_f, h5tclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*), intent(in) :: aname
character(len=*), intent(in) :: avalue
! local variables
!
integer(hid_t) :: sid, aid, atype
integer(hsize_t) :: alen
integer(hsize_t), dimension(1) :: am = (/ 1 /)
integer :: ierr
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_scalar_attribute_string_h5()'
!
!-------------------------------------------------------------------------------
!
! copy the attribute type and set its size
!
call h5tcopy_f(H5T_NATIVE_CHARACTER, atype, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot copy type for attribute :" // trim(aname)
return
end if
! get the string length
!
alen = len(trim(avalue))
if (alen <= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "String attribute has wrong length:" // trim(aname)
return
end if
! set the attribute type size
!
call h5tset_size_f(atype, alen, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot set the type size for attribute :" // trim(aname)
return
end if
! create space for the attribute value
!
call h5screate_simple_f(1, am, sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for attribute :" // trim(aname)
return
end if
! create the attribute in the given group
!
call h5acreate_f(gid, aname, atype, sid, aid, ierr)
if (ierr == 0) then
! write the attribute data
!
call h5awrite_f(aid, atype, trim(avalue), am, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write the attribute data in :" // trim(aname)
end if
! close the attribute
!
call h5aclose_f(aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close attribute :" // trim(aname)
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create attribute :" // trim(aname)
end if
! release the space
!
call h5sclose_f(sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for attribute :" // trim(aname)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_scalar_attribute_string_h5
!
!===============================================================================
!
! subroutine WRITE_SCALAR_ATTRIBUTE_INTEGER_H5:
! --------------------------------------------
!
! Subroutine stores a value of the integer attribute in the group provided
! by an identifier and the attribute name.
!
! Arguments:
!
! gid - the group identifier to which the attribute should be linked;
! aname - the attribute name;
! avalue - the attribute value;
!
!===============================================================================
!
subroutine write_scalar_attribute_integer_h5(gid, aname, avalue)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*), intent(in) :: aname
integer(kind=4) , intent(in) :: avalue
! local variables
!
integer(hid_t) :: sid, aid
integer(hsize_t), dimension(1) :: am = (/ 1 /)
integer :: ierr
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_scalar_attribute_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! create space for the attribute value
!
call h5screate_simple_f(1, am, sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for attribute :" // trim(aname)
return
end if
! create the attribute in the given group
!
call h5acreate_f(gid, aname, H5T_NATIVE_INTEGER, sid, aid, ierr)
if (ierr == 0) then
! write the attribute data
!
call h5awrite_f(aid, H5T_NATIVE_INTEGER, avalue, am, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write the attribute data in :" // trim(aname)
end if
! close the attribute
!
call h5aclose_f(aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close attribute :" // trim(aname)
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create attribute :" // trim(aname)
end if
! release the space
!
call h5sclose_f(sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for attribute :" // trim(aname)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_scalar_attribute_integer_h5
!
!===============================================================================
!
! subroutine WRITE_SCALAR_ATTRIBUTE_DOUBLE_H5:
! -------------------------------------------
!
! Subroutine stores a value of the double precision attribute in the group
! provided by an identifier and the attribute name.
!
! Arguments:
!
! gid - the group identifier to which the attribute should be linked;
! aname - the attribute name;
! avalue - the attribute value;
!
!===============================================================================
!
subroutine write_scalar_attribute_double_h5(gid, aname, avalue)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_DOUBLE
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! attribute arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*), intent(in) :: aname
real(kind=8) , intent(in) :: avalue
! local variables
!
integer(hid_t) :: sid, aid
integer(hsize_t), dimension(1) :: am = (/ 1 /)
integer :: ierr
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_scalar_attribute_double_h5()'
!
!-------------------------------------------------------------------------------
!
! create space for the attribute value
!
call h5screate_simple_f(1, am, sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for attribute :" // trim(aname)
return
end if
! create the attribute in the given group
!
call h5acreate_f(gid, aname, H5T_NATIVE_DOUBLE, sid, aid, ierr)
if (ierr == 0) then
! write the attribute data
!
call h5awrite_f(aid, H5T_NATIVE_DOUBLE, avalue, am, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write the attribute data in :" // trim(aname)
end if
! close the attribute
!
call h5aclose_f(aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close attribute :" // trim(aname)
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create attribute :" // trim(aname)
end if
! release the space
!
call h5sclose_f(sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for attribute :" // trim(aname)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_scalar_attribute_double_h5
!
!===============================================================================
!
! subroutine WRITE_VECTOR_ATTRIBUTE_INTEGER_H5:
! --------------------------------------------
!
! Subroutine stores a vector of the integer attribute in the group provided
! by an identifier and the attribute name.
!
! Arguments:
!
! gid - the group identifier to which the attribute should be linked;
! aname - the attribute name;
! avalue - the attribute values;
!
!===============================================================================
!
subroutine write_vector_attribute_integer_h5(gid, aname, avalue)
! import procedures and variables from other modules
!
use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_INTEGER
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! attribute arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: aname
integer(kind=4) , dimension(:), intent(in) :: avalue
! local variables
!
integer(hid_t) :: sid, aid
integer(hsize_t), dimension(1) :: am = (/ 1 /)
integer :: ierr
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_vector_attribute_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! set the proper attribute length
!
am(1) = size(avalue)
! create space for the attribute value
!
call h5screate_simple_f(1, am, sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for attribute :" // trim(aname)
return
end if
! create the attribute in the given group
!
call h5acreate_f(gid, aname, H5T_NATIVE_INTEGER, sid, aid, ierr)
if (ierr == 0) then
! write the attribute data
!
call h5awrite_f(aid, H5T_NATIVE_INTEGER, avalue, am, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write the attribute data in :" // trim(aname)
end if
! close the attribute
!
call h5aclose_f(aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close attribute :" // trim(aname)
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create attribute :" // trim(aname)
end if
! release the space
!
call h5sclose_f(sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for attribute :" // trim(aname)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_vector_attribute_integer_h5
!
!===============================================================================
!
! subroutine WRITE_ARRAY_ATTRIBUTE_LONG_H5:
! ----------------------------------------
!
! Subroutine stores a 2D array of the integer attribute in the group provided
! by an identifier and the attribute name.
!
! Arguments:
!
! gid - the group identifier to which the attribute should be linked;
! aname - the attribute name;
! avalue - the attribute values;
!
!===============================================================================
!
subroutine write_array_attribute_long_h5(gid, aname, avalue)
! import procedures and variables from other modules
!
use hdf5 , only : hid_t, hsize_t, H5T_STD_I64LE
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! attribute arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: aname
integer(kind=8) , dimension(:,:), intent(in) :: avalue
! local variables
!
integer(hid_t) :: sid, aid
integer(hsize_t), dimension(2) :: am = (/ 1, 1 /)
integer :: ierr
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_array_attribute_long_h5()'
!
!-------------------------------------------------------------------------------
!
! set the proper attribute length
!
am(1) = size(avalue, 1)
am(2) = size(avalue, 2)
! create space for the attribute value
!
call h5screate_simple_f(2, am, sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for attribute :" // trim(aname)
return
end if
! create the attribute in the given group
!
call h5acreate_f(gid, aname, H5T_STD_I64LE, sid, aid, ierr)
if (ierr == 0) then
! write the attribute data
!
call h5awrite_f(aid, H5T_STD_I64LE, avalue, am, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write the attribute data in :" // trim(aname)
end if
! close the attribute
!
call h5aclose_f(aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close attribute :" // trim(aname)
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create attribute :" // trim(aname)
end if
! release the space
!
call h5sclose_f(sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for attribute :" // trim(aname)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_array_attribute_long_h5
!
!===============================================================================
!
! subroutine WRITE_ARRAY_ATTRIBUTE_COMPLEX_H5:
! -------------------------------------------
!
! Subroutine stores a 2D array of the double precision complex attribute
! in the group provided by an identifier and the attribute name.
!
! Arguments:
!
! gid - the group identifier to which the attribute should be linked;
! aname - the attribute name;
! avalue - the attribute values;
!
!===============================================================================
!
subroutine write_array_attribute_complex_h5(gid, aname, avalue)
! import procedures and variables from other modules
!
use hdf5 , only : hid_t, hsize_t, H5T_NATIVE_DOUBLE
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5acreate_f, h5awrite_f, h5aclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! attribute arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: aname
complex(kind=8) , dimension(:,:), intent(in) :: avalue
! local variables
!
integer(hid_t) :: sid, aid
integer(hsize_t), dimension(3) :: am = (/ 1, 1, 1 /)
integer :: ierr
! allocatable arrays
!
real(kind=8), dimension(:,:,:), allocatable :: tvalue
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_array_attribute_complex_h5()'
!
!-------------------------------------------------------------------------------
!
! set the proper attribute length
!
am(1) = 2
am(2) = size(avalue, 1)
am(3) = size(avalue, 2)
! create space for the attribute value
!
call h5screate_simple_f(3, am, sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for attribute :" // trim(aname)
return
end if
! allocate space for temporary array and copy the input array values
!
allocate(tvalue(am(1),am(2),am(3)))
tvalue(1,:,:) = dreal(avalue(:,:))
tvalue(2,:,:) = dimag(avalue(:,:))
! create the attribute in the given group
!
call h5acreate_f(gid, aname, H5T_NATIVE_DOUBLE, sid, aid, ierr)
if (ierr == 0) then
! write the attribute data
!
call h5awrite_f(aid, H5T_NATIVE_DOUBLE, tvalue, am, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write the attribute data in :" // trim(aname)
end if
! close the attribute
!
call h5aclose_f(aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close attribute :" // trim(aname)
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create attribute :" // trim(aname)
end if
! deallocate temporary array
!
deallocate(tvalue)
! release the space
!
call h5sclose_f(sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for attribute :" // trim(aname)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_array_attribute_complex_h5
!===============================================================================
!
! READ_ATTRIBUTE SUBROUTINES
!
!===============================================================================
!
! subroutine READ_SCALAR_ATTRIBUTE_INTEGER_H5:
! -------------------------------------------
!
! Subroutine reads a value of the integer attribute provided by the group
! identifier to which it is linked and its name.
!
! Arguments:
!
! gid - the group identifier to which the attribute is linked;
! aname - the attribute name;
! avalue - the attribute value;
!
!===============================================================================
!
subroutine read_scalar_attribute_integer_h5(gid, aname, avalue)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5aexists_by_name_f
use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! attribute arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*), intent(in) :: aname
integer(kind=4) , intent(inout) :: avalue
! local variables
!
logical :: exists = .false.
integer(hid_t) :: aid
integer(hsize_t), dimension(1) :: am = (/ 1 /)
integer :: ierr
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_scalar_attribute_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! check if the attribute exists in the group provided by gid
!
call h5aexists_by_name_f(gid, '.', aname, exists, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot check if attribute exists :" // trim(aname)
return
end if
if (.not. exists) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Attribute does not exist :" // trim(aname)
return
end if
! open the attribute
!
call h5aopen_by_name_f(gid, '.', aname, aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open attribute :" // trim(aname)
return
end if
! read attribute value
!
call h5aread_f(aid, H5T_NATIVE_INTEGER, avalue, am(:), ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot read attribute :" // trim(aname)
end if
! close the attribute
!
call h5aclose_f(aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close attribute :" // trim(aname)
return
end if
!-------------------------------------------------------------------------------
!
end subroutine read_scalar_attribute_integer_h5
!
!===============================================================================
!
! subroutine READ_SCALAR_ATTRIBUTE_DOUBLE_H5:
! ------------------------------------------
!
! Subroutine reads a value of the double precision attribute provided by
! the group identifier to which it is linked and its name.
!
! Arguments:
!
! gid - the group identifier to which the attribute is linked;
! aname - the attribute name;
! avalue - the attribute value;
!
!===============================================================================
!
subroutine read_scalar_attribute_double_h5(gid, aname, avalue)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_DOUBLE
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5aexists_by_name_f
use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! attribute arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*), intent(in) :: aname
real(kind=8) , intent(inout) :: avalue
! local variables
!
logical :: exists = .false.
integer(hid_t) :: aid
integer(hsize_t), dimension(1) :: am = (/ 1 /)
integer :: ierr
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_scalar_attribute_double_h5()'
!
!-------------------------------------------------------------------------------
!
! check if the attribute exists in the group provided by gid
!
call h5aexists_by_name_f(gid, '.', aname, exists, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot check if attribute exists :" // trim(aname)
return
end if
if (.not. exists) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Attribute does not exist :" // trim(aname)
return
end if
! open the attribute
!
call h5aopen_by_name_f(gid, '.', aname, aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open attribute :" // trim(aname)
return
end if
! read attribute value
!
call h5aread_f(aid, H5T_NATIVE_DOUBLE, avalue, am(:), ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot read attribute :" // trim(aname)
end if
! close the attribute
!
call h5aclose_f(aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close attribute :" // trim(aname)
return
end if
!-------------------------------------------------------------------------------
!
end subroutine read_scalar_attribute_double_h5
!
!===============================================================================
!
! subroutine READ_ARRAY_ATTRIBUTE_LONG_H5:
! ---------------------------------------
!
! Subroutine reads a 2D array of the integer attribute provided by the group
! identifier to which it is linked and its name.
!
! Arguments:
!
! gid - the group identifier to which the attribute is linked;
! aname - the attribute name;
! avalue - the attribute value;
!
!===============================================================================
!
subroutine read_array_attribute_long_h5(gid, aname, avalue)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_STD_I64LE
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5aexists_by_name_f, h5aget_space_f
use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f
use hdf5 , only : h5sclose_f, h5sget_simple_extent_dims_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! attribute arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: aname
integer(kind=8) , dimension(:,:), intent(inout) :: avalue
! local variables
!
logical :: exists = .false.
integer(hid_t) :: aid, sid
integer(hsize_t), dimension(2) :: am, bm
integer :: ierr
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_array_attribute_long_h5()'
!
!-------------------------------------------------------------------------------
!
! check if the attribute exists in the group provided by gid
!
call h5aexists_by_name_f(gid, '.', aname, exists, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot check if attribute exists :" // trim(aname)
return
end if
if (.not. exists) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Attribute does not exist :" // trim(aname)
return
end if
! open the attribute
!
call h5aopen_by_name_f(gid, '.', aname, aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open attribute :" // trim(aname)
return
end if
! get the attribute space
!
call h5aget_space_f(aid, sid, ierr)
if (ierr == 0) then
call h5sget_simple_extent_dims_f(sid, am, bm, ierr)
if (ierr /= 2) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot get attribute dimensions :" // trim(aname)
end if
call h5sclose_f(sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the attribute space :" // trim(aname)
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot get the attribute space :" // trim(aname)
return
end if
! check if the output array is large enough
!
if (am(1) * am(2) > size(avalue)) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Attribute too large for output argument :" // trim(aname)
return
end if
! read attribute value
!
call h5aread_f(aid, H5T_STD_I64LE, avalue, am(:), ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot read attribute :" // trim(aname)
end if
! close the attribute
!
call h5aclose_f(aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close attribute :" // trim(aname)
return
end if
!-------------------------------------------------------------------------------
!
end subroutine read_array_attribute_long_h5
!
!===============================================================================
!
! subroutine READ_ARRAY_ATTRIBUTE_COMPLEX_H5:
! ------------------------------------------
!
! Subroutine reads a 2D array of the double precision complex attribute
! provided by the group identifier to which it is linked and its name.
!
! Arguments:
!
! gid - the group identifier to which the attribute is linked;
! aname - the attribute name;
! avalue - the attribute value;
!
!===============================================================================
!
subroutine read_array_attribute_complex_h5(gid, aname, avalue)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_DOUBLE
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5aexists_by_name_f, h5aget_space_f
use hdf5 , only : h5aopen_by_name_f, h5aread_f, h5aclose_f
use hdf5 , only : h5sclose_f, h5sget_simple_extent_dims_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! attribute arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: aname
complex(kind=8) , dimension(:,:), intent(inout) :: avalue
! local variables
!
logical :: exists = .false.
integer(hid_t) :: aid, sid
integer(hsize_t), dimension(3) :: am, bm
integer :: ierr
! local allocatable arrays
!
real(kind=8), dimension(:,:,:), allocatable :: tvalue
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_array_attribute_complex_h5()'
!
!-------------------------------------------------------------------------------
!
! check if the attribute exists in the group provided by gid
!
call h5aexists_by_name_f(gid, '.', aname, exists, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot check if attribute exists :" // trim(aname)
return
end if
if (.not. exists) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Attribute does not exist :" // trim(aname)
return
end if
! open the attribute
!
call h5aopen_by_name_f(gid, '.', aname, aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open attribute :" // trim(aname)
return
end if
! get the attribute space
!
call h5aget_space_f(aid, sid, ierr)
if (ierr == 0) then
call h5sget_simple_extent_dims_f(sid, am, bm, ierr)
if (ierr /= 3) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot get attribute dimensions :" // trim(aname)
end if
call h5sclose_f(sid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close the attribute space :" // trim(aname)
end if
else
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot get the attribute space :" // trim(aname)
return
end if
! allocate temporary array for attribute
!
allocate(tvalue(am(1),am(2),am(3)))
! check if the output array is large enough
!
if (am(1) * am(2) * am(3) > size(tvalue)) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Attribute too large for output argument :" // trim(aname)
return
end if
! read attribute value
!
call h5aread_f(aid, H5T_NATIVE_DOUBLE, tvalue, am(:), ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot read attribute :" // trim(aname)
end if
! copy array to complex one
!
avalue(:,:) = cmplx(tvalue(1,:,:), tvalue(2,:,:), kind=8)
! deallocate temporary array
!
deallocate(tvalue)
! close the attribute
!
call h5aclose_f(aid, ierr)
if (ierr /= 0) then
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close attribute :" // trim(aname)
return
end if
!-------------------------------------------------------------------------------
!
end subroutine read_array_attribute_complex_h5
!
!===============================================================================
!
! WRITE_ARRAY SUBROUTINES
!
!===============================================================================
!
! subroutine WRITE_1D_ARRAY_INTEGER_H5:
! ------------------------------------
!
! Subroutine stores a one-dimensional integer array in a group specified by
! identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine write_1d_array_integer_h5(gid, name, ln, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f
use hdf5 , only : h5pset_chunk_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t) , intent(in) :: ln
integer(kind=4) , dimension(:), intent(in) :: var
! HDF5 object identifiers
!
integer(hid_t) :: sid, did
! array dimensions
!
integer(hsize_t), dimension(1) :: dm
! procedure return value
!
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_1d_array_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! substitute array dimensions
!
dm(1) = ln
! create a space for the array
!
call h5screate_simple_f(1, dm(1:1), sid, iret)
! check if the space has been created successfuly, if not quit
!
if (iret < 0) then
! print error about the problem with creating the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for dataset: " // trim(name)
! quit the subroutine
!
return
end if
! set the chunk size
!
call h5pset_chunk_f(pid, 1, dm(1:1), iret)
! check if the chunk size has been set properly
!
if (iret > 0) then
! print error about the problem with setting the chunk size
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot set the size of the chunk!"
end if
! create the dataset
!
call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret, pid)
! check if the dataset has been created successfuly
!
if (iret >= 0) then
! write the dataset data
!
call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:), dm(1:1), iret, sid)
! check if the dataset has been written successfuly
!
if (iret > 0) then
! print error about the problem with writing down the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
else
! print error about the problem with creating the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create dataset: " // trim(name)
end if
! release the space
!
call h5sclose_f(sid, iret)
! check if the space has been released successfuly
!
if (iret > 0) then
! print error about the problem with closing the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_1d_array_integer_h5
!
!===============================================================================
!
! subroutine WRITE_2D_ARRAY_INTEGER_H5:
! ------------------------------------
!
! Subroutine stores a two-dimensional integer array in a group specified by
! identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine write_2d_array_integer_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f
use hdf5 , only : h5pset_chunk_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(2) , intent(in) :: dm
integer(kind=4) , dimension(:,:), intent(in) :: var
! HDF5 object identifiers
!
integer(hid_t) :: sid, did
! procedure return value
!
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_2d_array_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! create a space for the array
!
call h5screate_simple_f(2, dm(1:2), sid, iret)
! check if the space has been created successfuly, if not quit
!
if (iret < 0) then
! print error about the problem with creating the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for dataset: " // trim(name)
! quit the subroutine
!
return
end if
! set the chunk size
!
call h5pset_chunk_f(pid, 2, dm(1:2), iret)
! check if the chunk size has been set properly
!
if (iret > 0) then
! print error about the problem with setting the chunk size
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot set the size of the chunk!"
end if
! create the dataset
!
call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret, pid)
! check if the dataset has been created successfuly
!
if (iret >= 0) then
! write the dataset data
!
call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:,:), dm(1:2), iret, sid)
! check if the dataset has been written successfuly
!
if (iret > 0) then
! print error about the problem with writing down the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
else
! print error about the problem with creating the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create dataset: " // trim(name)
end if
! release the space
!
call h5sclose_f(sid, iret)
! check if the space has been released successfuly
!
if (iret > 0) then
! print error about the problem with closing the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_2d_array_integer_h5
#if NDIMS == 2
!
!===============================================================================
!
! subroutine WRITE_3D_ARRAY_INTEGER_H5:
! ------------------------------------
!
! Subroutine stores a three-dimensional integer array in a group specified by
! identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine write_3d_array_integer_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f
use hdf5 , only : h5pset_chunk_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(3) , intent(in) :: dm
integer(kind=4) , dimension(:,:,:), intent(in) :: var
! HDF5 object identifiers
!
integer(hid_t) :: sid, did
! procedure return value
!
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_3d_array_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! create a space for the array
!
call h5screate_simple_f(3, dm(1:3), sid, iret)
! check if the space has been created successfuly, if not quit
!
if (iret < 0) then
! print error about the problem with creating the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for dataset: " // trim(name)
! quit the subroutine
!
return
end if
! set the chunk size
!
call h5pset_chunk_f(pid, 3, dm(1:3), iret)
! check if the chunk size has been set properly
!
if (iret > 0) then
! print error about the problem with setting the chunk size
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot set the size of the chunk!"
end if
! create the dataset
!
call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret, pid)
! check if the dataset has been created successfuly
!
if (iret >= 0) then
! write the dataset data
!
call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:,:,:), dm(1:3), iret, sid)
! check if the dataset has been written successfuly
!
if (iret > 0) then
! print error about the problem with writing down the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
else
! print error about the problem with creating the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create dataset: " // trim(name)
end if
! release the space
!
call h5sclose_f(sid, iret)
! check if the space has been released successfuly
!
if (iret > 0) then
! print error about the problem with closing the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_3d_array_integer_h5
#endif /* NDIMS == 2 */
!
!===============================================================================
!
! subroutine WRITE_4D_ARRAY_INTEGER_H5:
! ------------------------------------
!
! Subroutine stores a four-dimensional integer array in a group specified by
! identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine write_4d_array_integer_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f
use hdf5 , only : h5pset_chunk_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(4) , intent(in) :: dm
integer(kind=4) , dimension(:,:,:,:), intent(in) :: var
! HDF5 object identifiers
!
integer(hid_t) :: sid, did
! procedure return value
!
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_4d_array_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! create a space for the array
!
call h5screate_simple_f(4, dm(1:4), sid, iret)
! check if the space has been created successfuly, if not quit
!
if (iret < 0) then
! print error about the problem with creating the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for dataset: " // trim(name)
! quit the subroutine
!
return
end if
! set the chunk size
!
call h5pset_chunk_f(pid, 4, dm(1:4), iret)
! check if the chunk size has been set properly
!
if (iret > 0) then
! print error about the problem with setting the chunk size
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot set the size of the chunk!"
end if
! create the dataset
!
call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret, pid)
! check if the dataset has been created successfuly
!
if (iret >= 0) then
! write the dataset data
!
call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:), dm(1:4), iret, sid)
! check if the dataset has been written successfuly
!
if (iret > 0) then
! print error about the problem with writing down the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
else
! print error about the problem with creating the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create dataset: " // trim(name)
end if
! release the space
!
call h5sclose_f(sid, iret)
! check if the space has been released successfuly
!
if (iret > 0) then
! print error about the problem with closing the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_4d_array_integer_h5
#if NDIMS == 3
!
!===============================================================================
!
! subroutine WRITE_5D_ARRAY_INTEGER_H5:
! ------------------------------------
!
! Subroutine stores a five-dimensional integer array in a group specified by
! identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine write_5d_array_integer_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f
use hdf5 , only : h5pset_chunk_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(5) , intent(in) :: dm
integer(kind=4) , dimension(:,:,:,:,:), intent(in) :: var
! HDF5 object identifiers
!
integer(hid_t) :: sid, did
! procedure return value
!
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_5d_array_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! create a space for the array
!
call h5screate_simple_f(5, dm(1:5), sid, iret)
! check if the space has been created successfuly, if not quit
!
if (iret < 0) then
! print error about the problem with creating the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for dataset: " // trim(name)
! quit the subroutine
!
return
end if
! set the chunk size
!
call h5pset_chunk_f(pid, 5, dm(1:5), iret)
! check if the chunk size has been set properly
!
if (iret > 0) then
! print error about the problem with setting the chunk size
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot set the size of the chunk!"
end if
! create the dataset
!
call h5dcreate_f(gid, name, H5T_NATIVE_INTEGER, sid, did, iret, pid)
! check if the dataset has been created successfuly
!
if (iret >= 0) then
! write the dataset data
!
call h5dwrite_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:,:), dm(1:5) &
, iret, sid)
! check if the dataset has been written successfuly
!
if (iret > 0) then
! print error about the problem with writing down the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
else
! print error about the problem with creating the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create dataset: " // trim(name)
end if
! release the space
!
call h5sclose_f(sid, iret)
! check if the space has been released successfuly
!
if (iret > 0) then
! print error about the problem with closing the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_5d_array_integer_h5
#endif /* NDIMS == 3 */
!
!===============================================================================
!
! subroutine WRITE_1D_ARRAY_DOUBLE_H5:
! -----------------------------------
!
! Subroutine stores a one-dimensional double precision array in a group
! specified by identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine write_1d_array_double_h5(gid, name, ln, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_DOUBLE
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f
use hdf5 , only : h5pset_chunk_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t) , intent(in) :: ln
real(kind=8) , dimension(:), intent(in) :: var
! HDF5 object identifiers
!
integer(hid_t) :: sid, did
! array dimensions
!
integer(hsize_t), dimension(1) :: dm
! procedure return value
!
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_1d_array_double_h5()'
!
!-------------------------------------------------------------------------------
!
! substitute array dimensions
!
dm(1) = ln
! create a space for the array
!
call h5screate_simple_f(1, dm(1:1), sid, iret)
! check if the space has been created successfuly, if not quit
!
if (iret < 0) then
! print error about the problem with creating the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for dataset: " // trim(name)
! quit the subroutine
!
return
end if
! set the chunk size
!
call h5pset_chunk_f(pid, 1, dm(1:1), iret)
! check if the chunk size has been set properly
!
if (iret > 0) then
! print error about the problem with setting the chunk size
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot set the size of the chunk!"
end if
! create the dataset
!
call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret, pid)
! check if the dataset has been created successfuly
!
if (iret >= 0) then
! write the dataset data
!
call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:), dm(1:1), iret, sid)
! check if the dataset has been written successfuly
!
if (iret > 0) then
! print error about the problem with writing down the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
else
! print error about the problem with creating the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create dataset: " // trim(name)
end if
! release the space
!
call h5sclose_f(sid, iret)
! check if the space has been released successfuly
!
if (iret > 0) then
! print error about the problem with closing the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_1d_array_double_h5
!
!===============================================================================
!
! subroutine WRITE_3D_ARRAY_DOUBLE_H5:
! -----------------------------------
!
! Subroutine stores a three-dimensional double precision array in a group
! specified by identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine write_3d_array_double_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_DOUBLE
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f
use hdf5 , only : h5pset_chunk_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(3) , intent(in) :: dm
real(kind=8) , dimension(:,:,:), intent(in) :: var
! HDF5 object identifiers
!
integer(hid_t) :: sid, did
! procedure return value
!
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_3d_array_double_h5()'
!
!-------------------------------------------------------------------------------
!
! create a space for the array
!
call h5screate_simple_f(3, dm(1:3), sid, iret)
! check if the space has been created successfuly, if not quit
!
if (iret < 0) then
! print error about the problem with creating the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for dataset: " // trim(name)
! quit the subroutine
!
return
end if
! set the chunk size
!
call h5pset_chunk_f(pid, 3, dm(1:3), iret)
! check if the chunk size has been set properly
!
if (iret > 0) then
! print error about the problem with setting the chunk size
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot set the size of the chunk!"
end if
! create the dataset
!
call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret, pid)
! check if the dataset has been created successfuly
!
if (iret >= 0) then
! write the dataset data
!
call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:,:,:), dm(1:3), iret, sid)
! check if the dataset has been written successfuly
!
if (iret > 0) then
! print error about the problem with writing down the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
else
! print error about the problem with creating the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create dataset: " // trim(name)
end if
! release the space
!
call h5sclose_f(sid, iret)
! check if the space has been released successfuly
!
if (iret > 0) then
! print error about the problem with closing the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_3d_array_double_h5
!
!===============================================================================
!
! subroutine WRITE_4D_ARRAY_DOUBLE_H5:
! ------------------------------------
!
! Subroutine stores a four-dimensional double precision array in a group
! specified by identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine write_4d_array_double_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_DOUBLE
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5screate_simple_f, h5sclose_f
use hdf5 , only : h5dcreate_f, h5dwrite_f, h5dclose_f
use hdf5 , only : h5pset_chunk_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(4) , intent(in) :: dm
real(kind=8) , dimension(:,:,:,:), intent(in) :: var
! HDF5 object identifiers
!
integer(hid_t) :: sid, did
! procedure return value
!
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::write_4d_array_double_h5()'
!
!-------------------------------------------------------------------------------
!
! create a space for the array
!
call h5screate_simple_f(4, dm(1:4), sid, iret)
! check if the space has been created successfuly, if not quit
!
if (iret < 0) then
! print error about the problem with creating the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create space for dataset: " // trim(name)
! quit the subroutine
!
return
end if
! set the chunk size
!
call h5pset_chunk_f(pid, 4, dm(1:4), iret)
! check if the chunk size has been set properly
!
if (iret > 0) then
! print error about the problem with setting the chunk size
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot set the size of the chunk!"
end if
! create the dataset
!
call h5dcreate_f(gid, name, H5T_NATIVE_DOUBLE, sid, did, iret, pid)
! check if the dataset has been created successfuly
!
if (iret >= 0) then
! write the dataset data
!
call h5dwrite_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:), dm(1:4), iret, sid)
! check if the dataset has been written successfuly
!
if (iret > 0) then
! print error about the problem with writing down the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot write dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
else
! print error about the problem with creating the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot create dataset: " // trim(name)
end if
! release the space
!
call h5sclose_f(sid, iret)
! check if the space has been released successfuly
!
if (iret > 0) then
! print error about the problem with closing the space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close space for dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine write_4d_array_double_h5
!
!===============================================================================
!
! READ_ARRAY SUBROUTINES
!
!===============================================================================
!
! subroutine READ_1D_ARRAY_INTEGER_H5:
! -----------------------------------
!
! Subroutine restores a one-dimensional integer array from a group specified
! by identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine read_1d_array_integer_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(1), intent(inout) :: dm
integer(kind=4) , dimension(:), intent(inout) :: var
! local variables
!
integer(hid_t) :: did
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_1d_array_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! open the dataset
!
call h5dopen_f(gid, name, did, iret)
! check if the dataset has been opened successfuly
!
if (iret < 0) then
! print error about the problem with opening the data space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open dataset: " // trim(name)
! quit the subroutine
!
return
end if
! read dataset data
!
call h5dread_f(did, H5T_NATIVE_INTEGER, var(:), dm(1:1), iret)
! check if the dataset has been read successfuly
!
if (iret > 0) then
! print error about the problem with reading the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot read dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine read_1d_array_integer_h5
!
!===============================================================================
!
! subroutine READ_2D_ARRAY_INTEGER_H5:
! -----------------------------------
!
! Subroutine restores a two-dimensional integer array from a group specified
! by identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine read_2d_array_integer_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(2) , intent(inout) :: dm
integer(kind=4) , dimension(:,:), intent(inout) :: var
! local variables
!
integer(hid_t) :: did
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_2d_array_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! open the dataset
!
call h5dopen_f(gid, name, did, iret)
! check if the dataset has been opened successfuly
!
if (iret < 0) then
! print error about the problem with opening the data space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open dataset: " // trim(name)
! quit the subroutine
!
return
end if
! read dataset data
!
call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:), dm(1:2), iret)
! check if the dataset has been read successfuly
!
if (iret > 0) then
! print error about the problem with reading the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot read dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine read_2d_array_integer_h5
#if NDIMS == 2
!
!===============================================================================
!
! subroutine READ_3D_ARRAY_INTEGER_H5:
! -----------------------------------
!
! Subroutine restores a three-dimensional integer array from a group specified
! by identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine read_3d_array_integer_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(3) , intent(inout) :: dm
integer(kind=4) , dimension(:,:,:), intent(inout) :: var
! local variables
!
integer(hid_t) :: did
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_3d_array_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! open the dataset
!
call h5dopen_f(gid, name, did, iret)
! check if the dataset has been opened successfuly
!
if (iret < 0) then
! print error about the problem with opening the data space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open dataset: " // trim(name)
! quit the subroutine
!
return
end if
! read dataset data
!
call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:,:), dm(1:3), iret)
! check if the dataset has been read successfuly
!
if (iret > 0) then
! print error about the problem with reading the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot read dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine read_3d_array_integer_h5
#endif /* NDIMS == 2 */
!
!===============================================================================
!
! subroutine READ_4D_ARRAY_INTEGER_H5:
! -----------------------------------
!
! Subroutine restores a four-dimensional integer array from a group specified
! by identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine read_4d_array_integer_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(4) , intent(inout) :: dm
integer(kind=4) , dimension(:,:,:,:), intent(inout) :: var
! local variables
!
integer(hid_t) :: did
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_4d_array_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! open the dataset
!
call h5dopen_f(gid, name, did, iret)
! check if the dataset has been opened successfuly
!
if (iret < 0) then
! print error about the problem with opening the data space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open dataset: " // trim(name)
! quit the subroutine
!
return
end if
! read dataset data
!
call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:), dm(1:4), iret)
! check if the dataset has been read successfuly
!
if (iret > 0) then
! print error about the problem with reading the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot read dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine read_4d_array_integer_h5
#if NDIMS == 3
!
!===============================================================================
!
! subroutine READ_5D_ARRAY_INTEGER_H5:
! -----------------------------------
!
! Subroutine restores a five-dimensional integer array from a group specified
! by identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine read_5d_array_integer_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_INTEGER
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(5) , intent(inout) :: dm
integer(kind=4) , dimension(:,:,:,:,:), intent(inout) :: var
! local variables
!
integer(hid_t) :: did
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_5d_array_integer_h5()'
!
!-------------------------------------------------------------------------------
!
! open the dataset
!
call h5dopen_f(gid, name, did, iret)
! check if the dataset has been opened successfuly
!
if (iret < 0) then
! print error about the problem with opening the data space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open dataset: " // trim(name)
! quit the subroutine
!
return
end if
! read dataset data
!
call h5dread_f(did, H5T_NATIVE_INTEGER, var(:,:,:,:,:), dm(1:5), iret)
! check if the dataset has been read successfuly
!
if (iret > 0) then
! print error about the problem with reading the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot read dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine read_5d_array_integer_h5
#endif /* NDIMS == 3 */
!
!===============================================================================
!
! subroutine READ_1D_ARRAY_DOUBLE_H5:
! ----------------------------------
!
! Subroutine restores a one-dimensional double precision array from a group
! specified by identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine read_1d_array_double_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_DOUBLE
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(1), intent(inout) :: dm
real(kind=8) , dimension(:), intent(inout) :: var
! local variables
!
integer(hid_t) :: did
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_1d_array_double_h5()'
!
!-------------------------------------------------------------------------------
!
! open the dataset
!
call h5dopen_f(gid, name, did, iret)
! check if the dataset has been opened successfuly
!
if (iret < 0) then
! print error about the problem with opening the data space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open dataset: " // trim(name)
! quit the subroutine
!
return
end if
! read dataset data
!
call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:), dm(1:1), iret)
! check if the dataset has been read successfuly
!
if (iret > 0) then
! print error about the problem with reading the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot read dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine read_1d_array_double_h5
!
!===============================================================================
!
! subroutine READ_4D_ARRAY_DOUBLE_H5:
! -----------------------------------
!
! Subroutine restores a four-dimensional double precision array from a group
! specified by identifier.
!
! Arguments:
!
! gid - the HDF5 group identifier
! name - the string name describing the array
! dm - the array dimensions
! value - the array values
!
!===============================================================================
!
subroutine read_4d_array_double_h5(gid, name, dm, var)
! import procedures and variables from other modules
!
use hdf5 , only : H5T_NATIVE_DOUBLE
use hdf5 , only : hid_t, hsize_t
use hdf5 , only : h5dopen_f, h5dread_f, h5dclose_f
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
integer(hid_t) , intent(in) :: gid
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(4) , intent(inout) :: dm
real(kind=8) , dimension(:,:,:,:), intent(inout) :: var
! local variables
!
integer(hid_t) :: did
integer :: iret
! local parameters
!
character(len=*), parameter :: loc = 'IO::read_4d_array_double_h5()'
!
!-------------------------------------------------------------------------------
!
! open the dataset
!
call h5dopen_f(gid, name, did, iret)
! check if the dataset has been opened successfuly
!
if (iret < 0) then
! print error about the problem with opening the data space
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot open dataset: " // trim(name)
! quit the subroutine
!
return
end if
! read dataset data
!
call h5dread_f(did, H5T_NATIVE_DOUBLE, var(:,:,:,:), dm(1:4), iret)
! check if the dataset has been read successfuly
!
if (iret > 0) then
! print error about the problem with reading the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot read dataset: " // trim(name)
end if
! close the dataset
!
call h5dclose_f(did, iret)
! check if the dataset has been closed successfuly
!
if (iret > 0) then
! print error about the problem with closing the dataset
!
write(error_unit,"('[',a,']: ',a)") trim(loc) &
, "Cannot close dataset: " // trim(name)
end if
!-------------------------------------------------------------------------------
!
end subroutine read_4d_array_double_h5
!
!===============================================================================
!
! 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()
! import procedures and variables from other modules
!
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
! local variables are not implicit by default
!
implicit none
! local pointers
!
type(block_data), pointer :: pdata
! local variables
!
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 */
! local arrays
!
integer, dimension(12) :: slab
! local parameters
!
integer, parameter :: xdmf = 101
!
!-------------------------------------------------------------------------------
!
! prepare the XDMF and HDF5 file names
write(fname, "(a1,i6.6,'_',i5.5,'.xdmf')") ftype, isnap, nproc
write(hname, "(a1,i6.6,'_',i5.5,'.h5' )") ftype, isnap, nproc
! open the XDMF file
!
open (unit = xdmf, file = fname, status = 'replace')
! write the header
!
write(xdmf, "(a)") '<?xml version="1.0" encoding="UTF-8"?>'
write(xdmf, "(a)") '<Xdmf Version="2.2"' &
// ' xmlns:xi="http://www.w3.org/2003/XInclude">'
write(xdmf, "(a)") ' <Domain>'
write(stmp, "(1i16)") nproc
write(xdmf, "(a)") ' <Grid Name="region_' // trim(adjustl(stmp)) &
// '" GridType="Collection" CollectionType="Spatial">'
write(stmp, "(1g15.8)") time
write(xdmf, "(a)") ' <Time TimeType="Single" Value="' &
// trim(adjustl(stmp)) // '"/>'
! do not proceed if there are not data block on this processor
!
if (get_dblocks() > 0) then
! prepare dimensions
!
ip = ni + 1
jp = ni + 1
#if NDIMS == 3
kp = ni + 1
#endif /* NDIMS == 3 */
#if NDIMS == 3
write(stmp, "(1i8)") ni
write(ttmp, "(1i8)") ni
stmp = trim(adjustl(stmp)) // ' ' // trim(adjustl(ttmp))
write(ttmp, "(1i8)") ni
#else /* NDIMS == 3 */
write(stmp, "(1i8)") ni
write(ttmp, "(1i8)") ni
#endif /* NDIMS == 3 */
bdim = trim(adjustl(stmp)) // ' ' // trim(adjustl(ttmp))
write(stmp, "(1i8)") ni
write(ttmp, "(1i8)") ni
stmp = trim(adjustl(stmp)) // ' ' // trim(adjustl(ttmp))
write(ttmp, "(1i8)") ni
stmp = trim(adjustl(stmp)) // ' ' // trim(adjustl(ttmp))
write(ttmp, "(1i8)") get_dblocks()
sdim = trim(adjustl(stmp)) // ' ' // trim(adjustl(ttmp))
! prepare slab indices
!
#if NDIMS == 3
if (with_ghosts) then
slab(:) = (/ ng, ng, ng, -1, 1, 1, 1, 1, ni, ni, ni, 1 /)
else
slab(:) = (/ 0, 0, 0, -1, 1, 1, 1, 1, ni, ni, ni, 1 /)
end if
#else /* NDIMS == 3 */
if (with_ghosts) then
slab(:) = (/ 0, ng, ng, -1, 1, 1, 1, 1, 1, ni, ni, 1 /)
else
slab(:) = (/ 0, 0, 0, -1, 1, 1, 1, 1, 1, ni, ni, 1 /)
end if
#endif /* NDIMS == 3 */
! iterate over all data blocks
!
l = 0
pdata => list_data
do while(associated(pdata))
! store block geometry information
!
write(stmp, "(1i16)") pdata%meta%id
write(xdmf, "(a)") ' <Grid Name="block_' &
// trim(adjustl(stmp)) // '">'
#if NDIMS == 3
write(stmp, "(1i8)") kp
write(ttmp, "(1i8)") jp
stmp = trim(adjustl(stmp)) // ' ' // trim(adjustl(ttmp))
write(ttmp, "(1i8)") ip
stmp = trim(adjustl(stmp)) // ' ' // trim(adjustl(ttmp))
write(xdmf, "(a)") ' <Topology TopologyType="3DCoRectMesh"' &
// ' Dimensions="' // trim(adjustl(stmp)) // '"/>'
write(xdmf, "(a)") ' <Geometry GeometryType="ORIGIN_DXDYDZ">'
write(stmp, "(3es16.8)") pdata%meta%zmin, pdata%meta%ymin &
, pdata%meta%xmin
write(xdmf, "(a)") ' <DataItem Name="Origin" NumberType="Float"' &
// ' Precision="4" Dimensions="3" Format="XML">' &
// trim(adjustl(stmp)) // '</DataItem>'
write(stmp, "(3es16.8)") adz(pdata%meta%level), ady(pdata%meta%level) &
, adx(pdata%meta%level)
write(xdmf, "(a)") ' <DataItem Name="Spacing" NumberType="Float"' &
// ' Precision="4" Dimensions="3" Format="XML">' &
// trim(adjustl(stmp)) // '</DataItem>'
#else /* NDIMS == 3 */
write(stmp, "(1i8)") jp
write(ttmp, "(1i8)") ip
stmp = trim(adjustl(stmp)) // ' ' // trim(adjustl(ttmp))
write(xdmf, "(a)") ' <Topology TopologyType="2DCoRectMesh"' &
// ' Dimensions="' // trim(adjustl(stmp)) // '"/>'
write(xdmf, "(a)") ' <Geometry GeometryType="ORIGIN_DXDY">'
write(stmp, "(2es16.8)") pdata%meta%ymin, pdata%meta%xmin
write(xdmf, "(a)") ' <DataItem Name="Origin" NumberType="Float"' &
// ' Precision="4" Dimensions="2" Format="XML">' &
// trim(adjustl(stmp)) // '</DataItem>'
write(stmp, "(2es16.8)") ady(pdata%meta%level), adx(pdata%meta%level)
write(xdmf, "(a)") ' <DataItem Name="Spacing" NumberType="Float"' &
// ' Precision="4" Dimensions="2" Format="XML">' &
// trim(adjustl(stmp)) // '</DataItem>'
#endif /* NDIMS == 3 */
write(xdmf, "(a)") ' </Geometry>'
! convert slab dimensions to string
!
slab(4) = l
write(pdim, "(1i8)") slab(1)
do p = 2, 12
write(ttmp, "(1i8)") slab(p)
pdim = trim(adjustl(pdim)) // ' ' // trim(adjustl(ttmp))
end do
! loop over all variables and store their information
!
do p = 1, nv
write(xdmf, "(a)") ' <Attribute Name="' &
// trim(adjustl(pvars(p))) &
// '" AttributeType="Scalar" Center="Cell">'
write(xdmf, "(a)") ' <DataItem ItemType="Hyperslab"' &
// ' Dimensions="' // trim(adjustl(bdim)) &
// '" Type="HyperSlab">'
write(xdmf, "(a)") ' <DataItem Dimensions="3 4" Format="XML">' &
// trim(adjustl(pdim)) // '</DataItem>'
write(ttmp, "(a,':/variables/',a)") trim(hname), trim(pvars(p))
write(xdmf, "(a)") ' <DataItem NumberType="Float"' &
// ' Precision="8" Dimensions="' &
// trim(adjustl(sdim)) // '" Format="HDF">' &
// trim(adjustl(ttmp)) // '</DataItem>'
write(xdmf, "(a)") ' </DataItem>'
write(xdmf, "(a)") ' </Attribute>'
end do
! close grid structure for the current block
!
write(xdmf,"(a)") ' </Grid>'
l = l + 1
pdata => pdata%next
end do
end if ! get_dblocks() > 0
! close the XDMF structures
!
write(xdmf, "(a)") ' </Grid>'
write(xdmf, "(a)") ' </Domain>'
write(xdmf, "(a)") '</Xdmf>'
! close the XDMF file
!
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()
! import procedures and variables from other modules
!
use mpitools , only : npmax
! local variables are not implicit by default
!
implicit none
! local variables
!
character(len=64) :: fname, pname
integer(kind=4) :: np
! local parameters
!
integer, parameter :: xdmf = 102
!
!-------------------------------------------------------------------------------
!
! prepare the XDMF and HDF5 file names
write(fname, "(a1,i6.6,'.xdmf')") ftype, isnap
! open the XDMF file
!
open (unit = xdmf, file = fname, status = 'replace')
! write the header
!
write(xdmf, "(a)") '<?xml version="1.0" encoding="UTF-8"?>'
write(xdmf, "(a)") '<Xdmf Version="2.2"' &
// ' xmlns:xi="http://www.w3.org/2003/XInclude">'
write(xdmf, "(a)") ' <Domain Name="GatherMPISubDomains">'
write(xdmf, "(a)") ' <Grid Name="FullDomain"' &
// ' GridType="Collection" CollectionType="Spatial">'
! write references to MPI subdomain files
!
do np = 0, npmax
write(pname, "(a1,i6.6,'_',i5.5,'.xdmf')") ftype, isnap, np
write(xdmf, "(a)") ' <xi:include href="' // trim(pname) &
// '" xpointer="xpointer(//Xdmf/Domain/Grid)"/>'
end do
! close the XDMF structures
!
write(xdmf, "(a)") ' </Grid>'
write(xdmf, "(a)") ' </Domain>'
write(xdmf, "(a)") '</Xdmf>'
! close the XDMF file
!
close(xdmf)
!-------------------------------------------------------------------------------
!
end subroutine write_snapshot_xdmf_master
#endif /* HDF5 */
!===============================================================================
!
end module
Reference in New Issue View Git Blame Copy Permalink