IO: Rewrite read_restart_snapshot_xml().
This subroutine now used the new XML module to parge XML files. It also used new subroutine read_binary_xml() to read binary files. Signed-off-by: Grzegorz Kowal <grzegorz@amuncode.org>
This commit is contained in:
parent
64966c3eb3
commit
14fad08f47
519
sources/io.F90
519
sources/io.F90
@ -1103,7 +1103,6 @@ module io
|
||||
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
|
||||
@ -1111,33 +1110,30 @@ module io
|
||||
#endif /* MPI */
|
||||
use mpitools , only : nprocs, nproc
|
||||
use random , only : gentype, set_seeds
|
||||
use XML , only : XMLNode, XMLParseFile, XMLFreeTree, &
|
||||
XMLGetElementValue
|
||||
|
||||
implicit none
|
||||
|
||||
integer, intent(out) :: status
|
||||
|
||||
type(XMLNode), pointer :: xml_ptr
|
||||
|
||||
logical :: test
|
||||
character(len=255) :: dname, fname, line, sname, svalue
|
||||
character(len=256) :: snapshot_path, file_path
|
||||
character(len= 16) :: aname
|
||||
integer :: il, iu, nl, nx, nm, nd, nv, i, j, l, n, p, nu, nr
|
||||
#if NDIMS == 3
|
||||
integer :: k
|
||||
#endif /* NDIMS == 3 */
|
||||
integer(kind=4) :: lndims, lnprocs, lnproc, lmblocks, lnleafs, llast_id
|
||||
integer(kind=4) :: ldblocks, lncells, lnghosts, lnseeds, lnmodes
|
||||
integer(kind=4) :: lncells, lnghosts, lnseeds, lnmodes
|
||||
integer(kind=8) :: bytes
|
||||
real(kind=8) :: deinj
|
||||
|
||||
type(block_meta), pointer :: pmeta
|
||||
type(block_data), pointer :: pdata
|
||||
|
||||
integer :: 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
|
||||
@ -1162,141 +1158,65 @@ module io
|
||||
!
|
||||
status = 0
|
||||
|
||||
write(dname, "(a,'restart-',i5.5)") trim(respath), nrest
|
||||
write(snapshot_path, "(a,'restart-',i5.5)") trim(respath), nrest
|
||||
|
||||
#ifdef __INTEL_COMPILER
|
||||
inquire(directory=dname, exist=test)
|
||||
inquire(directory=snapshot_path, exist=test)
|
||||
#else /* __INTEL_COMPILER */
|
||||
inquire(file=dname, exist=test)
|
||||
inquire(file=snapshot_path, exist=test)
|
||||
#endif /* __INTEL_COMPILER */
|
||||
if (.not. test) then
|
||||
call print_message(loc, trim(dname) // " does not exist!")
|
||||
call print_message(loc, trim(snapshot_path) // " does not exist!")
|
||||
status = 121
|
||||
return
|
||||
end if
|
||||
dname = trim(dname) // "/"
|
||||
snapshot_path = trim(snapshot_path) // "/"
|
||||
file_path = trim(snapshot_path) // "metadata.xml"
|
||||
|
||||
write(fname,"(a,'metadata.xml')") trim(dname)
|
||||
inquire(file=fname, exist=test)
|
||||
inquire(file=file_path, exist=test)
|
||||
if (.not. test) then
|
||||
call print_message(loc, trim(fname) // " does not exist!")
|
||||
call print_message(loc, "The file '" // trim(file_path) // &
|
||||
"' 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)
|
||||
call XMLParseFile(file_path, xml_ptr, status)
|
||||
|
||||
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)
|
||||
call XMLGetElementValue(xml_ptr, 'Parallelization', 'nprocs' , lnprocs)
|
||||
call XMLGetElementValue(xml_ptr, 'Parallelization', 'nproc' , lnproc)
|
||||
call XMLGetElementValue(xml_ptr, 'Physics' , 'nvars' , nv)
|
||||
call XMLGetElementValue(xml_ptr, 'Geometry' , 'ndims' , lndims)
|
||||
call XMLGetElementValue(xml_ptr, 'Geometry' , 'xmin' , xmin)
|
||||
call XMLGetElementValue(xml_ptr, 'Geometry' , 'xmax' , xmax)
|
||||
call XMLGetElementValue(xml_ptr, 'Geometry' , 'ymin' , ymin)
|
||||
call XMLGetElementValue(xml_ptr, 'Geometry' , 'ymax' , ymax)
|
||||
#if NDIMS == 3
|
||||
call XMLGetElementValue(xml_ptr, 'Geometry' , 'zmin' , zmin)
|
||||
call XMLGetElementValue(xml_ptr, 'Geometry' , 'zmax' , zmax)
|
||||
#endif /* NDIMS == 3 */
|
||||
call XMLGetElementValue(xml_ptr, 'Mesh' , 'ncells' , lncells)
|
||||
call XMLGetElementValue(xml_ptr, 'Mesh' , 'nghosts' , lnghosts)
|
||||
call XMLGetElementValue(xml_ptr, 'Mesh' , 'mblocks' , lmblocks)
|
||||
call XMLGetElementValue(xml_ptr, 'Mesh' , 'nleafs' , lnleafs)
|
||||
call XMLGetElementValue(xml_ptr, 'Mesh' , 'last_id' , llast_id)
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'step' , step)
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'time' , time)
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'dt' , dt)
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'dth' , dth)
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'dte' , dte)
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'cmax' , cmax)
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'cglm' , cglm)
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'niterations', niterations)
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'nrejections', nrejections)
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'errs(1)' , errs(1))
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'errs(2)' , errs(2))
|
||||
call XMLGetElementValue(xml_ptr, 'Evolution' , 'errs(3)' , errs(3))
|
||||
call XMLGetElementValue(xml_ptr, 'Forcing' , 'nmodes' , lnmodes)
|
||||
call XMLGetElementValue(xml_ptr, 'Random' , 'nseeds' , lnseeds)
|
||||
call XMLGetElementValue(xml_ptr, 'Snapshots' , 'isnap' , isnap)
|
||||
|
||||
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)
|
||||
cmax2 = cmax * cmax
|
||||
|
||||
if (lndims /= NDIMS) then
|
||||
call print_message(loc, "The number of dimensions does not match!")
|
||||
@ -1332,44 +1252,31 @@ module io
|
||||
|
||||
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)
|
||||
call read_binary_xml(snapshot_path, 'fields' , c_loc(fields), &
|
||||
bytes, xml_ptr, status)
|
||||
|
||||
bytes = size(children, kind=8) * kind(children)
|
||||
call check_digest(loc, fname, c_loc(children), bytes, hchild, dtype)
|
||||
call read_binary_xml(snapshot_path, 'children', c_loc(children), &
|
||||
bytes, xml_ptr, status)
|
||||
|
||||
#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)
|
||||
call read_binary_xml(snapshot_path, 'faces' , c_loc(faces), &
|
||||
bytes, xml_ptr, status)
|
||||
|
||||
#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)
|
||||
call read_binary_xml(snapshot_path, 'edges' , c_loc(edges), &
|
||||
bytes, xml_ptr, status)
|
||||
|
||||
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)
|
||||
call read_binary_xml(snapshot_path, 'corners' , c_loc(corners), &
|
||||
bytes, xml_ptr, status)
|
||||
|
||||
bytes = size(bounds, kind=8) * kind(bounds)
|
||||
call check_digest(loc, fname, c_loc(bounds), bytes, hbound, dtype)
|
||||
call read_binary_xml(snapshot_path, 'bounds' , c_loc(bounds), &
|
||||
bytes, xml_ptr, status)
|
||||
|
||||
l = 0
|
||||
pmeta => list_meta
|
||||
@ -1453,14 +1360,14 @@ module io
|
||||
|
||||
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) * 2
|
||||
call check_digest(loc, fname, c_loc(lfcoefs), bytes, hforce, dtype)
|
||||
call read_binary_xml(snapshot_path, 'forcing', c_loc(lfcoefs), &
|
||||
bytes, xml_ptr, status)
|
||||
|
||||
fcoefs = lfcoefs
|
||||
deallocate(lfcoefs, stat=status)
|
||||
if (status /= 0) &
|
||||
@ -1475,6 +1382,10 @@ module io
|
||||
call print_message(loc, "The number of forcing modes does not match!")
|
||||
end if
|
||||
|
||||
! release the XML tree for 'metadata.xml' file
|
||||
!
|
||||
call XMLFreeTree(xml_ptr)
|
||||
|
||||
if (nprocs >= lnprocs) then
|
||||
|
||||
! spread the restart snapshots reading across new processes so we do not
|
||||
@ -1496,64 +1407,20 @@ module io
|
||||
|
||||
if (nl >= 0) then
|
||||
|
||||
write(fname,sfmt) trim(dname), "datablocks", nl, "xml"
|
||||
inquire(file=fname, exist=test)
|
||||
write(file_path, sfmt) trim(snapshot_path), "datablocks", nl, "xml"
|
||||
inquire(file=file_path, exist=test)
|
||||
if (.not. test) then
|
||||
write(*,*) trim(fname) // " does not exist!"
|
||||
call print_message(loc, "The file '" // trim(file_path) // &
|
||||
"' 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)
|
||||
call XMLParseFile(file_path, xml_ptr, status)
|
||||
|
||||
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)
|
||||
call XMLGetElementValue(xml_ptr, 'DataBlocks', 'dblocks', nd)
|
||||
call XMLGetElementValue(xml_ptr, 'DataBlocks', 'nregs' , nr)
|
||||
call XMLGetElementValue(xml_ptr, 'Forcing' , 'einj' , einj)
|
||||
|
||||
nm = lncells + 2 * lnghosts
|
||||
if (lnghosts >= nghosts) then
|
||||
@ -1574,27 +1441,18 @@ module io
|
||||
|
||||
if (status == 0) then
|
||||
|
||||
write(fname,sfmt) trim(dname), "datablock_ids", nl, "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
|
||||
call read_binary_xml(snapshot_path, 'ids', c_loc(ids), &
|
||||
bytes, xml_ptr, status)
|
||||
|
||||
bytes = size(array, kind=8) * kind(array) / nr
|
||||
do l = 1, nd
|
||||
call append_datablock(pdata, status)
|
||||
call link_blocks(block_array(ids(l))%ptr, pdata)
|
||||
|
||||
write(fname,"(a,'datablock_prim_',i6.6,'_',i6.6,'.bin')") &
|
||||
trim(dname), nl, 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)
|
||||
write(aname, "('prim_',i6.6)") l
|
||||
call read_binary_xml(snapshot_path, aname, c_loc(array), &
|
||||
bytes, xml_ptr, status)
|
||||
|
||||
if (lnghosts >= nghosts) then
|
||||
#if NDIMS == 3
|
||||
@ -1610,13 +1468,9 @@ module io
|
||||
#endif /* NDIMS == 3 */
|
||||
end if
|
||||
|
||||
write(fname,"(a,'datablock_cons_',i6.6,'_',i6.6,'.bin')") &
|
||||
trim(dname), nl, 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)
|
||||
write(aname, "('cons_',i6.6)") l
|
||||
call read_binary_xml(snapshot_path, aname, c_loc(array), &
|
||||
bytes * nr, xml_ptr, status)
|
||||
|
||||
p = min(nregs, nr)
|
||||
if (lnghosts >= nghosts) then
|
||||
@ -1634,7 +1488,7 @@ module io
|
||||
end if
|
||||
end do
|
||||
|
||||
deallocate(ids, array, hprim, hcons, stat=status)
|
||||
deallocate(ids, array, stat=status)
|
||||
if (status /= 0) &
|
||||
call print_message(loc, "Could not release space of datablocks!")
|
||||
else
|
||||
@ -1646,12 +1500,9 @@ module io
|
||||
|
||||
if (status == 0) then
|
||||
|
||||
write(fname,sfmt) trim(dname), "random_seeds", nl, "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 read_binary_xml(snapshot_path, 'seeds', c_loc(seeds), &
|
||||
bytes, xml_ptr, status)
|
||||
call set_seeds(lnseeds, seeds(:,:), .false.)
|
||||
|
||||
deallocate(seeds, stat=status)
|
||||
@ -1661,40 +1512,11 @@ module io
|
||||
call print_message(loc, "Could not allocate space for seeds!")
|
||||
end if
|
||||
|
||||
call XMLFreeTree(xml_ptr)
|
||||
|
||||
else ! nl < 0
|
||||
|
||||
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
|
||||
! restore PRNG seeds for the remaining processes
|
||||
!
|
||||
if (trim(gentype) == "same") then
|
||||
|
||||
@ -1702,14 +1524,24 @@ module io
|
||||
|
||||
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)
|
||||
write(file_path, sfmt) trim(snapshot_path), "datablocks", 0, "xml"
|
||||
inquire(file=file_path, exist=test)
|
||||
if (.not. test) then
|
||||
call print_message(loc, "The file '" // trim(file_path) // &
|
||||
"' does not exist.")
|
||||
status = 121
|
||||
return
|
||||
end if
|
||||
|
||||
call XMLParseFile(file_path, xml_ptr, status)
|
||||
|
||||
bytes = size(seeds, kind=8) * kind(seeds)
|
||||
call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype)
|
||||
call read_binary_xml(snapshot_path, 'seeds', c_loc(seeds), &
|
||||
bytes, xml_ptr, status)
|
||||
call set_seeds(lnseeds, seeds(:,:), .false.)
|
||||
|
||||
call XMLFreeTree(xml_ptr)
|
||||
|
||||
deallocate(seeds, stat=status)
|
||||
if (status /= 0) &
|
||||
call print_message(loc, "Could not release space of seeds!")
|
||||
@ -1747,66 +1579,21 @@ module io
|
||||
|
||||
do n = nl, nu
|
||||
|
||||
write(fname,sfmt) trim(dname), "datablocks", n, "xml"
|
||||
inquire(file=fname, exist=test)
|
||||
write(file_path, sfmt) trim(snapshot_path), "datablocks", n, "xml"
|
||||
inquire(file=file_path, exist=test)
|
||||
if (.not. test) then
|
||||
write(*,*) trim(fname) // " does not exist!"
|
||||
call print_message(loc, "The file '" // trim(file_path) // &
|
||||
"' 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)
|
||||
call XMLParseFile(file_path, xml_ptr, status)
|
||||
|
||||
call XMLGetElementValue(xml_ptr, 'DataBlocks', 'dblocks', nd)
|
||||
call XMLGetElementValue(xml_ptr, 'DataBlocks', 'nregs' , nr)
|
||||
call XMLGetElementValue(xml_ptr, 'Forcing' , 'einj' , deinj)
|
||||
|
||||
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
|
||||
@ -1828,27 +1615,18 @@ module io
|
||||
|
||||
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
|
||||
call read_binary_xml(snapshot_path, 'ids', c_loc(ids), &
|
||||
bytes, xml_ptr, status)
|
||||
|
||||
bytes = size(array, kind=8) * kind(array) / nr
|
||||
do l = 1, nd
|
||||
call append_datablock(pdata, status)
|
||||
call link_blocks(block_array(ids(l))%ptr, pdata)
|
||||
|
||||
write(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)
|
||||
write(aname, "('prim_',i6.6)") l
|
||||
call read_binary_xml(snapshot_path, aname, c_loc(array), &
|
||||
bytes, xml_ptr, status)
|
||||
|
||||
if (lnghosts >= nghosts) then
|
||||
#if NDIMS == 3
|
||||
@ -1864,13 +1642,9 @@ module io
|
||||
#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)
|
||||
write(aname, "('cons_',i6.6)") l
|
||||
call read_binary_xml(snapshot_path, aname, c_loc(array), &
|
||||
bytes * nr, xml_ptr, status)
|
||||
|
||||
p = min(nregs, nr)
|
||||
if (lnghosts >= nghosts) then
|
||||
@ -1888,28 +1662,41 @@ module io
|
||||
end if
|
||||
end do
|
||||
|
||||
deallocate(ids, array, hprim, hcons, stat=status)
|
||||
deallocate(ids, array, stat=status)
|
||||
if (status /= 0) &
|
||||
call print_message(loc, "Could not release space of datablocks!")
|
||||
else
|
||||
call print_message(loc, "Could not allocate space for datablocks!")
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
call XMLFreeTree(xml_ptr)
|
||||
|
||||
end do ! n = nl, nu
|
||||
|
||||
allocate(seeds(4,lnseeds), stat=status)
|
||||
|
||||
if (status == 0) then
|
||||
|
||||
write(fname,sfmt) trim(dname), "random_seeds", nproc, "bin"
|
||||
open(newunit=lun, file=fname, form='unformatted', access='stream')
|
||||
read(lun) seeds
|
||||
close(lun)
|
||||
write(file_path, sfmt) trim(snapshot_path), "datablocks", nproc, "xml"
|
||||
inquire(file=file_path, exist=test)
|
||||
if (.not. test) then
|
||||
call print_message(loc, "The file '" // trim(file_path) // &
|
||||
"' does not exist.")
|
||||
status = 121
|
||||
return
|
||||
end if
|
||||
|
||||
call XMLParseFile(file_path, xml_ptr, status)
|
||||
|
||||
bytes = size(seeds, kind=8) * kind(seeds)
|
||||
call check_digest(loc, fname, c_loc(seeds), bytes, hseed, dtype)
|
||||
call read_binary_xml(snapshot_path, 'seeds', c_loc(seeds), &
|
||||
bytes, xml_ptr, status)
|
||||
call set_seeds(lnseeds, seeds(:,:), .false.)
|
||||
|
||||
call XMLFreeTree(xml_ptr)
|
||||
|
||||
deallocate(seeds, stat=status)
|
||||
if (status /= 0) &
|
||||
call print_message(loc, "Could not release space of seeds!")
|
||||
@ -2949,7 +2736,7 @@ module io
|
||||
integer :: io, item_size
|
||||
integer :: digest_type, digest_length
|
||||
integer :: compressor_id, encoder_id
|
||||
integer(kind=8) :: hash, usize, csize, dsize
|
||||
integer(kind=8) :: hash, usize, csize
|
||||
integer(kind=1), dimension(:), pointer :: array
|
||||
integer(kind=1), dimension(:), allocatable, target :: buffer
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user