gkowal/amun-code
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
amun-code/sources/io.F90
Grzegorz Kowal 9829505650 Update copyright year to 2022. 
Signed-off-by: Grzegorz Kowal <grzegorz@amuncode.org>
2022-02-02 09:51:41 -03:00

5723 lines
196 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-2022 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
use blocks, only : pointer_meta
#ifdef HDF5
use hdf5
#endif /* HDF5 */
use timers, only : set_timer, start_timer, stop_timer
implicit none
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
interface restore_attribute_h5
module procedure restore_attribute_string_h5
module procedure restore_attribute_number_h5
end interface
interface store_attribute_h5
module procedure store_attribute_string_h5
module procedure store_attribute_number_h5
end interface
#endif /* HDF5 */
integer, save :: iio
! MODULE PARAMETERS:
! =================
!
! snapshot formats
!
integer, parameter :: snapshot_xml = 0
#ifdef HDF5
integer, parameter :: snapshot_hdf5 = 1
#endif /* HDF5 */
! snapshot_format - the format of snapshots;
! restart_format - the format of restart snapshots;
!
integer, save :: snapshot_format = snapshot_xml
integer, save :: restart_format = snapshot_xml
! respath - the directory from which the restart snapshots should be read;
! nrest - for job restarting, this is the number of restart snapshot;
! irest - the local counter for the restart snapshots;
! isnap - the local counter for the regular snapshots;
! ishift - the shift of the snapshot counter for restarting job with
! different snapshot interval;
! hrest - the execution time interval for restart snapshot storing
! (in hours); the minimum allowed value is 3 minutes;
! hsnap - the problem time interval for regular snapshot storing;
! tsnap - the next snapshot time;
!
character(len=255), save :: respath = "./"
integer , save :: nrest = -1
integer(kind=4) , save :: irest = 1
integer(kind=4) , save :: isnap = 0
integer(kind=4) , save :: ishift = 0
real(kind=8) , save :: hrest = 6.0d+00
real(kind=8) , save :: hsnap = 1.0d+00
real(kind=8) , save :: tsnap = 0.0d+00
! flag indicating to store snapshots at exact intervals
!
logical , save :: precise_snapshots = .false.
#ifdef HDF5
! a flag to determine if XDMF files should be generated
!
logical , save :: with_xdmf = .false.
#endif /* HDF5 */
! the compression format and level of the XML+binary files
!
character(len=255), save :: cformat = "none" ! compression format
integer , save :: clevel = 3 ! compression level
! the type of digest to use and its length
!
integer, save :: hash_type = 0
integer, save :: hash_length = 0
#ifdef HDF5
! supported compression types
!
integer, parameter :: H5Z_DEFLATE = 1
integer, parameter :: H5Z_SZIP = 4
integer, parameter :: H5Z_ZFP = 32013
integer, parameter :: H5Z_ZSTANDARD = 32015
! used compression type and level
!
integer, save :: hcformat = 0, hclevel = 20
! ZFP compressor parameters
!
character(len=32), save :: zfpmode = "reversible"
integer , save :: zfpprec = 64
real(kind=8) , save :: zfprate = 6.4d+01
real(kind=8) , save :: zfpaccu = 0.0d+00
! HDF5 property object identifier
!
integer(hid_t), save :: prp_id
#endif /* HDF5 */
! array of pointer used during job restart
!
type(pointer_meta), dimension(:), allocatable, save :: block_array
private
public :: initialize_io, finalize_io, print_io
public :: restart_snapshot_number, restart_from_snapshot
public :: read_snapshot_parameter
public :: read_restart_snapshot, write_restart_snapshot, write_snapshot
public :: update_dtp
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
contains
!
!===============================================================================
!!
!!*** PUBLIC SUBROUTINES *****************************************************
!!
!===============================================================================
!
!===============================================================================
!
! subroutine INITIALIZE_IO:
! ------------------------
!
! Subroutine initializes module IO by setting its parameters.
!
! Arguments:
!
! verbose - flag determining if the subroutine should be verbose;
! status - return flag of the procedure execution status;
!
!===============================================================================
!
subroutine initialize_io(verbose, status)
use compression, only : set_compression, get_compression
use hash , only : hash_info
use helpers , only : print_message
#ifdef HDF5
use mpitools , only : nproc
#endif /* HDF5 */
use parameters , only : get_parameter
implicit none
logical, intent(in) :: verbose
integer, intent(out) :: status
logical :: test
character(len=255) :: dname
character(len=255) :: sformat = "xml"
character(len=255) :: precise = "off"
character(len=255) :: ghosts = "on"
character(len=255) :: xdmf = "off"
character(len=8) :: dtype = "xxh64"
#ifdef HDF5
integer(hsize_t) :: cd_nelmts = 6
integer, dimension(6) :: cd_values = 0
#endif /* HDF5 */
#ifdef HDF5
character(len=*), parameter :: loc = 'IO::initialize_io()'
#endif /* HDF5 */
!-------------------------------------------------------------------------------
!
status = 0
call set_timer('SNAPSHOTS I/O', iio)
call get_parameter("restart_path" , respath)
call get_parameter("restart_number" , nrest )
call get_parameter("restart_interval" , hrest )
call get_parameter("snapshot_interval", hsnap )
call get_parameter("precise_snapshots", precise)
call get_parameter("include_ghosts" , ghosts )
call get_parameter("generate_xdmf" , xdmf )
if (index(respath, '/', back = .true.) /= len(trim(respath))) then
write(respath,"(a)") trim(adjustl(respath)) // '/'
end if
call get_parameter("snapshot_format", sformat)
select case(sformat)
#ifdef HDF5
case('h5', 'hdf5', 'H5', 'HDF5')
snapshot_format = snapshot_hdf5
#endif /* HDF5 */
case default
snapshot_format = snapshot_xml
end select
call get_parameter("restart_format", sformat)
select case(sformat)
#ifdef HDF5
case('h5', 'hdf5', 'H5', 'HDF5')
restart_format = snapshot_hdf5
#endif /* HDF5 */
case default
restart_format = snapshot_xml
end select
if (nrest == 0) then
test = .true.
nrest = 0
select case(restart_format)
#ifdef HDF5
case(snapshot_hdf5)
do while (test)
nrest = nrest + 1
write(dname, "(a,'r',i6.6,'_',i5.5,'.h5')") &
trim(respath), nrest, nproc
inquire(file=dname, exist=test)
end do
#endif /* HDF5 */
case default
do while (test)
nrest = nrest + 1
write(dname, "(a,'restart-',i5.5)") trim(respath), nrest
#ifdef __INTEL_COMPILER
inquire(directory=dname, exist=test)
#else /* __INTEL_COMPILER */
inquire(file=dname, exist=test)
#endif /* __INTEL_COMPILER */
end do
end select
nrest = nrest - 1
end if
call get_parameter("compression_format", cformat)
call get_parameter("compression_level" , clevel)
call set_compression(cformat, clevel)
call get_parameter("digest_type", dtype)
call hash_info(dtype, hash_type, hash_length)
if (status == 0) then
select case(trim(precise))
case ("off", "OFF", "n", "N", "false", "FALSE", "no", "NO")
precise_snapshots = .false.
case default
precise_snapshots = .true.
end select
#ifdef HDF5
select case(trim(xdmf))
case ("off", "OFF", "n", "N", "false", "FALSE", "no", "NO")
with_xdmf = .false.
case default
with_xdmf = .true.
end select
call h5open_f(status)
if (status /= 0) then
call print_message(loc, &
"Cannot initialize the HDF5 Fortran interface!")
else
call h5pcreate_f(H5P_DATASET_CREATE_F, prp_id, status)
if (status < 0) then
call print_message(loc, &
"Cannot create the compression property for datasets!")
else
call get_parameter("compression_format", sformat)
call get_parameter("compression_level" , hclevel)
call get_parameter("zfp_mode" , zfpmode)
call get_parameter("zfp_rate" , zfprate)
call get_parameter("zfp_precision" , zfpprec)
call get_parameter("zfp_accuracy" , zfpaccu)
select case(sformat)
case("deflate", "gzip")
call h5zfilter_avail_f(H5Z_DEFLATE, test, status)
if (status == 0) then
if (test) then
hcformat = H5Z_DEFLATE
hclevel = max(1, min(9, hclevel))
call h5pset_deflate_f(prp_id, hclevel, status)
end if
else
call print_message(loc, &
"Could not check if the filter is available!")
end if
case("szip")
call h5zfilter_avail_f(H5Z_FILTER_SZIP_F, test, status)
if (status == 0) then
if (test) then
hcformat = H5Z_SZIP
call h5pset_szip_f(prp_id, 32, 32, status)
end if
else
call print_message(loc, &
"Could not check if the filter is available!")
end if
with_xdmf = .false.
case("zstd", "zstandard")
call h5zfilter_avail_f(H5Z_ZSTANDARD, test, status)
if (status == 0) then
if (test) then
hcformat = H5Z_ZSTANDARD
hclevel = max(1, min(20, hclevel))
cd_values(:) = hclevel
call h5pset_filter_f(prp_id, H5Z_ZSTANDARD, &
H5Z_FLAG_OPTIONAL_F, cd_nelmts, cd_values, status)
end if
else
call print_message(loc, &
"Could not check if the filter is available!")
end if
with_xdmf = .false.
case("zfp")
call h5zfilter_avail_f(H5Z_ZFP, test, status)
if (status == 0) then
if (test) then
hcformat = H5Z_ZFP
select case(trim(zfpmode))
case('rate')
cd_values(1) = 1
cd_values(3:4) = transfer(zfprate, [0_4])
case('precision')
cd_values(1) = 2
cd_values(3) = zfpprec
case('accuracy')
cd_values(1) = 3
cd_values(3:4) = transfer(zfpaccu, [0_4])
case('reversible')
cd_values(1) = 5
end select
call h5pset_filter_f(prp_id, H5Z_ZFP, 0, &
cd_nelmts, cd_values, status)
end if
else
call print_message(loc, &
"Could not check if the filter is available!")
end if
with_xdmf = .false.
case default
end select
end if
end if
#endif /* HDF5 */
end if
!-------------------------------------------------------------------------------
!
end subroutine initialize_io
!
!===============================================================================
!
! subroutine FINALIZE_IO:
! ----------------------
!
! Subroutine releases memory used by the module.
!
! Arguments:
!
! status - the subroutine call status;
!
!===============================================================================
!
subroutine finalize_io(status)
#ifdef HDF5
use helpers, only : print_message
#endif /* HDF5 */
implicit none
integer, intent(out) :: status
#ifdef HDF5
character(len=*), parameter :: loc = 'IO::finalize_io()'
#endif /* HDF5 */
!-------------------------------------------------------------------------------
!
status = 0
#ifdef HDF5
call h5pclose_f(prp_id, status)
if (status < 0) &
call print_message(loc, "Could not close the HDF5 compression property!")
call h5close_f(status)
if (status < 0) &
call print_message(loc, "Could not close the HDF5 Fortran interface!")
#endif /* HDF5 */
!-------------------------------------------------------------------------------
!
end subroutine finalize_io
!
!===============================================================================
!
! subroutine PRINT_IO:
! -------------------
!
! Subroutine prints IO parameters.
!
! Arguments:
!
! verbose - flag determining if the subroutine should be verbose;
!
!===============================================================================
!
subroutine print_io(verbose)
use hash , only : hash_name
use helpers, only : print_section, print_parameter
implicit none
logical, intent(in) :: verbose
character(len=80) :: sfmt, msg
integer :: dd, hh, mm, ss
!-------------------------------------------------------------------------------
!
if (verbose) then
call print_section(verbose, "Snapshots")
select case(snapshot_format)
#ifdef HDF5
case(snapshot_hdf5)
call print_parameter(verbose, "snapshot format", "HDF5")
#endif /* HDF5 */
case default
call print_parameter(verbose, "snapshot format", "XML+binary")
end select
select case(restart_format)
#ifdef HDF5
case(snapshot_hdf5)
call print_parameter(verbose, "restart snapshot format", "HDF5")
#endif /* HDF5 */
case default
call print_parameter(verbose, "restart snapshot format", "XML+binary")
call print_parameter(verbose, "digest type", hash_name(hash_type))
call print_parameter(verbose, "compression format", cformat)
call print_parameter(verbose, "compression level", clevel)
end select
call print_parameter(verbose, "precise snapshot intervals", &
precise_snapshots, "on")
#ifdef HDF5
select case(hcformat)
case(H5Z_DEFLATE)
call print_parameter(verbose, "HDF5 compression", "deflate")
call print_parameter(verbose, "compression level", hclevel)
case(H5Z_SZIP)
call print_parameter(verbose, "HDF5 compression", "szip")
case(H5Z_ZSTANDARD)
call print_parameter(verbose, "HDF5 compression", "zstd")
call print_parameter(verbose, "compression level", hclevel)
case(H5Z_ZFP)
call print_parameter(verbose, "HDF5 compression", "zfp")
call print_parameter(verbose, "ZFP mode", zfpmode)
select case(trim(zfpmode))
case('rate')
call print_parameter(verbose, "ZFP rate" , zfprate)
case('precision')
call print_parameter(verbose, "ZFP precision", zfpprec)
case('accuracy')
call print_parameter(verbose, "ZFP accuracy" , zfpaccu)
end select
case default
call print_parameter(verbose, "HDF5 compression" , "none")
end select
call print_parameter(verbose, "generate XDMF files", with_xdmf, "on")
#endif /* HDF5 */
call print_parameter(verbose, "snapshot interval" , hsnap)
if (hrest > 0.0d+00) then
dd = int(hrest / 2.4d+01)
hh = int(mod(hrest, 2.4d+01))
mm = int(mod(6.0d+01 * hrest, 6.0d+01))
ss = int(mod(3.6d+03 * hrest, 6.0d+01))
sfmt = "(i2.2,'d',i2.2,'h',i2.2,'m',i2.2,'s')"
write(msg,sfmt) dd, hh, mm, ss
call print_parameter(verbose, "restart interval" , msg )
end if
if (restart_from_snapshot()) then
call print_parameter(verbose, "restart from path" , respath)
call print_parameter(verbose, "restart from snapshot", nrest )
end if
end if
!-------------------------------------------------------------------------------
!
end subroutine print_io
!
!===============================================================================
!
! function RESTART_SNAPSHOT_NUMBER:
! --------------------------------
!
! Subroutine returns the number of restart snapshot.
!
!===============================================================================
!
integer function restart_snapshot_number()
implicit none
!-------------------------------------------------------------------------------
!
restart_snapshot_number = nrest
!-------------------------------------------------------------------------------
!
end function restart_snapshot_number
!
!===============================================================================
!
! function RESTART_FROM_SNAPSHOT:
! ------------------------------
!
! Subroutine returns true if the current job is the restarted one.
!
!===============================================================================
!
logical function restart_from_snapshot()
implicit none
!-------------------------------------------------------------------------------
!
restart_from_snapshot = (nrest > 0)
!-------------------------------------------------------------------------------
!
end function restart_from_snapshot
!
!===============================================================================
!
! subroutine READ_RESTART_SNAPSHOT:
! --------------------------------
!
! Subroutine reads restart snapshot files in order to resume the job.
! This is a wrapper calling specific format subroutine.
!
! Arguments:
!
! status - the status flag to inform if subroutine succeeded or failed;
!
!===============================================================================
!
subroutine read_restart_snapshot(status)
use blocks , only : build_leaf_list, build_datablock_list
use evolution, only : time
use helpers , only : print_message
implicit none
integer, intent(out) :: status
character(len=*), parameter :: loc = 'IO::read_restart_snapshot()'
!-------------------------------------------------------------------------------
!
call start_timer(iio)
status = 0
select case(restart_format)
#ifdef HDF5
case(snapshot_hdf5)
call read_restart_snapshot_h5(status)
#endif /* HDF5 */
case default
call read_restart_snapshot_xml(status)
end select
call build_leaf_list(status)
if (status /= 0) &
call print_message(loc, "Could not build the list of leafs!")
call build_datablock_list(status)
if (status /= 0) &
call print_message(loc, "Could not build the list of data blocks!")
! calculate the shift of the snapshot counter, and the next snapshot time
!
ishift = int(time / hsnap) - isnap + 1
tsnap = (ishift + isnap) * hsnap
call stop_timer(iio)
!-------------------------------------------------------------------------------
!
end subroutine read_restart_snapshot
!
!===============================================================================
!
! subroutine WRITE_RESTART_SNAPSHOT:
! ---------------------------------
!
! Subroutine stores current restart snapshot files. This is a wrapper
! calling specific format subroutine.
!
! Arguments:
!
! thrs - the current execution time in hours;
! problem - the problem's name;
! nrun - the run number;
! status - the status flag;
!
!===============================================================================
!
subroutine write_restart_snapshot(thrs, problem, nrun, status)
implicit none
real(kind=8) , intent(in) :: thrs
character(len=*), intent(in) :: problem
integer , intent(in) :: nrun
integer , intent(out) :: status
!-------------------------------------------------------------------------------
!
status = 0
! check if conditions for storing the restart snapshot have been met
!
if (hrest < 5.0d-02 .or. thrs < irest * hrest) return
call start_timer(iio)
select case(snapshot_format)
#ifdef HDF5
case(snapshot_hdf5)
call store_restart_snapshot_h5(problem, nrun, status)
#endif /* HDF5 */
case default
call store_restart_snapshot_xml(problem, nrun, status)
end select
! increase the restart snapshot counter
!
irest = irest + 1
call stop_timer(iio)
!-------------------------------------------------------------------------------
!
end subroutine write_restart_snapshot
!
!===============================================================================
!
! subroutine WRITE_SNAPSHOT:
! -------------------------
!
! Subroutine stores block data in snapshots. Block variables are grouped
! together and stored in big 4D arrays separately. This is a wrapper for
! specific format storing.
!
! Arguments:
!
! problem - the problem's name;
!
!===============================================================================
!
subroutine write_snapshot(problem)
use evolution, only : time
#ifdef HDF5
use mpitools , only : master
#endif /* HDF5 */
implicit none
character(len=*), intent(in) :: problem
integer :: status
!-------------------------------------------------------------------------------
!
if (hsnap <= 0.0e+00 .or. time < tsnap) return
call start_timer(iio)
select case(snapshot_format)
#ifdef HDF5
case(snapshot_hdf5)
call store_snapshot_h5(problem, status)
if (with_xdmf) then
call write_snapshot_xdmf()
if (master) call write_snapshot_xdmf_master()
end if
#endif /* HDF5 */
case default
call store_snapshot_xml(problem, status)
end select
! increase the snapshot counter and calculate the next snapshot time
!
isnap = isnap + 1
tsnap = (ishift + isnap) * hsnap
call stop_timer(iio)
!-------------------------------------------------------------------------------
!
end subroutine write_snapshot
!
!===============================================================================
!
! subroutine UPDATE_DTP:
! ---------------------
!
! Subroutine updates dtp from module EVOLUTION.
!
!===============================================================================
!
subroutine update_dtp()
use evolution, only : time, dtp
implicit none
!-------------------------------------------------------------------------------
!
if (precise_snapshots) then
if (tsnap > time) then
dtp = tsnap - time
else
dtp = hsnap
endif
end if
!-------------------------------------------------------------------------------
!
end subroutine update_dtp
!
!===============================================================================
!!
!!*** PRIVATE SUBROUTINES ****************************************************
!!
!===============================================================================
!
!===============================================================================
!
! subroutine 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 helpers, only : print_message
implicit none
character(len=*), intent(in) :: pname
character(len=*), intent(inout) :: pvalue
integer , intent(inout) :: status
logical :: test
character(len=255) :: dname, fname, line
integer(kind=4) :: lun = 103
integer :: l, u
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
call print_message(loc, trim(dname) // " does not exist!")
status = 121
return
end if
write(fname,"(a,'/metadata.xml')") trim(dname)
inquire(file = fname, exist = test)
if (.not. test) then
call print_message(loc, trim(fname) // " does not exist!")
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 helpers, only : print_message
implicit none
character(len=*), intent(in) :: pname
integer , intent(inout) :: pvalue
integer , intent(inout) :: status
logical :: test
character(len=255) :: dname, fname, line, svalue
integer(kind=4) :: lun = 103
integer :: l, u
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
call print_message(loc, trim(dname) // " does not exist!")
status = 121
return
end if
write(fname,"(a,'/metadata.xml')") trim(dname)
inquire(file = fname, exist = test)
if (.not. test) then
call print_message(loc, trim(fname) // " does not exist!")
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 helpers, only : print_message
implicit none
character(len=*), intent(in) :: pname
real(kind=8) , intent(inout) :: pvalue
integer , intent(inout) :: status
logical :: test
character(len=255) :: dname, fname, line, svalue
integer(kind=4) :: lun = 103
integer :: l, u
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
call print_message(loc, trim(dname) // " does not exist!")
status = 121
return
end if
write(fname,"(a,'/metadata.xml')") trim(dname)
inquire(file = fname, exist = test)
if (.not. test) then
call print_message(loc, trim(fname) // " does not exist!")
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, nregs
use blocks , only : append_metablock, append_datablock, link_blocks
use blocks , only : get_mblocks
use blocks , only : set_last_id, get_last_id
use blocks , only : metablock_set_id, metablock_set_process
use blocks , only : metablock_set_refinement
use blocks , only : metablock_set_configuration
use blocks , only : metablock_set_level, metablock_set_position
use blocks , only : metablock_set_coordinates, metablock_set_bounds
use blocks , only : metablock_set_leaf
use blocks , only : change_blocks_process
use coordinates , only : nn => bcells, ncells, nghosts
use coordinates , only : xmin, xmax, ymin, ymax, zmin, zmax
use equations , only : cmax, cmax2, cglm
use evolution , only : step, time, dt, dth, dte
use evolution , only : niterations, nrejections, errs
use forcing , only : nmodes, fcoefs, einj
use hash , only : hash_info, check_digest, digest_integer
use helpers , only : print_message
use iso_c_binding, only : c_loc
#ifdef MPI
use mesh , only : redistribute_blocks
#endif /* MPI */
use mpitools , only : nprocs, nproc
use random , only : gentype, set_seeds
implicit none
integer, intent(out) :: status
logical :: test
character(len=255) :: dname, fname, line, sname, svalue
integer :: il, iu, nl, nx, nm, nd, nv, i, j, l, n, p, nu, nr
#if NDIMS == 3
integer :: k
#endif /* NDIMS == 3 */
integer(kind=4) :: lndims, lnprocs, lnproc, lmblocks, lnleafs, llast_id
integer(kind=4) :: ldblocks, lncells, lnghosts, lnseeds, lnmodes
real(kind=8) :: deinj
type(block_meta), pointer :: pmeta
type(block_data), pointer :: pdata
integer :: dtype, dlen
integer(kind=4) :: lun = 104
integer(kind=8) :: bytes, pbytes, ubytes
integer(kind=8) :: hfield, hchild, hface, hedge, hcorner, hbound
integer(kind=8) :: hids, hseed, hforce
integer(kind=8), dimension(:) , allocatable :: hprim, hcons
integer(kind=4), dimension(:) , allocatable, target :: ids
integer(kind=4), dimension(:,:) , allocatable, target :: fields
integer(kind=4), dimension(:,:) , allocatable, target :: children
#if NDIMS == 2
integer(kind=4), dimension(:,:,:,:) , allocatable, target :: edges
integer(kind=4), dimension(:,:,:) , allocatable, target :: corners
#endif /* NDIMS == 2 */
#if NDIMS == 3
integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: faces
integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: edges
integer(kind=4), dimension(:,:,:,:) , allocatable, target :: corners
#endif /* NDIMS == 3 */
integer(kind=8), dimension(:,:) , allocatable, target :: seeds
real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds
real(kind=8) , dimension(:,:,:,:,:), allocatable, target :: array
complex(kind=8), dimension(:,:) , allocatable, target :: lfcoefs
character(len=*), parameter :: loc = 'IO::read_restart_snapshot_xml()'
character(len=*), parameter :: sfmt = "(a,a,'_',i6.6,'.',a)"
!-------------------------------------------------------------------------------
!
status = 0
write(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
call print_message(loc, trim(dname) // " does not exist!")
status = 121
return
end if
dname = trim(dname) // "/"
write(fname,"(a,'metadata.xml')") trim(dname)
inquire(file=fname, exist=test)
if (.not. test) then
call print_message(loc, trim(fname) // " does not exist!")
status = 121
return
end if
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('dth')
read(svalue, fmt=*) dth
case('dte')
read(svalue, fmt=*) dte
case('cmax')
read(svalue, fmt=*) cmax
cmax2 = cmax * cmax
case('cglm')
read(svalue, fmt=*) cglm
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_type="') + 13
iu = index(line(il:), '"') + il - 2
call hash_info(line(il:iu), dtype, dlen)
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hfield)
case('children')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hchild)
case('faces')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hface)
case('edges')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hedge)
case('corners')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hcorner)
case('bounds')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hbound)
case('forcing')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hforce)
end select
end if
end if
go to 10
20 close(lun)
if (lndims /= NDIMS) then
call print_message(loc, "The number of dimensions does not match!")
return
end if
if (lncells /= ncells) then
call print_message(loc, "The block dimensions do not match!")
return
end if
do l = 1, lmblocks
call append_metablock(pmeta, status)
end do
if (lmblocks /= get_mblocks()) then
call print_message(loc, "Number of metablocks does not match!")
end if
call set_last_id(llast_id)
nx = llast_id
nm = lmblocks
allocate(fields(16,nm), children(nc,nm), bounds(3,2,nm), &
#if NDIMS == 3
faces(NDIMS,ns,ns,ns,nm), &
edges(NDIMS,ns,ns,ns,nm), corners(ns,ns,ns,nm), &
#else /* NDIMS == 3 */
edges(NDIMS,ns,ns,nm), corners(ns,ns,nm), &
#endif /* NDIMS == 3 */
block_array(nx), stat=status)
if (status == 0) then
write(fname,"(a,'metablock_fields.bin')") trim(dname)
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) fields
close(lun)
bytes = size(fields, kind=8) * kind(fields)
call check_digest(loc, fname, c_loc(fields), bytes, hfield, dtype)
write(fname,"(a,'metablock_children.bin')") trim(dname)
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) children
close(lun)
bytes = size(children, kind=8) * kind(children)
call check_digest(loc, fname, c_loc(children), bytes, hchild, dtype)
#if NDIMS == 3
write(fname,"(a,'metablock_faces.bin')") trim(dname)
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) faces
close(lun)
bytes = size(faces, kind=8) * kind(faces)
call check_digest(loc, fname, c_loc(faces), bytes, hface, dtype)
#endif /* NDIMS == 3 */
write(fname,"(a,'metablock_edges.bin')") trim(dname)
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) edges
close(lun)
bytes = size(edges, kind=8) * kind(edges)
call check_digest(loc, fname, c_loc(edges), bytes, hedge, dtype)
write(fname,"(a,'metablock_corners.bin')") trim(dname)
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) corners
close(lun)
bytes = size(corners, kind=8) * kind(corners)
call check_digest(loc, fname, c_loc(corners), bytes, hcorner, dtype)
write(fname,"(a,'metablock_bounds.bin')") trim(dname)
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) bounds
close(lun)
bytes = size(bounds, kind=8) * kind(bounds)
call check_digest(loc, fname, c_loc(bounds), bytes, hbound, dtype)
l = 0
pmeta => list_meta
do while(associated(pmeta))
l = l + 1
block_array(fields(1,l))%ptr => pmeta
call metablock_set_id (pmeta, fields( 1,l))
call metablock_set_process (pmeta, fields( 2,l))
call metablock_set_level (pmeta, fields( 3,l))
call metablock_set_configuration(pmeta, fields( 4,l))
call metablock_set_refinement (pmeta, fields( 5,l))
call metablock_set_position (pmeta, fields(6: 8,l))
call metablock_set_coordinates (pmeta, fields(9:11,l))
call metablock_set_bounds (pmeta, bounds(1,1,l), bounds(1,2,l), &
bounds(2,1,l), bounds(2,2,l), &
bounds(3,1,l), bounds(3,2,l))
if (fields(12,l) == 1) call metablock_set_leaf(pmeta)
pmeta => pmeta%next
end do
l = 0
pmeta => list_meta
do while(associated(pmeta))
l = l + 1
if (fields(14,l) > 0) pmeta%parent => block_array(fields(14,l))%ptr
do p = 1, nc
if (children(p,l) > 0) then
pmeta%child(p)%ptr => block_array(children(p,l))%ptr
end if
end do
#if NDIMS == 2
do j = 1, ns
do i = 1, ns
do n = 1, NDIMS
if (edges(n,i,j,l) > 0) &
pmeta%edges(i,j,n)%ptr => block_array(edges(n,i,j,l))%ptr
end do
if (corners(i,j,l) > 0) &
pmeta%corners(i,j)%ptr => block_array(corners(i,j,l))%ptr
end do
end do
#endif /* NDIMS == 2 */
#if NDIMS == 3
do k = 1, ns
do j = 1, ns
do i = 1, ns
do n = 1, NDIMS
if (faces(n,i,j,k,l) > 0) &
pmeta%faces(i,j,k,n)%ptr => block_array(faces(n,i,j,k,l))%ptr
if (edges(n,i,j,k,l) > 0) &
pmeta%edges(i,j,k,n)%ptr => block_array(edges(n,i,j,k,l))%ptr
end do
if (corners(i,j,k,l) > 0) &
pmeta%corners(i,j,k)%ptr => block_array(corners(i,j,k,l))%ptr
end do
end do
end do
#endif /* NDIMS == 3 */
pmeta => pmeta%next
end do
#if NDIMS == 3
deallocate(fields, children, bounds, faces, edges, corners, stat=status)
#else /* NDIMS == 3 */
deallocate(fields, children, bounds, edges, corners, stat=status)
#endif /* NDIMS == 3 */
if (status /= 0) &
call print_message(loc, "Could not release space of metablocks!")
else
call print_message(loc, "Could not allocate space of metablocks!")
end if
if (lnmodes == nmodes) then
if (lnmodes > 0) then
allocate(lfcoefs(lnmodes,lndims), stat=status)
if (status == 0) then
write(fname,"(a,'forcing_coefficients.bin')") trim(dname)
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) lfcoefs
close(lun)
bytes = size(lfcoefs, kind=8) * kind(lfcoefs)
call check_digest(loc, fname, c_loc(lfcoefs), bytes, hforce, dtype)
fcoefs = lfcoefs
deallocate(lfcoefs, stat=status)
if (status /= 0) &
call print_message(loc, &
"Could not release space of Fourier coefficients!")
else
call print_message(loc, &
"Could not allocate space of Fourier coefficients!")
end if
end if
else
call print_message(loc, "The number of forcing modes does not match!")
end if
if (nprocs >= lnprocs) then
if (nproc < lnprocs) then
write(fname,sfmt) trim(dname), "datablocks", nproc, "xml"
inquire(file=fname, exist=test)
if (.not. test) then
write(*,*) trim(fname) // " does not exist!"
status = 121
return
end if
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
if (nd > 0) then
allocate(hprim(nd), hcons(nd), stat=status)
if (status /= 0) &
call print_message(loc, &
"Could not allocate space for hashes!")
end if
case('nregs')
read(svalue, fmt=*) nr
case('einj')
read(svalue, fmt=*) einj
case('ids')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hids)
case('seeds')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hseed)
end select
if (index(sname, 'prim') > 0) then
read(sname(7:), fmt=*) l
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hprim(l))
end if
if (index(sname, 'cons') > 0) then
read(sname(7:), fmt=*) l
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hcons(l))
end if
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 (nd > 0) then
#if NDIMS == 3
allocate(ids(nd), array(nv,nm,nm,nm,nr), stat=status)
#else /* NDIMS == 3 */
allocate(ids(nd), array(nv,nm,nm, 1,nr), stat=status)
#endif /* NDIMS == 3 */
if (status == 0) then
write(fname,sfmt) trim(dname), "datablock_ids", nproc, "bin"
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) ids
close(lun)
bytes = size(ids, kind=8) * kind(ids)
call check_digest(loc, fname, c_loc(ids), bytes, hids, dtype)
ubytes = size(array, kind=8) * kind(array)
pbytes = ubytes / nr
do l = 1, nd
call append_datablock(pdata, status)
call link_blocks(block_array(ids(l))%ptr, pdata)
write(fname,"(a,'datablock_prim_',i6.6,'_',i6.6,'.bin')") &
trim(dname), nproc, l
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) array(:,:,:,:,1)
close(lun)
call check_digest(loc, fname, c_loc(array), &
pbytes, hprim(l), dtype)
if (lnghosts >= nghosts) then
#if NDIMS == 3
pdata%q = array(:,il:iu,il:iu,il:iu,1)
#else /* NDIMS == 3 */
pdata%q = array(:,il:iu,il:iu, : ,1)
#endif /* NDIMS == 3 */
else
#if NDIMS == 3
pdata%q(:,il:iu,il:iu,il:iu) = array(:,:,:,:,1)
#else /* NDIMS == 3 */
pdata%q(:,il:iu,il:iu, : ) = array(:,:,:,:,1)
#endif /* NDIMS == 3 */
end if
write(fname,"(a,'datablock_cons_',i6.6,'_',i6.6,'.bin')") &
trim(dname), nproc, l
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) array
close(lun)
call check_digest(loc, fname, c_loc(array), &
ubytes, hcons(l), dtype)
p = min(nregs, nr)
if (lnghosts >= nghosts) then
#if NDIMS == 3
pdata%uu(:,:,:,:,1:p) = array(:,il:iu,il:iu,il:iu,1:p)
#else /* NDIMS == 3 */
pdata%uu(:,:,:,:,1:p) = array(:,il:iu,il:iu, : ,1:p)
#endif /* NDIMS == 3 */
else
#if NDIMS == 3
pdata%uu(:,il:iu,il:iu,il:iu,1:p) = array(:,:,:,:,1:p)
#else /* NDIMS == 3 */
pdata%uu(:,il:iu,il:iu, : ,1:p) = array(:,:,:,:,1:p)
#endif /* NDIMS == 3 */
end if
end do
deallocate(ids, array, hprim, hcons, stat=status)
if (status /= 0) &
call print_message(loc, "Could not release space of datablocks!")
else
call print_message(loc, "Could not allocate space for datablocks!")
end if
end if
allocate(seeds(4,lnseeds), stat=status)
if (status == 0) then
write(fname,sfmt) trim(dname), "random_seeds", nproc, "bin"
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) seeds
close(lun)
bytes = size(seeds, kind=8) * kind(seeds)
call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype)
call set_seeds(lnseeds, seeds(:,:), .false.)
deallocate(seeds, stat=status)
if (status /= 0) &
call print_message(loc, "Could not release space of seeds!")
else
call print_message(loc, "Could not allocate space for seeds!")
end if
else ! nproc < lnprocs
write(fname,sfmt) trim(dname), "datablocks", 0, "xml"
inquire(file=fname, exist=test)
if (.not. test) then
write(*,*) trim(fname) // " does not exist!"
status = 121
return
end if
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
call digest_integer(line(il:iu), 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
write(fname,sfmt) trim(dname), "random_seeds", 0, "bin"
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) seeds
close(lun)
bytes = size(seeds, kind=8) * kind(seeds)
call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype)
call set_seeds(lnseeds, seeds(:,:), .false.)
deallocate(seeds, stat=status)
if (status /= 0) &
call print_message(loc, "Could not release space of seeds!")
else
call print_message(loc, "Could not allocate space for seeds!")
end if
end if ! gentype == "same"
end if ! nproc < nprocs
else ! nprocs < lnprocs
! divide files between processes and update the block process accordingly
!
nl = 0
nd = lnprocs / nprocs
nr = mod(lnprocs, nprocs)
do n = 0, nprocs - 1
if (n < nr) then
il = n * (nd + 1)
iu = il + nd
else
il = n * nd + nr
iu = il + nd - 1
end if
do i = il, iu
call change_blocks_process(i, n)
end do
if (n == nproc) then
nl = il
nu = iu
end if
end do
do n = nl, nu
write(fname,sfmt) trim(dname), "datablocks", n, "xml"
inquire(file=fname, exist=test)
if (.not. test) then
write(*,*) trim(fname) // " does not exist!"
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
if (nd > 0) then
allocate(hprim(nd), hcons(nd), stat=status)
if (status /= 0) &
call print_message(loc, &
"Could not allocate space for hashes!")
end if
case('nregs')
read(svalue, fmt=*) nr
case('einj')
read(svalue, fmt=*) deinj
case('ids')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hids)
case('seeds')
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hseed)
end select
if (index(sname, 'prim') > 0) then
read(sname(7:), fmt=*) l
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hprim(l))
end if
if (index(sname, 'cons') > 0) then
read(sname(7:), fmt=*) l
il = index(line, 'digest="') + 8
iu = index(line(il:), '"') + il - 2
call digest_integer(line(il:iu), hcons(l))
end if
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 (nd > 0) then
#if NDIMS == 3
allocate(ids(nd), array(nv,nm,nm,nm,nr), stat=status)
#else /* NDIMS == 3 */
allocate(ids(nd), array(nv,nm,nm, 1,nr), stat=status)
#endif /* NDIMS == 3 */
if (status == 0) then
write(fname,sfmt) trim(dname), "datablock_ids", n, "bin"
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) ids
close(lun)
bytes = size(ids, kind=8) * kind(ids)
call check_digest(loc, fname, c_loc(ids), bytes, hids, dtype)
ubytes = size(array, kind=8) * kind(array)
pbytes = ubytes / nr
do l = 1, nd
call append_datablock(pdata, status)
call link_blocks(block_array(ids(l))%ptr, pdata)
write(fname,"(a,'datablock_prim_',i6.6,'_',i6.6,'.bin')") &
trim(dname), n, l
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) array(:,:,:,:,1)
close(lun)
call check_digest(loc, fname, c_loc(array), &
pbytes, hprim(l), dtype)
if (lnghosts >= nghosts) then
#if NDIMS == 3
pdata%q = array(:,il:iu,il:iu,il:iu,1)
#else /* NDIMS == 3 */
pdata%q = array(:,il:iu,il:iu, : ,1)
#endif /* NDIMS == 3 */
else
#if NDIMS == 3
pdata%q(:,il:iu,il:iu,il:iu) = array(:,:,:,:,1)
#else /* NDIMS == 3 */
pdata%q(:,il:iu,il:iu, : ) = array(:,:,:,:,1)
#endif /* NDIMS == 3 */
end if
write(fname,"(a,'datablock_cons_',i6.6,'_',i6.6,'.bin')") &
trim(dname), n, l
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) array
close(lun)
call check_digest(loc, fname, c_loc(array), &
ubytes, hcons(l), dtype)
p = min(nregs, nr)
if (lnghosts >= nghosts) then
#if NDIMS == 3
pdata%uu(:,:,:,:,1:p) = array(:,il:iu,il:iu,il:iu,1:p)
#else /* NDIMS == 3 */
pdata%uu(:,:,:,:,1:p) = array(:,il:iu,il:iu, : ,1:p)
#endif /* NDIMS == 3 */
else
#if NDIMS == 3
pdata%uu(:,il:iu,il:iu,il:iu,1:p) = array(:,:,:,:,1:p)
#else /* NDIMS == 3 */
pdata%uu(:,il:iu,il:iu, : ,1:p) = array(:,:,:,:,1:p)
#endif /* NDIMS == 3 */
end if
end do
deallocate(ids, array, hprim, hcons, stat=status)
if (status /= 0) &
call print_message(loc, "Could not release space of datablocks!")
else
call print_message(loc, "Could not allocate space for datablocks!")
end if
end if
end do ! n = nl, nu
allocate(seeds(4,lnseeds), stat=status)
if (status == 0) then
write(fname,sfmt) trim(dname), "random_seeds", nproc, "bin"
open(newunit=lun, file=fname, form='unformatted', access='stream')
read(lun) seeds
close(lun)
bytes = size(seeds, kind=8) * kind(seeds)
call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype)
call set_seeds(lnseeds, seeds(:,:), .false.)
deallocate(seeds, stat=status)
if (status /= 0) &
call print_message(loc, "Could not release space of seeds!")
else
call print_message(loc, "Could not allocate space for seeds!")
end if
end if ! nprocs >= lnprocs
if (allocated(block_array)) deallocate(block_array)
#ifdef MPI
call redistribute_blocks(status)
#endif /* MPI */
!-------------------------------------------------------------------------------
!
end subroutine read_restart_snapshot_xml
!
!===============================================================================
!
! subroutine STORE_RESTART_SNAPSHOT_XML:
! -------------------------------------
!
! Subroutine stores a restart snapshot, i.e. parameters, meta and data blocks
! using the XML format for parameters and binary format for meta and data
! block fields.
!
! Arguments:
!
! problem - the problem's name;
! nrun - the snapshot number;
! status - the status flag to inform if subroutine succeeded or failed;
!
!===============================================================================
!
subroutine store_restart_snapshot_xml(problem, nrun, status)
use blocks , only : block_meta, block_data, list_meta, list_data
use blocks , only : get_mblocks, get_dblocks, get_nleafs
use blocks , only : get_last_id
use blocks , only : ns => nsides, nc => nchildren, nr => nregs
use coordinates , only : nn => bcells, ncells, nghosts, minlev, maxlev
use coordinates , only : xmin, xmax, ymin, ymax
#if NDIMS == 3
use coordinates , only : zmin, zmax
#endif /* NDIMS == 3 */
use coordinates , only : bdims => domain_base_dims
use equations , only : eqsys, eos, nv, cmax, cglm
use evolution , only : step, time, dt, dth, dte, cfl, glm_alpha, errs
use evolution , only : atol, rtol, mrej, niterations, nrejections
use forcing , only : nmodes, fcoefs, einj
use hash , only : hash_info
use helpers , only : print_message
use iso_c_binding, only : c_loc
use mpitools , only : nprocs, nproc
use parameters , only : get_parameter_file
use random , only : gentype, nseeds, get_seeds
implicit none
character(len=*), intent(in) :: problem
integer , intent(in) :: nrun
integer , intent(out) :: status
logical :: test
character(len=64) :: dname, fname, aname
integer(kind=8) :: digest, bytes
integer(kind=4) :: lun = 103
integer :: dtype, dlen
integer :: nd, nl, nm, nx, i, j, l, n, p
#if NDIMS == 3
integer :: k
#endif /* NDIMS == 3 */
type(block_meta), pointer :: pmeta
type(block_data), pointer :: pdata
integer(kind=4), dimension(:) , allocatable, target :: ids
integer(kind=4), dimension(:,:) , allocatable, target :: fields
integer(kind=4), dimension(:,:) , allocatable, target :: children
#if NDIMS == 2
integer(kind=4), dimension(:,:,:,:) , allocatable, target :: edges
integer(kind=4), dimension(:,:,:) , allocatable, target :: corners
#endif /* NDIMS == 2 */
#if NDIMS == 3
integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: faces
integer(kind=4), dimension(:,:,:,:,:), allocatable, target :: edges
integer(kind=4), dimension(:,:,:,:) , allocatable, target :: corners
#endif /* NDIMS == 3 */
integer(kind=8), dimension(:,:) , allocatable, target :: seeds
real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds
character(len=*), parameter :: loc = "IO::store_restart_snapshot_xml()"
character(len=*), parameter :: sfmt = "(a,a,'_',i6.6,'.',a)"
!-------------------------------------------------------------------------------
!
status = 0
call hash_info("xxh64", dtype, dlen)
write(dname, "('restart-',i5.5)") nrun
#ifdef __INTEL_COMPILER
inquire(directory = dname, exist = test)
do while(.not. test)
if (.not. test) call execute_command_line("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 execute_command_line("mkdir -p " // trim(dname))
inquire(file = dname, exist = test)
end do
#endif /* __INTEL_COMPILER */
dname = trim(dname) // "/"
nx = get_last_id()
nm = get_mblocks()
nd = get_dblocks()
nl = get_nleafs()
if (nproc == 0) then
call get_parameter_file(fname, status)
if (status == 0) then
call execute_command_line("cp -a " // trim(fname) // " " // trim(dname))
else
call print_message(loc, "Cannot get the location of parameter file!")
return
end if
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)
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, "dth" , dth)
call write_attribute_xml(lun, "dte" , dte)
call write_attribute_xml(lun, "cfl" , cfl)
call write_attribute_xml(lun, "cmax" , cmax)
call write_attribute_xml(lun, "cglm" , cglm)
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>'
allocate(fields(16,nm), children(nc,nm), bounds(3,2,nm), &
#if NDIMS == 3
faces(NDIMS,ns,ns,ns,nm), &
edges(NDIMS,ns,ns,ns,nm), corners(ns,ns,ns,nm), &
#else /* NDIMS == 3 */
edges(NDIMS,ns,ns,nm), corners(ns,ns,nm), &
#endif /* NDIMS == 3 */
stat = status)
if (status == 0) then
fields = -1
children = -1
#if NDIMS == 3
faces = -1
#endif /* NDIMS == 3 */
edges = -1
corners = -1
bounds = 0.0d+00
l = 0
pmeta => list_meta
do while(associated(pmeta))
l = l + 1
fields( 1,l) = pmeta%id
fields( 2,l) = pmeta%process
fields( 3,l) = pmeta%level
fields( 4,l) = pmeta%conf
fields( 5,l) = pmeta%refine
fields( 6,l) = pmeta%pos(1)
fields( 7,l) = pmeta%pos(2)
#if NDIMS == 3
fields( 8,l) = pmeta%pos(3)
#endif /* NDIMS == 3 */
fields( 9,l) = pmeta%coords(1)
fields(10,l) = pmeta%coords(2)
#if NDIMS == 3
fields(11,l) = pmeta%coords(3)
#endif /* NDIMS == 3 */
if (pmeta%leaf) fields(12,l) = 1
if (associated(pmeta%data) ) fields(13,l) = 1
if (associated(pmeta%parent)) fields(14,l) = pmeta%parent%id
do p = 1, nc
if (associated(pmeta%child(p)%ptr)) &
children(p,l) = pmeta%child(p)%ptr%id
end do
#if NDIMS == 2
do j = 1, ns
do i = 1, ns
do n = 1, NDIMS
if (associated(pmeta%edges(i,j,n)%ptr)) &
edges(n,i,j,l) = pmeta%edges(i,j,n)%ptr%id
end do ! NDIMS
if (associated(pmeta%corners(i,j)%ptr)) &
corners(i,j,l) = pmeta%corners(i,j)%ptr%id
end do
end do
#endif /* NDIMS == 2 */
#if NDIMS == 3
do k = 1, ns
do j = 1, ns
do i = 1, ns
do n = 1, NDIMS
if (associated(pmeta%faces(i,j,k,n)%ptr)) &
faces(n,i,j,k,l) = pmeta%faces(i,j,k,n)%ptr%id
if (associated(pmeta%edges(i,j,k,n)%ptr)) &
edges(n,i,j,k,l) = pmeta%edges(i,j,k,n)%ptr%id
end do ! NDIMS
if (associated(pmeta%corners(i,j,k)%ptr)) &
corners(i,j,k,l) = pmeta%corners(i,j,k)%ptr%id
end do
end do
end do
#endif /* NDIMS == 3 */
bounds(1,:,l) = [ pmeta%xmin, pmeta%xmax ]
bounds(2,:,l) = [ pmeta%ymin, pmeta%ymax ]
#if NDIMS == 3
bounds(3,:,l) = [ pmeta%zmin, pmeta%zmax ]
#endif /* NDIMS == 3 */
pmeta => pmeta%next
end do
write(fname,"(a,'.bin')") "metablock_fields"
bytes = size(fields, kind=8) * kind(fields)
call write_binary_xml(dname, fname, c_loc(fields), bytes, dtype, digest)
call write_attribute_xml(lun, "fields", fname, 'int32', &
shape(fields), bytes, dtype, digest)
write(fname,"(a,'.bin')") "metablock_children"
bytes = size(children, kind=8) * kind(children)
call write_binary_xml(dname, fname, c_loc(children), &
bytes, dtype, digest)
call write_attribute_xml(lun, "children", fname, 'int32', &
shape(children), bytes, dtype, digest)
#if NDIMS == 3
write(fname,"(a,'.bin')") "metablock_faces"
bytes = size(faces, kind=8) * kind(faces)
call write_binary_xml(dname, fname, c_loc(faces), bytes, dtype, digest)
call write_attribute_xml(lun, "faces", fname, 'int32', &
shape(faces), bytes, dtype, digest)
#endif /* NDIMS == 3 */
write(fname,"(a,'.bin')") "metablock_edges"
bytes = size(edges, kind=8) * kind(edges)
call write_binary_xml(dname, fname, c_loc(edges), bytes, dtype, digest)
call write_attribute_xml(lun, "edges", fname, 'int32', &
shape(edges), bytes, dtype, digest)
write(fname,"(a,'.bin')") "metablock_corners"
bytes = size(corners, kind=8) * kind(corners)
call write_binary_xml(dname, fname, c_loc(corners), &
bytes, dtype, digest)
call write_attribute_xml(lun, "corners", fname, 'int32', &
shape(corners), bytes, dtype, digest)
write(fname,"(a,'.bin')") "metablock_bounds"
bytes = size(bounds, kind=8) * kind(bounds)
call write_binary_xml(dname, fname, c_loc(bounds), bytes, dtype, digest)
call write_attribute_xml(lun, "bounds", fname, 'float64', &
shape(bounds), bytes, dtype, digest)
if (nmodes > 0) then
write(fname,"(a,'.bin')") "forcing_coefficients"
bytes = size(fcoefs, kind=8) * kind(fcoefs)
call write_binary_xml(dname, fname, c_loc(fcoefs), &
bytes, dtype, digest)
call write_attribute_xml(lun, "forcing", fname, 'complex64', &
shape(fcoefs), bytes, dtype, digest)
end if
#if NDIMS == 3
deallocate(fields, children, bounds, faces, &
edges, corners, stat=status)
#else /* NDIMS == 3 */
deallocate(fields, children, bounds, edges, corners, stat=status)
#endif /* NDIMS == 3 */
if (status /= 0) &
call print_message(loc, "Could not deallocate space of metablocks!")
else
call print_message(loc, "Cannot allocate space for metablocks!")
return
end if
#if NDIMS == 3
#endif /* NDIMS == 3 */
write(lun,"(a)") '</BinaryFiles>'
write(lun,"(a)") '</AMUNFile>'
close(lun)
end if
write(fname,sfmt) 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)
call write_attribute_xml(lun, "nregs" , nr)
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
allocate(ids(nd), stat = status)
if (status == 0) then
l = 0
pdata => list_data
do while(associated(pdata))
l = l + 1
ids(l) = pdata%meta%id
write(aname,"('_',i6.6)") l
write(fname,"('datablock_prim_',i6.6,a,'.bin')") nproc, trim(aname)
bytes = size(pdata%q, kind=8) * kind(pdata%q)
call write_binary_xml(dname, fname, c_loc(pdata%q), &
bytes, dtype, digest)
call write_attribute_xml(lun, "prim" // trim(aname), fname, &
'float64', shape(pdata%q), bytes, dtype, digest)
write(fname,"('datablock_cons_',i6.6,a,'.bin')") nproc, trim(aname)
bytes = size(pdata%uu, kind=8) * kind(pdata%uu)
call write_binary_xml(dname, fname, c_loc(pdata%uu), &
bytes, dtype, digest)
call write_attribute_xml(lun, "cons" // trim(aname), fname, &
'float64', shape(pdata%uu), bytes, dtype, digest)
pdata => pdata%next
end do
write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "ids", nproc
bytes = size(ids, kind=8) * kind(ids)
call write_binary_xml(dname, fname, c_loc(ids), bytes, dtype, digest)
call write_attribute_xml(lun, "ids", fname, 'int32', &
shape(ids), bytes, dtype, digest)
if (allocated(ids)) deallocate(ids)
else
call print_message(loc, "Cannot allocate space for datablocks!")
status = 1001
return
end if
end if
allocate(seeds(4,nseeds), stat = status)
if (status == 0) then
call get_seeds(seeds(:,:))
write(fname,"(a,'_',a,'_',i6.6,'.bin')") "random", "seeds", nproc
bytes = size(seeds, kind=8) * kind(seeds)
call write_binary_xml(dname, fname, c_loc(seeds), bytes, dtype, digest)
call write_attribute_xml(lun, "seeds", fname, 'int64', &
shape(seeds), bytes, dtype, digest)
if (allocated(seeds)) deallocate(seeds)
else
call print_message(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 store_restart_snapshot_xml
!
!===============================================================================
!
! subroutine STORE_SNAPSHOT_XML:
! -----------------------------
!
! Subroutine stores a regular snapshot, i.e. parameters, leafs and data blocks
! using the XML format for metadata and binary format for meta and data
! block fields.
!
! Arguments:
!
! problem - the problem's name;
! status - the status flag to inform if subroutine succeeded or failed;
!
!===============================================================================
!
subroutine store_snapshot_xml(problem, status)
use blocks , only : block_meta, block_data, list_meta, list_data
use blocks , only : get_dblocks, get_nleafs
use coordinates , only : nn => bcells, ncells, nghosts, minlev, maxlev
use coordinates , only : xmin, xmax, ymin, ymax
#if NDIMS == 3
use coordinates , only : zmin, zmax
#endif /* NDIMS == 3 */
use coordinates , only : bdims => domain_base_dims
use equations , only : eqsys, eos, nv, pvars, adiabatic_index, csnd
use evolution , only : step, time, dt, cfl, glm_alpha
use helpers , only : print_message
use iso_c_binding, only : c_loc
use mpitools , only : nprocs, nproc
use parameters , only : get_parameter_file
use sources , only : viscosity, resistivity
implicit none
character(len=*), intent(in) :: problem
integer , intent(out) :: status
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
type(block_meta), pointer :: pmeta
type(block_data), pointer :: pdata
integer(kind=4), dimension(:) , allocatable, target :: ids
integer(kind=4), dimension(:,:) , allocatable, target :: fields
real(kind=8) , dimension(:,:,:) , allocatable, target :: bounds
real(kind=8) , dimension(:,:,:,:), allocatable, target :: array
character(len=*), parameter :: loc = "IO::store_snapshot_xml()"
character(len=*), parameter :: sfmt = "(a,a,'_',i6.6,'.',a)"
!-------------------------------------------------------------------------------
!
status = 0
write(dname, "('snapshot-',i9.9)") isnap
#ifdef __INTEL_COMPILER
inquire(directory = dname, exist = test)
do while(.not. test)
if (.not. test) call execute_command_line("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 execute_command_line("mkdir -p " // trim(dname))
inquire(file = dname, exist = test)
end do
#endif /* __INTEL_COMPILER */
dname = trim(dname) // "/"
nd = get_dblocks()
nl = get_nleafs()
vars = ""
do l = 1, nv
vars = trim(vars) // " " // trim(pvars(l))
end do
if (nproc == 0) then
call get_parameter_file(fname, status)
if (status == 0) then
call execute_command_line("cp -a " // trim(fname) // " " // trim(dname))
else
call print_message(loc, "Cannot get the location of parameter file!")
return
end if
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)
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>'
allocate(fields(8,nl), bounds(3,2,nl), stat = status)
if (status == 0) then
fields = -1
bounds = 0.0d+00
l = 0
pmeta => list_meta
do while(associated(pmeta))
if (pmeta%leaf) then
l = l + 1
fields(1,l) = pmeta%id
fields(2,l) = pmeta%level
fields(3,l) = pmeta%coords(1)
fields(4,l) = pmeta%coords(2)
#if NDIMS == 3
fields(5,l) = pmeta%coords(3)
#endif /* NDIMS == 3 */
bounds(1,:,l) = [ pmeta%xmin, pmeta%xmax ]
bounds(2,:,l) = [ pmeta%ymin, pmeta%ymax ]
#if NDIMS == 3
bounds(3,:,l) = [ pmeta%zmin, pmeta%zmax ]
#endif /* NDIMS == 3 */
end if
pmeta => pmeta%next
end do
write(fname,"(a,'.bin')") "metablock_fields"
dbytes = size(fields, kind=8) * kind(fields)
call write_binary_xml(dname, fname, c_loc(fields), &
dbytes, hash_type, ddigest, cbytes, cdigest)
call write_attribute_xml(lun, "fields", fname, 'int32', &
shape(fields), dbytes, hash_type, ddigest, cbytes, cdigest)
write(fname,"(a,'.bin')") "metablock_bounds"
dbytes = size(bounds, kind=8) * kind(bounds)
call write_binary_xml(dname, fname, c_loc(bounds), &
dbytes, hash_type, ddigest, cbytes, cdigest)
call write_attribute_xml(lun, "bounds", fname, 'float64', &
shape(bounds), dbytes, hash_type, ddigest, cbytes, cdigest)
if (allocated(fields)) deallocate(fields)
if (allocated(bounds)) deallocate(bounds)
else
call print_message(loc, "Cannot allocate space for metablocks!")
status = 1001
return
end if
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,sfmt) 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), array(nn,nn,nn,nd), stat = status)
#else /* NDIMS == 3 */
allocate(ids(nd), array(nn,nn, 1,nd), stat = status)
#endif /* NDIMS == 3 */
if (status == 0) then
l = 0
pdata => list_data
do while(associated(pdata))
l = l + 1
ids(l) = pdata%meta%id
pdata => pdata%next
end do ! data blocks
write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", "ids", nproc
dbytes = size(ids, kind=8) * kind(ids)
call write_binary_xml(dname, fname, c_loc(ids), &
dbytes, hash_type, ddigest, cbytes, cdigest)
call write_attribute_xml(lun, "ids", fname, 'int32', shape(ids), &
dbytes, hash_type, ddigest, cbytes, cdigest)
dbytes = size(array, kind=8) * kind(array)
do p = 1, nv
l = 0
pdata => list_data
do while(associated(pdata))
l = l + 1
array(:,:,:,l) = pdata%q(p,:,:,:)
pdata => pdata%next
end do
write(fname,"(a,'_',a,'_',i6.6,'.bin')") "datablock", &
trim(pvars(p)), nproc
call write_binary_xml(dname, fname, c_loc(array), &
dbytes, hash_type, ddigest, cbytes, cdigest)
call write_attribute_xml(lun, pvars(p), fname, 'float64', &
shape(array), dbytes, hash_type, ddigest, cbytes, cdigest)
end do
if (allocated(ids)) deallocate(ids)
if (allocated(array)) deallocate(array)
else
call print_message(loc, "Cannot allocate space for datablocks!")
status = 1001
return
end if ! allocation
end if
write(lun,"(a)") '</BinaryFiles>'
write(lun,"(a)") '</AMUNFile>'
close(lun)
!-------------------------------------------------------------------------------
!
end subroutine store_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_type - the data type of the input data;
! data_shape - the shape of the input data;
! digest_string - the digest type string;
! 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_type, data_shape, &
data_bytes, digest_type, data_digest, &
compressed_bytes, compressed_digest)
use compression, only : compression_suffix
use hash , only : hash_name, digest_string
implicit none
integer , intent(in) :: lun
character(len=*) , intent(in) :: aname, filename, data_type
integer , intent(in) :: digest_type
integer, dimension(:) , intent(in) :: data_shape
integer(kind=8) , intent(in) :: data_bytes, data_digest
integer(kind=8) , optional, intent(in) :: compressed_bytes
integer(kind=8) , optional, intent(in) :: compressed_digest
character(len=256) :: fname
character(len=1024) :: string
character(len=128) :: str
integer :: n
!-------------------------------------------------------------------------------
!
fname = filename
string = '<Attribute type="string" name="' // trim(adjustl(aname)) // '"'
string = trim(string) // ' data_type="' // trim(adjustl(data_type)) // '"'
str = ""
do n = 1, size(data_shape)
write(str,"(a,1x,i0)") trim(str), data_shape(n)
end do
string = trim(string) // ' dimensions="' // trim(adjustl(str)) // '"'
write(str,"(1i0)") data_bytes
string = trim(string) // ' size="' // trim(adjustl(str)) // '"'
str = hash_name(digest_type)
string = trim(string) // ' digest_type="' // trim(str) // '"'
call digest_string(data_digest, str)
string = trim(string) // ' digest="' // trim(adjustl(str)) // '"'
if (present(compressed_bytes)) then
if (compressed_bytes > 0) then
fname = trim(fname) // trim(compression_suffix)
write(str,"(1i0)") compressed_bytes
string = trim(string) // &
' compression_format="' // trim(adjustl(cformat)) // &
'" compressed_size="' // trim(adjustl(str)) // '"'
if (present(compressed_digest)) then
if (compressed_digest /= 0) then
call digest_string(compressed_digest, str)
string = trim(string) // &
' compressed_digest="' // trim(adjustl(str)) // '"'
end if
end if
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_ptr - the pointer to the array to store;
! array_bytes - the size of the array in bytes;
! digest_type - the type of digest to hash the data;
! array_digest - the digest of the original 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_ptr, array_bytes, digest_type, &
array_digest, compressed_bytes, compressed_digest)
use compression , only : get_compression, compression_bound, compress
use compression , only : compression_suffix
use hash , only : digest
use iso_c_binding, only : c_ptr, c_loc, c_f_pointer
implicit none
character(len=*), intent(in) :: path, name
type(c_ptr) , intent(in) :: array_ptr
integer(kind=8) , intent(in) :: array_bytes
integer , intent(in) :: digest_type
integer(kind=8), optional , intent(out) :: compressed_bytes
integer(kind=8), optional , intent(out) :: array_digest
integer(kind=8), optional , intent(out) :: compressed_digest
character(len=512) :: fname
integer :: lun = 123
logical :: written
integer :: status
integer(kind=1), dimension(:), pointer :: array
integer(kind=1), dimension(:), allocatable, target :: buffer
type(c_ptr) :: buffer_ptr
!-------------------------------------------------------------------------------
!
status = 0
written = .false.
if (present(array_digest)) &
array_digest = digest(array_ptr, array_bytes, digest_type)
! try to compress the array and store it if compression was successful
!
if (present(compressed_bytes) .and. get_compression() > 0) then
compressed_bytes = compression_bound(array_bytes)
allocate(buffer(compressed_bytes), stat = status)
buffer_ptr = c_loc(buffer)
if (status == 0) then
call compress(array_ptr, array_bytes, buffer_ptr, compressed_bytes)
if (compressed_bytes > 0 .and. compressed_bytes < array_bytes) then
write(fname,"(a,'/',a,a)") trim(path), trim(name), &
trim(compression_suffix)
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 = digest(buffer_ptr, &
compressed_bytes, digest_type)
else
compressed_bytes = 0
compressed_digest = 0
end if
deallocate(buffer)
end if
end if
! compression failed or no compression was used, so write the original array
!
if (.not. written) then
call c_f_pointer(array_ptr, array, [ array_bytes ])
write(fname,"(a,'/',a)") trim(path), trim(name)
open(newunit=lun, file=fname, 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's name;
! pvalue - the parameter's value;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine read_snapshot_parameter_string_h5(pname, pvalue, status)
use helpers, only : print_message
implicit none
character(len=*), intent(in) :: pname
character(len=*), intent(inout) :: pvalue
integer , intent(inout) :: status
character(len=255) :: fname
logical :: flag
integer(hid_t) :: file_id, grp_id
character(len=*), parameter :: loc = &
'IO::read_snapshot_parameter_string_h5()'
!-------------------------------------------------------------------------------
!
status = 0
write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, 0
inquire(file=fname, exist=flag)
if (.not. flag) then
call print_message(loc, "Restart snapshot " // trim(fname) // &
" does not exist!")
status = 1
return
end if
call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status)
if (status /= 0) then
call print_message(loc, "Could not open " // trim(fname) // "!")
return
end if
call h5gopen_f(file_id, 'attributes', grp_id, status)
if (status == 0) then
call restore_attribute_h5(grp_id, pname, pvalue, status)
if (status /= 0) &
call print_message(loc, "Failed to restore attribute" // &
trim(pname) // "!")
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'attributes'!")
else
call print_message(loc, "Could not open group 'attributes'!")
end if
call h5fclose_f(file_id, status)
if (status /= 0) &
call print_message(loc, "Could not close " // trim(fname) // "!")
!-------------------------------------------------------------------------------
!
end subroutine read_snapshot_parameter_string_h5
!
!===============================================================================
!
! subroutine READ_SNAPSHOT_PARAMETER_INTEGER_H5:
! ---------------------------------------------
!
! Subroutine reads an integer parameter from the restart snapshot.
!
! Arguments:
!
! pname - the parameter's name;
! pvalue - the parameter's value;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine read_snapshot_parameter_integer_h5(pname, pvalue, status)
use helpers, only : print_message
implicit none
character(len=*), intent(in) :: pname
integer , intent(inout) :: pvalue
integer , intent(inout) :: status
character(len=255) :: fname
logical :: flag
integer(hid_t) :: file_id, grp_id
character(len=*), parameter :: loc = &
'IO::read_snapshot_parameter_integer_h5()'
!-------------------------------------------------------------------------------
!
status = 0
write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, 0
inquire(file=fname, exist=flag)
if (.not. flag) then
call print_message(loc, "Restart snapshot " // trim(fname) // &
" does not exist!")
status = 1
return
end if
call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status)
if (status /= 0) then
call print_message(loc, "Could not open " // trim(fname) // "!")
return
end if
call h5gopen_f(file_id, 'attributes', grp_id, status)
if (status == 0) then
call restore_attribute_h5(grp_id, pname, &
H5T_NATIVE_INTEGER, 1, pvalue, status)
if (status /= 0) &
call print_message(loc, "Failed to restore attribute" // &
trim(pname) // "!")
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'attributes'!")
else
call print_message(loc, "Could not open group 'attributes'!")
end if
call h5fclose_f(file_id, status)
if (status /= 0) &
call print_message(loc, "Could not close " // trim(fname) // "!")
!-------------------------------------------------------------------------------
!
end subroutine 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's name;
! pvalue - the parameter's value;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine read_snapshot_parameter_double_h5(pname, pvalue, status)
use helpers, only : print_message
implicit none
character(len=*), intent(in) :: pname
real(kind=8) , intent(inout) :: pvalue
integer , intent(inout) :: status
character(len=255) :: fname
logical :: flag
integer(hid_t) :: file_id, grp_id
character(len=*), parameter :: loc = &
'IO::read_snapshot_parameter_double_h5()'
!-------------------------------------------------------------------------------
!
status = 0
write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, 0
inquire(file=fname, exist=flag)
if (.not. flag) then
call print_message(loc, "Restart snapshot " // trim(fname) // &
" does not exist!")
status = 1
return
end if
call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status)
if (status /= 0) then
call print_message(loc, "Could not open " // trim(fname) // "!")
return
end if
call h5gopen_f(file_id, 'attributes', grp_id, status)
if (status == 0) then
call restore_attribute_h5(grp_id, pname, &
H5T_NATIVE_DOUBLE, 1, pvalue, status)
if (status /= 0) &
call print_message(loc, "Failed to restore attribute" // &
trim(pname) // "!")
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'attributes'!")
else
call print_message(loc, "Could not open group 'attributes'!")
end if
call h5fclose_f(file_id, status)
if (status /= 0) &
call print_message(loc, "Could not close " // trim(fname) // "!")
!-------------------------------------------------------------------------------
!
end subroutine 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:
!
! status - the subroutine call status;
!
!===============================================================================
!
subroutine read_restart_snapshot_h5(status)
use blocks , only : change_blocks_process
use forcing , only : einj
use helpers , only : print_message
#ifdef MPI
use mesh , only : redistribute_blocks
#endif /* MPI */
use mpitools, only : nprocs, nproc
implicit none
integer, intent(out) :: status
character(len=255) :: fname
integer(hid_t) :: file_id, grp_id
integer :: nfiles, last_id, n, i, nd, nr, nl, nu, il, iu
logical :: flag
real(kind=8) :: deinj
character(len=*), parameter :: loc = 'IO::read_restart_snapshot_h5()'
!-------------------------------------------------------------------------------
!
!! 1. RESTORE PARAMETERS AND META BLOCKS FROM THE FIRST FILE
!!
write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, 0
inquire(file=fname, exist=flag)
if (.not. flag) then
call print_message(loc, &
"Restart snapshot '" // trim(fname) // "' not found!")
status = 1
return
end if
call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status)
if (status /= 0) then
call print_message(loc, "Could not open '" // trim(fname) // "'!")
return
end if
call read_snapshot_parameter_h5('nprocs' , nfiles , status)
call read_snapshot_parameter_h5('last_id', last_id, status)
allocate(block_array(last_id))
call restore_attributes_h5(file_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not restore attributes from '" // trim(fname) // "'!")
call restore_metablocks_h5(file_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not restore metablocks from '" // trim(fname) // "'!")
call h5fclose_f(file_id, status)
if (status /= 0) then
call print_message(loc, "Could not close '" // trim(fname) // "'!")
return
end if
!! 1. RESTORE DATA BLOCKS
!!
! separate data blocks reading into two cases, when the number of processors is
! larger or equal to the number of files, and when we have less processors than
! files
!
if (nfiles <= nprocs .and. nproc < nfiles) then
write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, nproc
inquire(file=fname, exist=flag)
if (.not. flag) then
call print_message(loc, &
"Restart snapshot '" // trim(fname) // "' not found!")
status = 1
return
end if
call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status)
if (status /= 0) then
call print_message(loc, "Could not open '" // trim(fname) // "'!")
return
end if
call restore_datablocks_h5(file_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not restore datablocks from '" // trim(fname) // "'!")
call h5gopen_f(file_id, 'attributes', grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not open group 'attributes'!")
return
end if
call restore_attribute_h5(grp_id, 'einj', &
H5T_NATIVE_DOUBLE, 1, einj, status)
if (status /= 0) &
call print_message(loc, "Could not get the injected energy!")
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'attributes'!")
call h5fclose_f(file_id, status)
if (status /= 0) then
call print_message(loc, "Could not close '" // trim(fname) // "'!")
return
end if
end if ! nproc < nfiles
! if there are more files than processes, divide the files equally between
! processes
!
if (nprocs < nfiles) then
nl = 0
nd = nfiles / nprocs
nr = mod(nfiles, nprocs)
do n = 0, nprocs - 1
if (n < nr) then
il = n * (nd + 1)
iu = il + nd
else
il = n * nd + nr
iu = il + nd - 1
end if
do i = il, iu
call change_blocks_process(i, n)
end do
if (n == nproc) then
nl = il
nu = iu
end if
end do
do n = nl, nu
write(fname, "(a,'r',i6.6,'_',i5.5,'.h5')") trim(respath), nrest, n
inquire(file=fname, exist=flag)
if (.not. flag) then
call print_message(loc, &
"Restart snapshot '" // trim(fname) // "' not found!")
status = 1
return
end if
call h5fopen_f(fname, H5F_ACC_RDONLY_F, file_id, status)
if (status /= 0) then
call print_message(loc, "Could not open '" // trim(fname) // "'!")
return
end if
call restore_datablocks_h5(file_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not restore datablocks from '" // trim(fname) // "'!")
call h5gopen_f(file_id, 'attributes', grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not open group 'attributes'!")
return
end if
call restore_attribute_h5(grp_id, 'einj', &
H5T_NATIVE_DOUBLE, 1, deinj, status)
if (status /= 0) &
call print_message(loc, "Could not get the injected energy!")
einj = einj + deinj
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'attributes'!")
call h5fclose_f(file_id, status)
if (status /= 0) then
call print_message(loc, "Could not close '" // trim(fname) // "'!")
return
end if
end do
end if
if (allocated(block_array)) deallocate(block_array)
#ifdef MPI
call redistribute_blocks(status)
#endif /* MPI */
!-------------------------------------------------------------------------------
!
end subroutine read_restart_snapshot_h5
!
!===============================================================================
!
! subroutine STORE_RESTART_SNAPSHOT_H5:
! ------------------------------------
!
! Subroutine stores restart snapshots in the HDF5 format.
!
! Arguments:
!
! problem - the problem's name;
! nrun - the snapshot number;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine store_restart_snapshot_h5(problem, nrun, status)
use helpers , only : print_message
use mpitools, only : nproc
implicit none
character(len=*), intent(in) :: problem
integer , intent(in) :: nrun
integer , intent(out) :: status
character(len=255) :: fname
integer(hid_t) :: file_id
character(len=*), parameter :: loc = 'IO::store_restart_snapshot_h5()'
!-------------------------------------------------------------------------------
!
write(fname, "('r',i6.6,'_',i5.5,'.h5')") nrun, nproc
call h5fcreate_f(fname, H5F_ACC_TRUNC_F, file_id, status)
if (status /= 0) then
call print_message(loc, "Could not create file " // trim(fname))
return
end if
call store_attributes_h5(file_id, problem, .true., status)
call store_metablocks_h5(file_id, status)
call store_datablocks_h5(file_id, status)
call h5fclose_f(file_id, status)
if (status /= 0) &
call print_message(loc, "Could not close file " // trim(fname))
!-------------------------------------------------------------------------------
!
end subroutine store_restart_snapshot_h5
!
!===============================================================================
!
! subroutine STORE_SNAPSHOT_H5:
! ----------------------------
!
! Subroutine stores the current simulation snapshot, i.e. parameters,
! coordinates and variables as a HDF5 file.
!
! Arguments:
!
! problem - the problem's name;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine store_snapshot_h5(problem, status)
use helpers , only : print_message
use mpitools, only : nproc
implicit none
character(len=*), intent(in) :: problem
integer , intent(out) :: status
character(len=255) :: fname
integer(hid_t) :: file_id
character(len=*), parameter :: loc = 'IO::store_snapshot_h5()'
!-------------------------------------------------------------------------------
!
write(fname,"('p',i6.6,'_',i5.5,'.h5')") isnap, nproc
call h5fcreate_f(fname, H5F_ACC_TRUNC_F, file_id, status)
if (status < 0) then
call print_message(loc, "Could not create file " // trim(fname))
return
end if
call store_attributes_h5(file_id, problem, .false., status)
call store_coordinates_h5(file_id, status)
call store_variables_h5(file_id, status)
call h5fclose_f(file_id, status)
if (status < 0) &
call print_message(loc, "Could not close file " // trim(fname))
!-------------------------------------------------------------------------------
!
end subroutine store_snapshot_h5
!
!===============================================================================
!
! subroutine RESTORE_ATTRIBUTES_H5:
! --------------------------------
!
! Subroutine restores global attributes from an HDF5 file provided by its
! identifier.
!
! Arguments:
!
! loc_id - the HDF5 file identifier;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine restore_attributes_h5(loc_id, status)
use blocks , only : block_meta
use blocks , only : append_metablock
use blocks , only : set_last_id
use blocks , only : get_mblocks, get_dblocks, get_nleafs
use coordinates , only : ncells
use coordinates , only : xmin, xmax, ymin, ymax, zmin, zmax
use equations , only : cmax, cmax2, cglm
use evolution , only : step, time, dt, dth, dte
use evolution , only : niterations, nrejections, errs
use forcing , only : nmodes, fcoefs
use helpers , only : print_message
use random , only : set_seeds, gentype
implicit none
integer(hid_t), intent(in) :: loc_id
integer , intent(out) :: status
type(block_meta), pointer :: pmeta
integer(hid_t) :: grp_id
integer :: l
integer :: lndims, lmblocks, lnleafs, llast_id
integer :: lncells, lnseeds, lnmodes
integer(hsize_t), dimension(2) :: dims
integer(kind=8), dimension(:,:), allocatable :: seeds
real(kind=8) , dimension(:,:), allocatable :: coefs
character(len=*), parameter :: loc = 'IO::restore_attributes_h5()'
!-------------------------------------------------------------------------------
!
call h5gopen_f(loc_id, 'attributes', grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not open group 'attributes'!")
return
end if
call restore_attribute_h5(grp_id, 'ndims', &
H5T_NATIVE_INTEGER, 1, lndims, status)
call restore_attribute_h5(grp_id, 'mblocks', &
H5T_NATIVE_INTEGER, 1, lmblocks, status)
call restore_attribute_h5(grp_id, 'nleafs', &
H5T_NATIVE_INTEGER, 1, lnleafs, status)
call restore_attribute_h5(grp_id, 'last_id', &
H5T_NATIVE_INTEGER, 1, llast_id, status)
call restore_attribute_h5(grp_id, 'ncells', &
H5T_NATIVE_INTEGER, 1, lncells, status)
call restore_attribute_h5(grp_id, 'nseeds', &
H5T_NATIVE_INTEGER, 1, lnseeds, status)
call restore_attribute_h5(grp_id, 'step', &
H5T_NATIVE_INTEGER, 1, step, status)
call restore_attribute_h5(grp_id, 'isnap', &
H5T_NATIVE_INTEGER, 1, isnap, status)
call restore_attribute_h5(grp_id, 'niterations', &
H5T_NATIVE_INTEGER, 1, niterations, status)
call restore_attribute_h5(grp_id, 'nrejections', &
H5T_NATIVE_INTEGER, 1, nrejections, status)
call restore_attribute_h5(grp_id, 'nmodes', &
H5T_NATIVE_INTEGER, 1, lnmodes, status)
call restore_attribute_h5(grp_id, 'xmin', &
H5T_NATIVE_DOUBLE, 1, xmin, status)
call restore_attribute_h5(grp_id, 'xmax', &
H5T_NATIVE_DOUBLE, 1, xmax, status)
call restore_attribute_h5(grp_id, 'ymin', &
H5T_NATIVE_DOUBLE, 1, ymin, status)
call restore_attribute_h5(grp_id, 'ymax', &
H5T_NATIVE_DOUBLE, 1, ymax, status)
call restore_attribute_h5(grp_id, 'zmin', &
H5T_NATIVE_DOUBLE, 1, zmin, status)
call restore_attribute_h5(grp_id, 'zmax', &
H5T_NATIVE_DOUBLE, 1, zmax, status)
call restore_attribute_h5(grp_id, 'time', &
H5T_NATIVE_DOUBLE, 1, time, status)
call restore_attribute_h5(grp_id, 'dt' , &
H5T_NATIVE_DOUBLE, 1, dt , status)
call restore_attribute_h5(grp_id, 'dth' , &
H5T_NATIVE_DOUBLE, 1, dth , status)
call restore_attribute_h5(grp_id, 'dte' , &
H5T_NATIVE_DOUBLE, 1, dte , status)
call restore_attribute_h5(grp_id, 'cmax', &
H5T_NATIVE_DOUBLE, 1, cmax, status)
cmax2 = cmax * cmax
call restore_attribute_h5(grp_id, 'cglm', &
H5T_NATIVE_DOUBLE, 1, cglm, status)
call restore_attribute_h5(grp_id, 'errs', &
H5T_NATIVE_DOUBLE, 3, errs, status)
call set_last_id(llast_id)
call h5gclose_f(grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not close group 'attributes'!")
return
end if
if (lndims /= NDIMS) then
call print_message(loc, "The number of dimensions does not match!")
status = 1
return
end if
if (lncells /= ncells) then
call print_message(loc, "The block dimensions do not match!")
status = 1
return
end if
do l = 1, lmblocks
call append_metablock(pmeta, status)
if (status /= 0) then
call print_message(loc, "Could not append a new metablock!")
return
end if
end do
if (lmblocks /= get_mblocks()) then
call print_message(loc, "The number of metablocks does not match!")
return
end if
if (lnmodes > 0) then
if (lnmodes == nmodes) then
call h5gopen_f(loc_id, 'forcing', grp_id, status)
if (status == 0) then
dims = shape(fcoefs)
allocate(coefs(dims(1),dims(2)), stat=status)
if (status == 0) then
call read_dataset_h5(grp_id, 'fcoefs_real', &
H5T_NATIVE_DOUBLE, dims, coefs, status)
fcoefs = cmplx(1.0d+00, 0.0+00, kind=8) * coefs
call read_dataset_h5(grp_id, 'fcoefs_imag', &
H5T_NATIVE_DOUBLE, dims, coefs, status)
fcoefs = fcoefs + cmplx(0.0d+00, 1.0+00, kind=8) * coefs
deallocate(coefs, stat=status)
if (status /= 0) &
call print_message(loc, &
"Could not deallocate space of the forcing coefficients!")
else
call print_message(loc, &
"Could not allocate space for the forcing coefficients!")
end if
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'forcing'!")
else
call print_message(loc, "Could not open group 'forcing'!")
end if
else
call print_message(loc, "The number of driving modes has changed!")
end if
end if
if (trim(gentype) == "same") then
call h5gopen_f(loc_id, 'random', grp_id, status)
if (status == 0) then
dims = [ 4, lnseeds ]
allocate(seeds(dims(1),dims(2)), stat=status)
if (status == 0) then
call read_dataset_h5(grp_id, 'seeds', &
H5T_STD_I64LE, dims, seeds, status)
call set_seeds(lnseeds, seeds(:,:), .false.)
deallocate(seeds, stat=status)
if (status /= 0) &
call print_message(loc, &
"Could not deallocate space of the random seeds!")
else
call print_message(loc, &
"Could not allocate space for the random seeds!")
end if
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'random'!")
else
call print_message(loc, "Could not open group 'random'!")
end if
end if
!-------------------------------------------------------------------------------
!
end subroutine restore_attributes_h5
!
!===============================================================================
!
! subroutine STORE_ATTRIBUTES_H5:
! ------------------------------
!
! Subroutine stores the global simulation attributes in the specific location.
!
! Arguments:
!
! loc_id - the HDF5 file identifier;
! problem - the problem's name;
! restart - the flag indicating to store attributes for restart snapshot;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine store_attributes_h5(loc_id, problem, restart, status)
use blocks , only : get_mblocks, get_dblocks, get_nleafs
use blocks , only : get_last_id, nregs, nchildren
use coordinates, only : minlev, maxlev
use coordinates, only : bcells, ncells, nghosts
use coordinates, only : bdims => domain_base_dims
use coordinates, only : xmin, xmax, ymin, ymax, zmin, zmax
use coordinates, only : periodic
use equations , only : eqsys, eos, adiabatic_index, csnd, cmax, cglm, nv
use evolution , only : step, time, dt, dth, dte, cfl, glm_alpha, errs
use evolution , only : atol, rtol, mrej, niterations, nrejections
use forcing , only : nmodes, einj, fcoefs
use helpers , only : print_message
use mpitools , only : nprocs, nproc
use random , only : gentype, nseeds, get_seeds
use sources , only : viscosity, resistivity
implicit none
integer(hid_t) , intent(in) :: loc_id
character(len=*), intent(in) :: problem
logical , intent(in) :: restart
integer , intent(out) :: status
integer(hid_t) :: grp_id
integer(hsize_t), dimension(2) :: dims = 1
integer(kind=8), dimension(:,:), allocatable :: seeds
real(kind=8) , dimension(:,:), allocatable :: array
character(len=*), parameter :: loc = 'IO::store_attributes_h5()'
!-------------------------------------------------------------------------------
!
call store_attribute_h5(loc_id, 'code', 'AMUN', status)
call store_attribute_h5(loc_id, 'version', H5T_NATIVE_REAL, 1, 1.0, status)
call h5gcreate_f(loc_id, 'attributes', grp_id, status)
if (status == 0) then
call store_attribute_h5(grp_id, "problem", trim(problem), status)
call store_attribute_h5(grp_id, "eqsys" , trim(eqsys) , status)
call store_attribute_h5(grp_id, 'eos' , trim(eos) , status)
call store_attribute_h5(grp_id, 'nprocs', &
H5T_NATIVE_INTEGER, 1, nprocs, status)
call store_attribute_h5(grp_id, 'nproc', &
H5T_NATIVE_INTEGER, 1, nproc, status)
call store_attribute_h5(grp_id, 'nvars', &
H5T_NATIVE_INTEGER, 1, nv, status)
call store_attribute_h5(grp_id, 'ndims', &
H5T_NATIVE_INTEGER, 1, NDIMS, status)
call store_attribute_h5(grp_id, 'bdims', &
H5T_NATIVE_INTEGER, 3, bdims, status)
call store_attribute_h5(grp_id, 'xblocks', &
H5T_NATIVE_INTEGER, 1, bdims(1), status)
call store_attribute_h5(grp_id, 'yblocks', &
H5T_NATIVE_INTEGER, 1, bdims(2), status)
call store_attribute_h5(grp_id, 'zblocks', &
H5T_NATIVE_INTEGER, 1, bdims(3), status)
call store_attribute_h5(grp_id, 'minlev', &
H5T_NATIVE_INTEGER, 1, minlev, status)
call store_attribute_h5(grp_id, 'maxlev', &
H5T_NATIVE_INTEGER, 1, maxlev, status)
call store_attribute_h5(grp_id, 'ncells', &
H5T_NATIVE_INTEGER, 1, ncells, status)
call store_attribute_h5(grp_id, 'nghosts', &
H5T_NATIVE_INTEGER, 1, nghosts, status)
call store_attribute_h5(grp_id, 'bcells', &
H5T_NATIVE_INTEGER, 1, bcells, status)
call store_attribute_h5(grp_id, 'dblocks', &
H5T_NATIVE_INTEGER, 1, get_dblocks(), status)
call store_attribute_h5(grp_id, 'nleafs', &
H5T_NATIVE_INTEGER, 1, get_nleafs(), status)
call store_attribute_h5(grp_id, 'step', &
H5T_NATIVE_INTEGER, 1, step, status)
call store_attribute_h5(grp_id, 'isnap', &
H5T_NATIVE_INTEGER, 1, isnap, status)
call store_attribute_h5(grp_id, 'periodic', &
H5T_NATIVE_INTEGER, 3, periodic, status)
call store_attribute_h5(grp_id, 'adiabatic_index', &
H5T_NATIVE_DOUBLE, 1, adiabatic_index, status)
call store_attribute_h5(grp_id, 'sound_speed', &
H5T_NATIVE_DOUBLE, 1, csnd, status)
call store_attribute_h5(grp_id, 'viscosity', &
H5T_NATIVE_DOUBLE, 1, viscosity, status)
call store_attribute_h5(grp_id, 'resistivity', &
H5T_NATIVE_DOUBLE, 1, resistivity, status)
call store_attribute_h5(grp_id, 'xmin', &
H5T_NATIVE_DOUBLE, 1, xmin, status)
call store_attribute_h5(grp_id, 'xmax', &
H5T_NATIVE_DOUBLE, 1, xmax, status)
call store_attribute_h5(grp_id, 'ymin', &
H5T_NATIVE_DOUBLE, 1, ymin, status)
call store_attribute_h5(grp_id, 'ymax', &
H5T_NATIVE_DOUBLE, 1, ymax, status)
call store_attribute_h5(grp_id, 'zmin', &
H5T_NATIVE_DOUBLE, 1, zmin, status)
call store_attribute_h5(grp_id, 'zmax', &
H5T_NATIVE_DOUBLE, 1, zmax, status)
call store_attribute_h5(grp_id, 'time', &
H5T_NATIVE_DOUBLE, 1, time, status)
call store_attribute_h5(grp_id, 'dt' , &
H5T_NATIVE_DOUBLE, 1, dt, status)
call store_attribute_h5(grp_id, 'cfl' , &
H5T_NATIVE_DOUBLE, 1, cfl, status)
call store_attribute_h5(grp_id, 'glm_alpha', &
H5T_NATIVE_DOUBLE, 1, glm_alpha, status)
if (restart) then
call store_attribute_h5(grp_id, 'rngtype', trim(gentype), status)
call store_attribute_h5(grp_id, 'nchildren', &
H5T_NATIVE_INTEGER, 1, nchildren, status)
call store_attribute_h5(grp_id, 'mblocks', &
H5T_NATIVE_INTEGER, 1, get_mblocks(), status)
call store_attribute_h5(grp_id, 'nregisters', &
H5T_NATIVE_INTEGER, 1, nregs, status)
call store_attribute_h5(grp_id, 'last_id', &
H5T_NATIVE_INTEGER, 1, get_last_id(), status)
call store_attribute_h5(grp_id, 'maximum_rejections', &
H5T_NATIVE_INTEGER, 1, mrej, status)
call store_attribute_h5(grp_id, 'niterations', &
H5T_NATIVE_INTEGER, 1, niterations, status)
call store_attribute_h5(grp_id, 'nrejections', &
H5T_NATIVE_INTEGER, 1, nrejections, status)
call store_attribute_h5(grp_id, 'nmodes', &
H5T_NATIVE_INTEGER, 1, nmodes, status)
call store_attribute_h5(grp_id, 'nseeds', &
H5T_NATIVE_INTEGER, 1, nseeds, status)
call store_attribute_h5(grp_id, 'dth' , &
H5T_NATIVE_DOUBLE, 1, dth, status)
call store_attribute_h5(grp_id, 'dte' , &
H5T_NATIVE_DOUBLE, 1, dte, status)
call store_attribute_h5(grp_id, 'cmax', &
H5T_NATIVE_DOUBLE, 1, cmax, status)
call store_attribute_h5(grp_id, 'cglm', &
H5T_NATIVE_DOUBLE, 1, cglm, status)
call store_attribute_h5(grp_id, 'absolute_tolerance', &
H5T_NATIVE_DOUBLE, 1, atol, status)
call store_attribute_h5(grp_id, 'relative_tolerance', &
H5T_NATIVE_DOUBLE, 1, rtol, status)
call store_attribute_h5(grp_id, 'errs', &
H5T_NATIVE_DOUBLE, 3, errs, status)
call store_attribute_h5(grp_id, 'einj', &
H5T_NATIVE_DOUBLE, 1, einj, status)
end if
call h5gclose_f(grp_id, status)
if (status < 0) &
call print_message(loc, "Could not close group 'attributes'!")
else
call print_message(loc, "Could not create group 'attributes'!")
end if
! store forcing coefficients in a different group
!
if (restart) then
call h5gcreate_f(loc_id, 'forcing', grp_id, status)
if (status >= 0) then
if (nmodes > 0) then
dims(1) = nmodes
dims(2) = NDIMS
allocate(array(nmodes,NDIMS), stat=status)
if (status == 0) then
array = real(fcoefs)
call store_dataset_h5(grp_id, 'fcoefs_real', H5T_NATIVE_DOUBLE, &
dims, array, .false., status)
if (status < 0) &
call print_message(loc, "Could not store real(fcoefs)!")
array = aimag(fcoefs)
call store_dataset_h5(grp_id, 'fcoefs_imag', H5T_NATIVE_DOUBLE, &
dims, array, .false., status)
if (status < 0) &
call print_message(loc, "Could not store imag(fcoefs)!")
deallocate(array, stat=status)
if (status /= 0) &
call print_message(loc, "Could not deallocate space for fcoefs!")
else
call print_message(loc, "Could not allocate space for fcoefs!")
end if
end if
call h5gclose_f(grp_id, status)
if (status < 0) &
call print_message(loc, "Could not close group 'forcing'!")
else
call print_message(loc, "Could not create group 'forcing'!")
end if
! store random seeds in a different group
!
call h5gcreate_f(loc_id, 'random', grp_id, status)
if (status >= 0) then
if (nseeds > 0) then
dims(1) = 4
dims(2) = nseeds
allocate(seeds(4,nseeds), stat=status)
if (status == 0) then
call get_seeds(seeds)
call store_dataset_h5(grp_id, 'seeds', H5T_STD_I64LE, &
dims, seeds, .false., status)
if (status < 0) &
call print_message(loc, "Could not store seeds!")
deallocate(seeds, stat=status)
if (status /= 0) &
call print_message(loc, "Could not deallocate space for seeds!")
else
call print_message(loc, "Could not allocate space for seeds!")
end if
end if
call h5gclose_f(grp_id, status)
if (status < 0) &
call print_message(loc, "Could not close group 'random'!")
else
call print_message(loc, "Could not create group 'random'!")
end if
end if
!-------------------------------------------------------------------------------
!
end subroutine store_attributes_h5
!
!===============================================================================
!
! subroutine RESTORE_METABLOCKS_H5:
! --------------------------------
!
! Subroutine restores meta blocks and their fields and dependencies from
! the 'metablocks' group of HDF5 restart snapshot.
!
! Arguments:
!
! loc_id - the location in which store the datablocks;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine restore_metablocks_h5(loc_id, status)
use blocks , only : block_meta, list_meta
use blocks , only : ns => nsides, nc => nchildren
use blocks , only : get_last_id, get_mblocks
use blocks , only : metablock_set_id, metablock_set_process
use blocks , only : metablock_set_refinement
use blocks , only : metablock_set_configuration
use blocks , only : metablock_set_level, metablock_set_position
use blocks , only : metablock_set_coordinates, metablock_set_bounds
use blocks , only : metablock_set_leaf
use helpers, only : print_message
implicit none
integer(hid_t), intent(in) :: loc_id
integer , intent(out) :: status
type(block_meta), pointer :: pmeta
integer(hid_t) :: grp_id
integer :: nm, l, n, p, i, j
#if NDIMS == 3
integer :: k
#endif /* NDIMS == 3 */
integer(hsize_t), dimension(5) :: dims
integer(kind=4), dimension(:,:) , allocatable :: fields
integer(kind=4), dimension(:,:) , allocatable :: children
#if NDIMS == 2
integer(kind=4), dimension(:,:,:,:) , allocatable :: edges
integer(kind=4), dimension(:,:,:) , allocatable :: corners
#endif /* NDIMS == 2 */
#if NDIMS == 3
integer(kind=4), dimension(:,:,:,:,:), allocatable :: faces
integer(kind=4), dimension(:,:,:,:,:), allocatable :: edges
integer(kind=4), dimension(:,:,:,:) , allocatable :: corners
#endif /* NDIMS == 3 */
real(kind=8) , dimension(:,:,:) , allocatable :: bounds
character(len=*), parameter :: loc = 'IO::restore_metablocks_h5()'
!-------------------------------------------------------------------------------
!
call h5gopen_f(loc_id, 'metablocks', grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not open group 'metablocks'!")
return
end if
nm = get_mblocks()
if (nm > 0) then
allocate(fields(16,nm), children(nc,nm), bounds(3,2,nm), &
#if NDIMS == 3
faces(NDIMS,ns,ns,ns,nm), &
edges(NDIMS,ns,ns,ns,nm), corners(ns,ns,ns,nm), &
#else /* NDIMS == 3 */
edges(NDIMS,ns,ns,nm), corners(ns,ns,nm), &
#endif /* NDIMS == 3 */
stat = status)
if (status == 0) then
l = rank(fields)
dims(1:l) = shape(fields)
call read_dataset_h5(grp_id, 'fields', &
H5T_NATIVE_INTEGER, dims(1:l), fields, status)
l = rank(children)
dims(1:l) = shape(children)
call read_dataset_h5(grp_id, 'children', &
H5T_NATIVE_INTEGER, dims(1:l), children, status)
#if NDIMS == 3
l = rank(faces)
dims(1:l) = shape(faces)
call read_dataset_h5(grp_id, 'faces', &
H5T_NATIVE_INTEGER, dims(1:l), faces, status)
#endif /* NDIMS == 3 */
l = rank(edges)
dims(1:l) = shape(edges)
call read_dataset_h5(grp_id, 'edges', &
H5T_NATIVE_INTEGER, dims(1:l), edges, status)
l = rank(corners)
dims(1:l) = shape(corners)
call read_dataset_h5(grp_id, 'corners', &
H5T_NATIVE_INTEGER, dims(1:l), corners, status)
l = rank(bounds)
dims(1:l) = shape(bounds)
call read_dataset_h5(grp_id, 'bounds', &
H5T_NATIVE_DOUBLE, dims(1:l), bounds, status)
l = 0
pmeta => list_meta
do while(associated(pmeta))
l = l + 1
block_array(fields(1,l))%ptr => pmeta
call metablock_set_id(pmeta, fields(1,l))
call metablock_set_process(pmeta, fields(2,l))
call metablock_set_level(pmeta, fields(3,l))
call metablock_set_configuration(pmeta, fields(4,l))
call metablock_set_refinement(pmeta, fields(5,l))
call metablock_set_position(pmeta, fields(6:8,l))
call metablock_set_coordinates(pmeta, fields(9:11,l))
call metablock_set_bounds(pmeta, bounds(1,1,l), bounds(1,2,l), &
bounds(2,1,l), bounds(2,2,l), &
bounds(3,1,l), bounds(3,2,l))
if (fields(12,l) == 1) call metablock_set_leaf(pmeta)
pmeta => pmeta%next
end do
l = 0
pmeta => list_meta
do while(associated(pmeta))
l = l + 1
if (fields(14,l) > 0) pmeta%parent => block_array(fields(14,l))%ptr
do p = 1, nc
if (children(p,l) > 0) &
pmeta%child(p)%ptr => block_array(children(p,l))%ptr
end do
#if NDIMS == 2
do j = 1, ns
do i = 1, ns
do n = 1, NDIMS
if (edges(n,i,j,l) > 0) &
pmeta%edges(i,j,n)%ptr => block_array(edges(n,i,j,l))%ptr
end do
if (corners(i,j,l) > 0) &
pmeta%corners(i,j)%ptr => block_array(corners(i,j,l))%ptr
end do
end do
#endif /* NDIMS == 2 */
#if NDIMS == 3
do k = 1, ns
do j = 1, ns
do i = 1, ns
do n = 1, NDIMS
if (faces(n,i,j,k,l) > 0) &
pmeta%faces(i,j,k,n)%ptr => &
block_array(faces(n,i,j,k,l))%ptr
if (edges(n,i,j,k,l) > 0) &
pmeta%edges(i,j,k,n)%ptr => &
block_array(edges(n,i,j,k,l))%ptr
end do ! NDIMS
if (corners(i,j,k,l) > 0) &
pmeta%corners(i,j,k)%ptr => &
block_array(corners(i,j,k,l))%ptr
end do
end do
end do
#endif /* NDIMS == 3 */
pmeta => pmeta%next
end do
#if NDIMS == 3
deallocate(fields, children, bounds, faces, &
edges, corners, stat=status)
#else /* NDIMS == 3 */
deallocate(fields, children, bounds, edges, corners, stat=status)
#endif /* NDIMS == 3 */
if (status /= 0) &
call print_message(loc, "Could not deallocate space of metablocks!")
else
call print_message(loc, "Could not allocate space for metablocks!")
end if
end if
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'metablocks'!")
!-------------------------------------------------------------------------------
!
end subroutine restore_metablocks_h5
!
!===============================================================================
!
! subroutine STORE_METABLOCKS_H5:
! ------------------------------
!
! Subroutine stores all meta blocks' data in the group 'metablocks'.
!
! Arguments:
!
! loc_id - the location in which store the datablocks;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine store_metablocks_h5(loc_id, status)
use blocks , only : block_meta, list_meta, get_last_id
use blocks , only : ns => nsides, nc => nchildren
use blocks , only : get_last_id, get_mblocks
use helpers, only : print_message
implicit none
integer(hid_t), intent(in) :: loc_id
integer , intent(out) :: status
type(block_meta), pointer :: pmeta
integer(hid_t) :: grp_id
integer :: nm, l, n, p, i, j
#if NDIMS == 3
integer :: k
#endif /* NDIMS == 3 */
integer(hsize_t), dimension(5) :: dims
integer(kind=4), dimension(:,:) , allocatable :: fields
integer(kind=4), dimension(:,:) , allocatable :: children
#if NDIMS == 2
integer(kind=4), dimension(:,:,:,:) , allocatable :: edges
integer(kind=4), dimension(:,:,:) , allocatable :: corners
#endif /* NDIMS == 2 */
#if NDIMS == 3
integer(kind=4), dimension(:,:,:,:,:), allocatable :: faces
integer(kind=4), dimension(:,:,:,:,:), allocatable :: edges
integer(kind=4), dimension(:,:,:,:) , allocatable :: corners
#endif /* NDIMS == 3 */
real(kind=8) , dimension(:,:,:) , allocatable :: bounds
character(len=*), parameter :: loc = 'IO::store_metablocks_h5()'
!-------------------------------------------------------------------------------
!
call h5gcreate_f(loc_id, 'metablocks', grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not create group 'metablocks'!")
return
end if
nm = get_mblocks()
if (nm > 0) then
allocate(fields(16,nm), children(nc,nm), bounds(3,2,nm), &
#if NDIMS == 3
faces(NDIMS,ns,ns,ns,nm), &
edges(NDIMS,ns,ns,ns,nm), corners(nm,ns,ns,ns), &
#else /* NDIMS == 3 */
edges(NDIMS,ns,ns,nm), corners(ns,ns,nm), &
#endif /* NDIMS == 3 */
stat = status)
! block_array(get_last_id()), stat = status)
if (status == 0) then
fields = -1
children = -1
#if NDIMS == 3
faces = -1
#endif /* NDIMS == 3 */
edges = -1
corners = -1
bounds = 0.0d+00
l = 0
pmeta => list_meta
do while(associated(pmeta))
l = l + 1
fields( 1,l) = pmeta%id
fields( 2,l) = pmeta%process
fields( 3,l) = pmeta%level
fields( 4,l) = pmeta%conf
fields( 5,l) = pmeta%refine
fields( 6,l) = pmeta%pos(1)
fields( 7,l) = pmeta%pos(2)
#if NDIMS == 3
fields( 8,l) = pmeta%pos(3)
#endif /* NDIMS == 3 */
fields( 9,l) = pmeta%coords(1)
fields(10,l) = pmeta%coords(2)
#if NDIMS == 3
fields(11,l) = pmeta%coords(3)
#endif /* NDIMS == 3 */
if (pmeta%leaf) fields(12,l) = 1
if (associated(pmeta%data) ) fields(13,l) = 1
if (associated(pmeta%parent)) fields(14,l) = pmeta%parent%id
do p = 1, nc
if (associated(pmeta%child(p)%ptr)) &
children(p,l) = pmeta%child(p)%ptr%id
end do
#if NDIMS == 2
do j = 1, ns
do i = 1, ns
do n = 1, NDIMS
if (associated(pmeta%edges(i,j,n)%ptr)) &
edges(n,i,j,l) = pmeta%edges(i,j,n)%ptr%id
end do
if (associated(pmeta%corners(i,j)%ptr)) &
corners(i,j,l) = pmeta%corners(i,j)%ptr%id
end do
end do
#endif /* NDIMS == 2 */
#if NDIMS == 3
do k = 1, ns
do j = 1, ns
do i = 1, ns
do n = 1, NDIMS
if (associated(pmeta%faces(i,j,k,n)%ptr)) &
faces(n,i,j,k,l) = pmeta%faces(i,j,k,n)%ptr%id
if (associated(pmeta%edges(i,j,k,n)%ptr)) &
edges(n,i,j,k,l) = pmeta%edges(i,j,k,n)%ptr%id
end do
if (associated(pmeta%corners(i,j,k)%ptr)) &
corners(i,j,k,l) = pmeta%corners(i,j,k)%ptr%id
end do
end do
end do
#endif /* NDIMS == 3 */
bounds(1,1,l) = pmeta%xmin
bounds(1,2,l) = pmeta%xmax
bounds(2,1,l) = pmeta%ymin
bounds(2,2,l) = pmeta%ymax
#if NDIMS == 3
bounds(3,1,l) = pmeta%zmin
bounds(3,2,l) = pmeta%zmax
#endif /* NDIMS == 3 */
pmeta => pmeta%next
end do
l = rank(fields)
dims(1:l) = shape(fields)
call store_dataset_h5(grp_id, 'fields', H5T_NATIVE_INTEGER, &
dims(1:l), fields, .false., status)
l = rank(children)
dims(1:l) = shape(children)
call store_dataset_h5(grp_id, 'children', H5T_NATIVE_INTEGER, &
dims(1:l), children, .false., status)
#if NDIMS == 3
l = rank(faces)
dims(1:l) = shape(faces)
call store_dataset_h5(grp_id, 'faces', H5T_NATIVE_INTEGER, &
dims(1:l), faces, .false., status)
#endif /* NDIMS == 3 */
l = rank(edges)
dims(1:l) = shape(edges)
call store_dataset_h5(grp_id, 'edges', H5T_NATIVE_INTEGER, &
dims(1:l), edges, .false., status)
l = rank(corners)
dims(1:l) = shape(corners)
call store_dataset_h5(grp_id, 'corners', H5T_NATIVE_INTEGER, &
dims(1:l), corners, .false., status)
l = rank(bounds)
dims(1:l) = shape(bounds)
call store_dataset_h5(grp_id, 'bounds', H5T_NATIVE_DOUBLE, &
dims(1:l), bounds, .false., status)
#if NDIMS == 3
deallocate(fields, children, bounds, faces, &
edges, corners, stat=status)
#else /* NDIMS == 3 */
deallocate(fields, children, bounds, edges, corners, stat=status)
#endif /* NDIMS == 3 */
if (status /= 0) &
call print_message(loc, "Could not deallocate space of metablocks!")
else
call print_message(loc, "Could not allocate space for metablocks!")
end if
end if
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'metablocks'!")
!-------------------------------------------------------------------------------
!
end subroutine store_metablocks_h5
!
!===============================================================================
!
! subroutine RESTORE_DATABLOCKS_H5:
! --------------------------------
!
! Subroutine reads all data blocks stored in the group 'datablocks' of
! the provided handler to the HDF5 restart file.
!
! Arguments:
!
! loc_id - the location in which store the datablocks;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine restore_datablocks_h5(loc_id, status)
use blocks , only : block_meta, block_data
use blocks , only : append_datablock, link_blocks, nregs
use coordinates, only : bcells, nghosts
use helpers , only : print_message
implicit none
integer(hid_t), intent(in) :: loc_id
integer , intent(out) :: status
type(block_data), pointer :: pdata
integer(hid_t) :: grp_id, blk_id
character(len=64) :: blk_name
integer(kind=4) :: dblocks, l, id, nr, nv, nm, ng, nl, nu
integer(hsize_t), dimension(5) :: dims = 1
real(kind=8), dimension(:,:,:,:,:), allocatable :: array
character(len=*), parameter :: loc = 'IO::restore_datablocks_h5()'
!-------------------------------------------------------------------------------
!
call h5gopen_f(loc_id, 'attributes', grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not open group 'attributes'!")
return
end if
call restore_attribute_h5(grp_id, 'dblocks', &
H5T_NATIVE_INTEGER, 1, dblocks, status)
call restore_attribute_h5(grp_id, 'nregisters', &
H5T_NATIVE_INTEGER, 1, nr, status)
call restore_attribute_h5(grp_id, 'nvars', &
H5T_NATIVE_INTEGER, 1, nv, status)
call restore_attribute_h5(grp_id, 'bcells', &
H5T_NATIVE_INTEGER, 1, nm, status)
call restore_attribute_h5(grp_id, 'nghosts', &
H5T_NATIVE_INTEGER, 1, ng, status)
call h5gclose_f(grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not close group 'attributes'!")
return
end if
if (dblocks == 0) return
call h5gopen_f(loc_id, 'datablocks', grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not open group 'datablocks'!")
return
end if
#if NDIMS == 3
allocate(array(nv,nm,nm,nm,nr), stat=status)
#else /* NDIMS == 3 */
allocate(array(nv,nm,nm, 1,nr), stat=status)
#endif /* NDIMS == 3 */
if (status == 0) then
dims = shape(array)
nr = min(nr, nregs)
if (ng >= nghosts) then
nl = 1 + (ng - nghosts)
nu = nm - (ng - nghosts)
else
nl = 1 + (nghosts - ng)
nu = bcells - (nghosts - ng)
end if
do l = 1, dblocks
write(blk_name, "('datablock_', i0)") l
call append_datablock(pdata, status)
if (status /= 0) then
call print_message(loc, "Could not append new datablock!")
go to 1000
end if
call h5gopen_f(grp_id, blk_name, blk_id, status)
if (status == 0) then
call restore_attribute_h5(blk_id, 'meta', &
H5T_NATIVE_INTEGER, 1, id, status)
call link_blocks(block_array(id)%ptr, pdata)
call read_dataset_h5(blk_id, 'primitive_variables', &
H5T_NATIVE_DOUBLE, dims(1:4), array(:,:,:,:,1), status)
if (ng >= nghosts) then
#if NDIMS == 3
pdata%q(:,:,:,:) = array(:,nl:nu,nl:nu,nl:nu,1)
#else /* NDIMS == 3 */
pdata%q(:,:,:,:) = array(:,nl:nu,nl:nu, : ,1)
#endif /* NDIMS == 3 */
else
#if NDIMS == 3
pdata%q(:,nl:nu,nl:nu,nl:nu) = array(:,:,:,:,1)
#else /* NDIMS == 3 */
pdata%q(:,nl:nu,nl:nu, : ) = array(:,:,:,:,1)
#endif /* NDIMS == 3 */
end if
call read_dataset_h5(blk_id, 'conservative_variables', &
H5T_NATIVE_DOUBLE, dims(1:5), array(:,:,:,:,:), status)
if (ng >= nghosts) then
#if NDIMS == 3
pdata%uu(:,:,:,:,1:nr) = array(:,nl:nu,nl:nu,nl:nu,1:nr)
#else /* NDIMS == 3 */
pdata%uu(:,:,:,:,1:nr) = array(:,nl:nu,nl:nu, : ,1:nr)
#endif /* NDIMS == 3 */
else
#if NDIMS == 3
pdata%uu(:,nl:nu,nl:nu,nl:nu,1:nr) = array(:,:,:,:,1:nr)
#else /* NDIMS == 3 */
pdata%uu(:,nl:nu,nl:nu, : ,1:nr) = array(:,:,:,:,1:nr)
#endif /* NDIMS == 3 */
end if
call h5gclose_f(blk_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not close group '" // trim(blk_name) // "'!")
else
call print_message(loc, &
"Could not open group '" // trim(blk_name) // "'!")
end if
end do
deallocate(array, stat=status)
if (status /= 0) &
call print_message(loc, &
"Could not deallocate memory for the temporary arrays!")
else
call print_message(loc, &
"Could not allocate memory for the temporary arrays!")
end if
1000 continue
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'datablocks'!")
!-------------------------------------------------------------------------------
!
end subroutine restore_datablocks_h5
!
!===============================================================================
!
! subroutine STORE_DATABLOCKS_H5:
! ------------------------------
!
! Subroutine stores all data blocks in the group 'datablocks'.
!
! Arguments:
!
! loc_id - the location in which store the datablocks;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine store_datablocks_h5(loc_id, status)
use blocks , only : block_meta, block_data, list_data, get_dblocks
use helpers, only : print_message
implicit none
integer(hid_t), intent(in) :: loc_id
integer , intent(out) :: status
type(block_data), pointer :: pdata
character(len=64) :: blk_name
integer(hid_t) :: grp_id, blk_id
integer(kind=4) :: l
integer(hsize_t), dimension(4) :: pdims = 1
integer(hsize_t), dimension(5) :: cdims = 1
character(len=*), parameter :: loc = 'IO::store_datablocks_h5()'
!-------------------------------------------------------------------------------
!
status = 0
call h5gcreate_f(loc_id, 'datablocks', grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not create group 'datablocks'!")
end if
if (get_dblocks() > 0) then
l = 0
pdata => list_data
do while(associated(pdata))
l = l + 1
write(blk_name, "('datablock_', i0)") l
call h5gcreate_f(grp_id, blk_name, blk_id, status)
if (status == 0) then
call store_attribute_h5(blk_id, 'meta', &
H5T_NATIVE_INTEGER, 1, pdata%meta%id, status)
pdims = shape(pdata%q)
cdims = shape(pdata%uu)
call store_dataset_h5(blk_id, 'primitive_variables', &
H5T_NATIVE_DOUBLE, pdims, pdata%q, .false., status)
if (status /= 0) &
call print_message(loc, &
"Could not store the primitive variables in " // &
trim(blk_name) // "!")
call store_dataset_h5(blk_id, 'conservative_variables', &
H5T_NATIVE_DOUBLE, cdims, pdata%uu, .false., status)
if (status /= 0) &
call print_message(loc, &
"Could not store the conservative variables in " // &
trim(blk_name) // "!")
call h5gclose_f(blk_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not close group for " // trim(blk_name) // "!")
else
call print_message(loc, &
"Could not create group for " // trim(blk_name) // "!")
end if
pdata => pdata%next
end do
end if
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'datablocks'!")
!-------------------------------------------------------------------------------
!
end subroutine store_datablocks_h5
!
!===============================================================================
!
! subroutine STORE_COORDINATES_H5:
! -------------------------------
!
! Subroutine stores blocks' data such as their IDs, levels, coordinates, etc.
! in a specific location.
!
! Arguments:
!
! loc_id - the location in which store the coordinates;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine store_coordinates_h5(loc_id, status)
use blocks , only : block_meta, block_data, list_data
use blocks , only : get_dblocks
use coordinates, only : toplev
use coordinates, only : adx, ady
#if NDIMS == 3
use coordinates, only : adz
#endif /* NDIMS == 3 */
use helpers , only : print_message
implicit none
integer(hid_t), intent(in) :: loc_id
integer , intent(out) :: status
integer(hid_t) :: grp_id
integer :: n
type(block_meta), pointer :: pmeta
type(block_data), pointer :: pdata
integer(hsize_t), dimension(1) :: am = 1, im = 1
integer(hsize_t), dimension(2) :: cm = 1
integer(hsize_t), dimension(3) :: bm = 1
integer(kind=4), dimension(:) , allocatable :: ids, levels
integer(kind=4), dimension(:,:) , allocatable :: coords
real (kind=8), dimension(:,:,:), allocatable :: bounds
character(len=*), parameter :: loc = 'IO::store_coordinates_h5()'
!-------------------------------------------------------------------------------
!
status = 0
call h5gcreate_f(loc_id, 'coordinates', grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not create group 'coordinates'!")
return
end if
am(1) = toplev
call store_dataset_h5(grp_id, 'dx', H5T_NATIVE_DOUBLE, &
am, adx, .false., status)
call store_dataset_h5(grp_id, 'dy', H5T_NATIVE_DOUBLE, &
am, ady, .false., status)
#if NDIMS == 3
call store_dataset_h5(grp_id, 'dz', H5T_NATIVE_DOUBLE, &
am, adz, .false., status)
#endif /* NDIMS == 3 */
if (get_dblocks() > 0) then
n = get_dblocks()
im(1) = n
cm(1) = NDIMS
cm(2) = n
bm(1) = NDIMS
bm(2) = 2
bm(3) = n
allocate(ids(n), levels(n), coords(NDIMS,n), &
bounds(NDIMS,2,n), stat=status)
if (status /= 0) then
call print_message(loc, "Could not allocate space for coordinates!")
else
n = 0
pdata => list_data
do while(associated(pdata))
pmeta => pdata%meta
n = n + 1
ids(n) = pmeta%id
levels(n) = pmeta%level
coords(:,n) = pmeta%coords(:)
bounds(1,:,n) = [ pmeta%xmin, pmeta%xmax ]
bounds(2,:,n) = [ pmeta%ymin, pmeta%ymax ]
#if NDIMS == 3
bounds(3,:,n) = [ pmeta%zmin, pmeta%zmax ]
#endif /* NDIMS == 3 */
pdata => pdata%next
end do
call store_dataset_h5(grp_id, 'ids', H5T_NATIVE_INTEGER, &
im, ids, .false., status)
call store_dataset_h5(grp_id, 'levels', H5T_NATIVE_INTEGER, &
im, levels, .false., status)
call store_dataset_h5(grp_id, 'coords', H5T_NATIVE_INTEGER, &
cm, coords, .false., status)
call store_dataset_h5(grp_id, 'bounds', H5T_NATIVE_DOUBLE, &
bm, bounds, .false., status)
deallocate(ids, levels, coords, bounds, stat=status)
if (status > 0) &
call print_message(loc, "Could not deallocate the coordinate space!")
end if
end if
call h5gclose_f(grp_id, status)
if (status < 0) &
call print_message(loc, "Could not close group 'coordinates'!")
!-------------------------------------------------------------------------------
!
end subroutine store_coordinates_h5
!
!===============================================================================
!
! subroutine STORE_VARIABLES_H5:
! -----------------------------
!
! Subroutine stores primitive variables in a specific location.
!
! Arguments:
!
! loc_id - the location in which store the variables;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine store_variables_h5(loc_id, status)
use blocks , only : block_data, list_data
use blocks , only : get_dblocks
use coordinates , only : bcells
use equations , only : nv, pvars
use helpers , only : print_message
use iso_c_binding, only : c_loc
implicit none
integer(hid_t), intent(in) :: loc_id
integer , intent(out) :: status
integer(hid_t) :: grp_id
integer :: n, p
integer(hsize_t), dimension(4) :: dims = 1
type(block_data), pointer :: pdata
real(kind=8), dimension(:,:,:,:), allocatable, target :: array
character(len=*), parameter :: loc = 'IO::store_variables_h5()'
!-------------------------------------------------------------------------------
!
status = 0
call h5gcreate_f(loc_id, 'variables', grp_id, status)
if (status /= 0) then
call print_message(loc, "Could not create group 'variables'!")
return
end if
if (get_dblocks() > 0) then
dims(1:NDIMS) = bcells
dims(4) = get_dblocks()
allocate(array(dims(1),dims(2),dims(3),dims(4)), stat=status)
if (status /= 0) then
call print_message(loc, "Could not allocate space for variables!")
else
do p = 1, nv
n = 0
pdata => list_data
do while(associated(pdata))
n = n + 1
array(:,:,:,n) = pdata%q(p,:,:,:)
pdata => pdata%next
end do
call store_dataset_h5(grp_id, trim(pvars(p)), &
H5T_NATIVE_DOUBLE, dims, array, .true., status)
end do
deallocate(array, stat=status)
if (status /= 0) &
call print_message(loc, "Could not deallocate the variable space!")
end if
end if
call h5gclose_f(grp_id, status)
if (status /= 0) &
call print_message(loc, "Could not close group 'variables'!")
!-------------------------------------------------------------------------------
!
end subroutine store_variables_h5
!
!===============================================================================
!
! subroutine RESTORE_ATTRIBUTE_STRING_H5:
! --------------------------------------
!
! Subroutine restores a string attribute from a given location.
!
! Arguments:
!
! loc_id - the location in which the dataset is stored;
! name - the attribute's name;
! string - the attribute's buffer;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine restore_attribute_string_h5(loc_id, name, string, status)
use helpers , only : print_message
use iso_c_binding, only : c_loc
implicit none
integer(hid_t) , intent(in) :: loc_id
character(len=*) , intent(in) :: name
character(len=*), target, intent(inout) :: string
integer , intent(out) :: status
integer(hid_t) :: attr_id, type_id, mem_id
integer(hsize_t) :: length, attr_size
logical :: flag
type(c_ptr) :: str_ptr
character(len=*), parameter :: loc = 'IO::restore_attribute_string_h5'
!-------------------------------------------------------------------------------
!
call h5aexists_by_name_f(loc_id, '.', trim(name), flag, status)
if (status /= 0) then
call print_message(loc, &
"Could not check if attribute '" // trim(name) // "' exists!")
return
end if
if (flag) then
call h5aopen_by_name_f(loc_id, '.', trim(name), attr_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not open attribute '" // trim(name) // "'!")
return
end if
call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not copy the datatype for attribute '" // trim(name) // "'!")
go to 1000
end if
call h5aget_storage_size_f(attr_id, attr_size, status)
if (status /= 0) then
call print_message(loc, &
"Could not get the datatype size of attribute '" // &
trim(name) // "'!")
go to 1000
end if
call h5tset_size_f(type_id, attr_size, status)
if (status /= 0) then
call print_message(loc, &
"Could not set the datatype size for attribute '" // &
trim(name) // "'!")
go to 1000
end if
call h5aget_type_f(attr_id, mem_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not get the datatype of attribute '" // trim(name) // "'!")
go to 1000
end if
call h5tequal_f(type_id, mem_id, flag, status)
if (status /= 0) then
call print_message(loc, &
"The datatypes of the input string and attribute '" // &
trim(name) // "' do not match!")
go to 1000
end if
length = len(string)
if (length < attr_size) then
call print_message(loc, &
"The string is too small for storing attribute '" // &
trim(name) // "'!")
go to 1000
end if
if (flag) then
string = ""
str_ptr = c_loc(string)
call h5aread_f(attr_id, type_id, str_ptr, status)
if (status /= 0) then
call print_message(loc, &
"Could not read attribute '" // trim(name) // "'!")
end if
end if
1000 continue
call h5aclose_f(attr_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not close attribute '" // trim(name) // "'!")
else
call print_message(loc, "Attribute '" // trim(name) // "' not found!")
end if
!-------------------------------------------------------------------------------
!
end subroutine restore_attribute_string_h5
!
!===============================================================================
!
! subroutine RESTORE_ATTRIBUTE_NUMBER_H5:
! --------------------------------------
!
! Subroutine restores a number (integer or real) attribute from a given
! location. Both scalar and vectors are supported.
!
! Arguments:
!
! loc_id - the location in which the dataset is stored;
! name - the attribute's name;
! type_id - the HDF5 type of attribute;
! length - the number of attribute's elements;
! buffer - the attribute's data;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine restore_attribute_number_h5(loc_id, name, type_id, &
length, buffer, status)
use helpers , only : print_message
use iso_c_binding, only : c_loc
implicit none
integer(hid_t) , intent(in) :: loc_id, type_id
character(len=*) , intent(in) :: name
integer , intent(in) :: length
type(*), target , dimension(..), intent(inout) :: buffer
integer , intent(out) :: status
integer(hid_t) :: attr_id, spc_id, mem_id
integer(hsize_t), dimension(1) :: dims, mdims
logical :: flag
integer :: rank, cls_type
type(c_ptr) :: buffer_ptr
character(len=*), parameter :: loc = 'IO::restore_attribute_h5'
!-------------------------------------------------------------------------------
!
call h5aexists_by_name_f(loc_id, '.', trim(name), flag, status)
if (status /= 0) then
call print_message(loc, &
"Could not check if attribute '" // trim(name) // "' exists!")
return
end if
if (flag) then
call h5aopen_by_name_f(loc_id, '.', trim(name), attr_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not open attribute '" // trim(name) // "'!")
return
end if
call h5aget_type_f(attr_id, mem_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not get the datatype of attribute '" // trim(name) // "'!")
go to 1000
end if
call h5tequal_f(type_id, mem_id, flag, status)
if (status /= 0) then
call print_message(loc, &
"The datatypes of the input buffer and attribute '" // &
trim(name) // "' do not match!")
go to 1000
end if
if (flag) then
call h5aget_space_f(attr_id, spc_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not get the dataspace of attribute '" // trim(name) // "'!")
go to 1000
end if
call h5sget_simple_extent_type_f(spc_id, cls_type, status)
if (status /= 0) then
call print_message(loc, &
"Could not get the dataspace type for attribute '" // &
trim(name) // "'!")
go to 900
end if
if (cls_type == H5S_SCALAR_F) then
buffer_ptr = c_loc(buffer)
call h5aread_f(attr_id, type_id, buffer_ptr, status)
if (status /= 0) then
call print_message(loc, &
"Could not read attribute '" // trim(name) // "'!")
end if
else if (cls_type == H5S_SIMPLE_F) then
call h5sget_simple_extent_dims_f(spc_id, dims, mdims, rank)
if (rank /= 1) then
call print_message(loc, "Only rank equal 1 is supported!")
go to 800
end if
mdims(1) = length
if (dims(1) /= mdims(1)) then
call print_message(loc, &
"The dataspace dimensions the input buffer and attribute '" // &
trim(name) // "' do not match!")
go to 800
end if
buffer_ptr = c_loc(buffer)
call h5aread_f(attr_id, type_id, buffer_ptr, status)
if (status /= 0) then
call print_message(loc, &
"Could not read attribute '" // trim(name) // "'!")
end if
800 continue
else
call print_message(loc, &
"The dataspace type of attribute '" // trim(name) // &
"' is not supported!")
end if
900 continue
call h5sclose_f(spc_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not close the dataspace of attribute '" // trim(name) // "'!")
end if
1000 continue
call h5aclose_f(attr_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not close attribute '" // trim(name) // "'!")
else
call print_message(loc, "Attribute '" // trim(name) // "' not found!")
end if
!-------------------------------------------------------------------------------
!
end subroutine restore_attribute_number_h5
!
!===============================================================================
!
! subroutine STORE_ATTRIBUTE_STRING_H5:
! ------------------------------------
!
! Subroutine stores a string attribute in a given location.
!
! Arguments:
!
! loc_id - the location in which the dataset is stored;
! name - the attribute's name;
! string - the attribute's text;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine store_attribute_string_h5(loc_id, name, string, status)
use helpers , only : print_message
use iso_c_binding, only : c_loc
implicit none
integer(hid_t) , intent(in) :: loc_id
character(len=*) , intent(in) :: name
character(len=*), target, intent(in) :: string
integer , intent(out) :: status
integer(hid_t) :: mem_id, spc_id, attr_id
integer(hsize_t) :: length
character(len=*), parameter :: loc = 'IO::store_attribute_string_h5()'
!-------------------------------------------------------------------------------
!
call h5tcopy_f(H5T_NATIVE_CHARACTER, mem_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not copy the datatype for attribute '" // trim(name) // "'!")
return
end if
length = len(trim(string))
call h5tset_size_f(mem_id, length, status)
if (status /= 0) then
call print_message(loc, &
"Could not set the datatype size for attribute '" // trim(name) // "'!")
return
end if
call h5screate_f(H5S_SCALAR_F, spc_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not create the dataspace for attribute '" // trim(name) // "'!")
return
end if
call h5acreate_f(loc_id, trim(name), mem_id, spc_id, attr_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not create attribute '" // trim(name) // "'!")
go to 1000
end if
call h5awrite_f(attr_id, mem_id, c_loc(string), status)
if (status /= 0) &
call print_message(loc, &
"Could not write attribute " // trim(name) // "'!")
call h5aclose_f(attr_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not close attribute '" // trim(name) // "'!")
1000 continue
call h5sclose_f(spc_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not close the dataspace for attribute '" // trim(name) // "'!")
!-------------------------------------------------------------------------------
!
end subroutine store_attribute_string_h5
!
!===============================================================================
!
! subroutine STORE_ATTRIBUTE_NUMBER_H5:
! ------------------------------------
!
! Subroutine stores a number (integer or real) attribute in a given location.
! Both scalar and vectors are supported.
!
! Arguments:
!
! loc_id - the location in which the dataset is stored;
! name - the attribute's name;
! type_id - the HDF5 type of attribute;
! length - the number of attribute elements
! buffer - the attribute's data;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine store_attribute_number_h5(loc_id, name, type_id, &
length, buffer, status)
use helpers , only : print_message
use iso_c_binding, only : c_loc
implicit none
integer(hid_t) , intent(in) :: loc_id, type_id
character(len=*) , intent(in) :: name
integer , intent(in) :: length
type(*), target , dimension(..), intent(in) :: buffer
integer , intent(out) :: status
integer(hid_t) :: spc_id, attr_id
integer(hsize_t), dimension(1) :: dims = 1
character(len=*), parameter :: loc = 'IO::store_attribute_number_h5()'
!-------------------------------------------------------------------------------
!
dims(1) = length
if (length > 1) then
call h5screate_simple_f(1, dims, spc_id, status)
else
call h5screate_f(H5S_SCALAR_F, spc_id, status)
end if
if (status /= 0) then
call print_message(loc, &
"Could not create the dataspace for attribute '" // trim(name) // "'!")
return
end if
call h5acreate_f(loc_id, trim(name), type_id, spc_id, attr_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not create attribute '" // trim(name) // "'!")
go to 1000
end if
call h5awrite_f(attr_id, type_id, c_loc(buffer), status)
if (status /= 0) &
call print_message(loc, &
"Could not write attribute " // trim(name) // "'!")
call h5aclose_f(attr_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not close attribute '" // trim(name) // "'!")
1000 continue
call h5sclose_f(spc_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not close the dataspace for attribute '" // trim(name) // "'!")
!-------------------------------------------------------------------------------
!
end subroutine store_attribute_number_h5
!
!===============================================================================
!
! subroutine READ_DATASET_H5:
! ---------------------------
!
! Subroutine reads a generic dataset.
!
! Arguments:
!
! loc_id - the location in which the dataset is stored;
! name - the dataset name;
! type_id - the dataset type;
! dims - the dataset dimensions;
! buffer - the dataset buffer;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine read_dataset_h5(loc_id, name, type_id, dims, buffer, status)
use helpers , only : print_message
use iso_c_binding, only : c_loc
implicit none
integer(hid_t) , intent(in) :: loc_id, type_id
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(:), intent(in) :: dims
type(*), target, dimension(..), intent(inout) :: buffer
integer , intent(out) :: status
type(c_ptr) :: buffer_ptr
logical :: flag
integer :: rank
integer(hid_t) :: space_id, dset_id, mem_id
integer(hsize_t), dimension(size(dims)) :: ddims, mdims
character(len=*), parameter :: loc = 'IO::read_dataset_h5()'
!-------------------------------------------------------------------------------
!
status = 0
call h5dopen_f(loc_id, trim(name), dset_id, status)
if (status /= 0) then
call print_message(loc, "Could not open dataset '" // trim(name) // "'!")
status = 1
return
end if
call h5dget_type_f(dset_id, mem_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not get the datatype for dataset '" // trim(name) // "'!")
go to 1000
end if
call h5tequal_f(type_id, mem_id, flag, status)
if (status < 0) then
call print_message(loc, &
"Could not compare the buffer and dataset '" // trim(name) // &
"' types!")
go to 1000
end if
if (.not. flag) then
call print_message(loc, &
"Datatypes of the buffer and dataset '" // trim(name) // &
"' do not match!")
go to 1000
end if
call h5dget_space_f(dset_id, space_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not get the dataspace for dataset '" // trim(name) // "'!")
go to 1000
end if
call h5sget_simple_extent_dims_f(space_id, ddims, mdims, rank)
if (rank /= size(dims)) then
call print_message(loc, "Wrong rank of dataset '" // trim(name) // "'!")
status = 1
go to 900
end if
if (any(ddims /= dims)) then
call print_message(loc, &
"Wrong dimensions of dataset '" // trim(name) // "'!")
status = 1
go to 900
end if
buffer_ptr = c_loc(buffer)
call h5dread_f(dset_id, type_id, buffer_ptr, status)
if (status /= 0) &
call print_message(loc, "Could not read dataset '" // trim(name) // "'!")
900 continue
call h5sclose_f(space_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not close the dataspace for dataset '" // trim(name) // "'!")
1000 continue
call h5dclose_f(dset_id, status)
if (status /= 0) &
call print_message(loc, "Could not close dataset '" // trim(name) // "'!")
!-------------------------------------------------------------------------------
!
end subroutine read_dataset_h5
!
!===============================================================================
!
! subroutine STORE_DATASET_H5:
! ---------------------------
!
! Subroutine stores a generic dataset.
!
! Arguments:
!
! loc_id - the location in which the dataset is stored;
! name - the dataset name;
! type_id - the dataset type;
! dims - the dataset dimensions;
! buffer - the dataset buffer to store;
! compress - the logical flag inficating is dataset should be compressed;
! status - the subroutine call status;
!
!===============================================================================
!
subroutine store_dataset_h5(loc_id, name, type_id, dims, &
buffer, compress, status)
use helpers , only : print_message
use iso_c_binding, only : c_loc
implicit none
integer(hid_t) , intent(in) :: loc_id, type_id
character(len=*) , intent(in) :: name
integer(hsize_t), dimension(:), intent(in) :: dims
type(*), target, dimension(..), intent(in) :: buffer
logical , intent(in) :: compress
integer , intent(out) :: status
integer :: rank
integer(hid_t) :: space_id, dset_id
integer(hsize_t), dimension(size(dims)) :: cdims
character(len=*), parameter :: loc = 'IO::store_dataset_h5()'
!-------------------------------------------------------------------------------
!
rank = size(dims)
cdims = dims
if (compress .and. hcformat .eq. H5Z_ZFP) cdims(rank) = 1
call h5screate_simple_f(rank, dims, space_id, status)
if (status /= 0) then
call print_message(loc, &
"Could not create the dataspace for dataset '" // trim(name) // "'!")
return
end if
call h5pset_chunk_f(prp_id, rank, cdims, status)
if (status /= 0) then
call print_message(loc, &
"Could not set the chunk size for dataset '" // trim(name) // "'!")
go to 1000
end if
if (compress) then
call h5dcreate_f(loc_id, name, type_id, space_id, dset_id, status, prp_id)
else
call h5dcreate_f(loc_id, name, type_id, space_id, dset_id, status)
end if
if (status /= 0) then
call print_message(loc, &
"Could not create dataset '" // trim(name) // "'!")
go to 1000
end if
call h5dwrite_f(dset_id, type_id, c_loc(buffer), status)
if (status /= 0) then
call print_message(loc, "Could not store dataset '" // trim(name) // "'!")
end if
call h5dclose_f(dset_id, status)
if (status /= 0) &
call print_message(loc, "Could not close dataset '" // trim(name) // "'!")
1000 continue
call h5sclose_f(space_id, status)
if (status /= 0) &
call print_message(loc, &
"Could not close the dataspace for dataset '" // trim(name) // "'!")
!-------------------------------------------------------------------------------
!
end subroutine store_dataset_h5
!
!===============================================================================
!
! XDMF SUBROUTINES
!
!===============================================================================
!
! subroutine WRITE_SNAPSHOT_XDMF:
! ------------------------------
!
! Subroutine writes an XDMF file per snapshot per MPI process.
! XDMF file is just a wrapper which helps to load data in a visualization
! tools like Paraview or Visit.
!
! Based on the subroutine by Pierre Kestener
! (see https://bitbucket.org/pkestene/amun-code).
!
!
!===============================================================================
!
subroutine write_snapshot_xdmf()
use blocks , only : block_data, list_data
use blocks , only : get_dblocks
use equations , only : nv, pvars
use mpitools , only : nproc
use coordinates, only : ni => ncells, ng => nghosts
use coordinates, only : adx, ady
#if NDIMS == 3
use coordinates, only : adz
#endif /* NDIMS == 3 */
use evolution , only : time
implicit none
type(block_data), pointer :: pdata
character(len=64) :: fname, hname
character(len=128) :: stmp, ttmp, sdim, bdim, pdim
integer(kind=4) :: l, p
integer(kind=4) :: ip, jp
#if NDIMS == 3
integer(kind=4) :: kp
#endif /* NDIMS == 3 */
integer, dimension(12) :: slab
integer, parameter :: xdmf = 101
!-------------------------------------------------------------------------------
!
write(fname, "('p',i6.6,'_',i5.5,'.xdmf')") isnap, nproc
write(hname, "('p',i6.6,'_',i5.5,'.h5' )") isnap, nproc
open (unit = xdmf, file = fname, status = 'replace')
! write the header
!
write(xdmf, "(a)") '<?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))
#if NDIMS == 3
write(stmp, "(1i8)") ni
#else /* NDIMS == 3 */
write(stmp, "(1i8)") 1
#endif /* NDIMS == 3 */
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(ttmp)) // ' ' // trim(adjustl(stmp))
! prepare slab indices
!
#if NDIMS == 3
slab(:) = (/ -1, ng, ng, ng, 1, 1, 1, 1, 1, ni, ni, ni /)
#else /* NDIMS == 3 */
slab(:) = (/ -1, 0, ng, ng, 1, 1, 1, 1, 1, 1, ni, ni /)
#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(1) = 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(xdmf)
!-------------------------------------------------------------------------------
!
end subroutine write_snapshot_xdmf
!
!===============================================================================
!
! subroutine WRITE_SNAPSHOT_XDMF_MASTER:
! -------------------------------------
!
! Subroutine writes one XDMF file per snapshot in root MPI process to gather
! all MPI subdomains.
!
! Based on the subroutine by Pierre Kestener
! (see https://bitbucket.org/pkestene/amun-code).
!
!
!===============================================================================
!
subroutine write_snapshot_xdmf_master()
use mpitools, only : npmax
implicit none
character(len=64) :: fname, pname
integer(kind=4) :: np
integer, parameter :: xdmf = 102
!-------------------------------------------------------------------------------
!
write(fname, "('p',i6.6,'.xdmf')") isnap
open (unit = xdmf, file = fname, status = 'replace')
! write the header
!
write(xdmf, "(a)") '<?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, "('p',i6.6,'_',i5.5,'.xdmf')") 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(xdmf)
!-------------------------------------------------------------------------------
!
end subroutine write_snapshot_xdmf_master
#endif /* HDF5 */
!===============================================================================
!
end module
Reference in New Issue View Git Blame Copy Permalink