crp/OpenMC
1
0
Fork 0
mirror of https://github.com/openmc-dev/openmc.git synced 2026-07-28 14:15:42 -04:00
Code Issues Projects Releases Packages Wiki Activity Actions 5

Merge pull request #915 from paulromano/the-big-refactor

Browse source 
Refactoring source organization, tally initialization, global variables
This commit is contained in:
Sterling Harper 2017-09-29 17:11:16 -04:00 • committed by GitHub
commit 54052385e4
95 changed files with 8264 additions and 6433 deletions
Download patch file Download diff file Expand all files Collapse all files

40
CMakeLists.txt
View file

@ -119,8 +119,8 @@ if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU)
list(APPEND f90flags -cpp -std=f2008ts -fbacktrace -O2)
if(debug)
list(REMOVE_ITEM f90flags -O2)
list(APPEND f90flags -g -Wall -pedantic -fbounds-check
-ffpe-trap=invalid,overflow,underflow)
list(APPEND f90flags -g -Wall -Wno-unused-dummy-argument -pedantic
-fbounds-check -ffpe-trap=invalid,overflow,underflow)
list(APPEND ldflags -g)
endif()
if(profile)
@ -322,7 +322,6 @@ set(LIBOPENMC_FORTRAN_SRC
src/error.F90
src/geometry.F90
src/geometry_header.F90
src/global.F90
src/hdf5_interface.F90
src/initialize.F90
src/input_xml.F90
@ -359,6 +358,8 @@ set(LIBOPENMC_FORTRAN_SRC
src/secondary_nbody.F90
src/secondary_uncorrelated.F90
src/set_header.F90
src/settings.F90
src/simulation_header.F90
src/simulation.F90
src/source.F90
src/source_header.F90
@ -367,21 +368,36 @@ set(LIBOPENMC_FORTRAN_SRC
src/string.F90
src/summary.F90
src/surface_header.F90
src/tally.F90
src/tally_filter.F90
src/tally_filter_header.F90
src/tally_header.F90
src/tally_initialize.F90
src/timer_header.F90
src/tracking.F90
src/track_output.F90
src/trigger.F90
src/trigger_header.F90
src/urr_header.F90
src/vector_header.F90
src/volume_calc.F90
src/volume_header.F90
src/xml_interface.F90)
src/xml_interface.F90
src/tallies/tally.F90
src/tallies/tally_derivative_header.F90
src/tallies/tally_filter.F90
src/tallies/tally_filter_header.F90
src/tallies/tally_filter_azimuthal.F90
src/tallies/tally_filter_cell.F90
src/tallies/tally_filter_cellborn.F90
src/tallies/tally_filter_cellfrom.F90
src/tallies/tally_filter_delayedgroup.F90
src/tallies/tally_filter_distribcell.F90
src/tallies/tally_filter_energy.F90
src/tallies/tally_filter_energyfunc.F90
src/tallies/tally_filter_material.F90
src/tallies/tally_filter_mesh.F90
src/tallies/tally_filter_mu.F90
src/tallies/tally_filter_polar.F90
src/tallies/tally_filter_surface.F90
src/tallies/tally_filter_universe.F90
src/tallies/tally_header.F90
src/tallies/trigger.F90
src/tallies/trigger_header.F90
)
add_library(libopenmc SHARED ${LIBOPENMC_FORTRAN_SRC})
set_target_properties(libopenmc PROPERTIES OUTPUT_NAME openmc)
add_executable(${program} src/main.F90)
@ -412,7 +428,7 @@ target_link_libraries(${program} ${ldflags} libopenmc)
add_custom_command(TARGET libopenmc POST_BUILD
COMMAND ${CMAKE_COMMAND} -E copy
$<TARGET_FILE:libopenmc>
${CMAKE_CURRENT_SOURCE_DIR}/openmc/capi/_$<TARGET_FILE_NAME:libopenmc>
${CMAKE_CURRENT_SOURCE_DIR}/openmc/capi/$<TARGET_FILE_NAME:libopenmc>
COMMENT "Copying libopenmc to Python module directory")
#===============================================================================

10
docs/source/capi/index.rst
View file

@ -4,7 +4,7 @@
C API
=====
.. c:function:: void openmc_calculate_voumes()
.. c:function:: void openmc_calculate_volumes()
Run a stochastic volume calculation
@ -52,7 +52,7 @@ C API
cell that was found and zero otherwise.
:type instance: int32_t*
.. c:function:: int openmc_get_cell(int32_t id, int32_t* index)
.. c:function:: int openmc_get_cell_index(int32_t id, int32_t* index)
Get the index in the cells array for a cell with a given ID
@ -70,7 +70,7 @@ C API
:return: Return status (negative if an error occurs)
:rtype: int
.. c:function:: int openmc_get_nuclide(char name[], int* index)
.. c:function:: int openmc_get_nuclide_index(char name[], int* index)
Get the index in the nuclides array for a nuclide with a given name
@ -81,7 +81,7 @@ C API
:return: Return status (negative if an error occurs)
:rtype: int
.. c:function:: int openmc_get_tally(int32_t id, int32_t* index)
.. c:function:: int openmc_get_tally_index(int32_t id, int32_t* index)
Get the index in the tallies array for a tally with a given ID
@ -92,7 +92,7 @@ C API
:return: Return status (negative if an error occurs)
:rtype: int
.. c:function:: int openmc_get_material(int32_t id, int32_t* index)
.. c:function:: int openmc_get_material_index(int32_t id, int32_t* index)
Get the index in the materials array for a material with a given ID

4
openmc/capi/__init__.py
View file

@ -27,7 +27,7 @@ else:
# Open shared library
_filename = pkg_resources.resource_filename(
__name__, '_libopenmc.{}'.format(_suffix))
__name__, 'libopenmc.{}'.format(_suffix))
_dll = CDLL(_filename)
from .error import *
@ -35,4 +35,6 @@ from .core import *
from .nuclide import *
from .material import *
from .cell import *
from .filter import *
from .tally import *
from .settings import settings

55
openmc/capi/cell.py
View file

@ -1,11 +1,14 @@
from collections import Mapping
from collections import Mapping, Iterable
from ctypes import c_int, c_int32, c_double, c_char_p, POINTER
from weakref import WeakValueDictionary
import numpy as np
from numpy.ctypeslib import as_array
from . import _dll
from .core import _View
from .error import _error_handler
from .material import MaterialView
__all__ = ['CellView', 'cells']
@ -13,16 +16,22 @@ __all__ = ['CellView', 'cells']
_dll.openmc_cell_get_id.argtypes = [c_int32, POINTER(c_int32)]
_dll.openmc_cell_get_id.restype = c_int
_dll.openmc_cell_get_id.errcheck = _error_handler
_dll.openmc_cell_get_fill.argtypes = [
c_int32, POINTER(c_int), POINTER(POINTER(c_int32)), POINTER(c_int32)]
_dll.openmc_cell_set_fill.argtypes = [
c_int32, c_int, c_int32, POINTER(c_int32)]
_dll.openmc_cell_set_fill.restype = c_int
_dll.openmc_cell_set_fill.errcheck = _error_handler
_dll.openmc_cell_set_temperature.argtypes = [
c_int32, c_double, POINTER(c_int32)]
_dll.openmc_cell_set_temperature.restype = c_int
_dll.openmc_cell_set_temperature.errcheck = _error_handler
_dll.openmc_get_cell.argtypes = [c_int32, POINTER(c_int32)]
_dll.openmc_get_cell.restype = c_int
_dll.openmc_get_cell.errcheck = _error_handler
_dll.openmc_get_cell_index.argtypes = [c_int32, POINTER(c_int32)]
_dll.openmc_get_cell_index.restype = c_int
_dll.openmc_get_cell_index.errcheck = _error_handler
class CellView(object):
class CellView(_View):
"""View of a cell.
This class exposes a cell that is stored internally in the OpenMC solver. To
@ -48,15 +57,40 @@ class CellView(object):
cls.__instances[args] = instance
return cls.__instances[args]
def __init__(self, index):
self._index = index
@property
def id(self):
cell_id = c_int32()
_dll.openmc_cell_get_id(self._index, cell_id)
return cell_id.value
@property
def fill(self):
fill_type = c_int()
indices = POINTER(c_int32)()
n = c_int32()
_dll.openmc_cell_get_fill(self._index, fill_type, indices, n)
if fill_type.value == 1:
if n.value > 1:
return [MaterialView(i) for i in indices[:n.value]]
else:
return MaterialView(indices[0])
else:
raise NotImplementedError
@fill.setter
def fill(self, fill):
if isinstance(fill, Iterable):
n = len(fill)
indices = (c_int*n)(*(m._index for m in fill))
_dll.openmc_cell_set_fill(self._index, 1, 1, indices)
elif isinstance(fill, MaterialView):
materials = [fill]
indices = (c_int*1)(fill._index)
_dll.openmc_cell_set_fill(self._index, 1, 1, indices)
else:
raise NotImplementedError
def set_temperature(self, T, instance=None):
"""Set the temperature of a cell
@ -74,7 +108,7 @@ class CellView(object):
class _CellMapping(Mapping):
def __getitem__(self, key):
index = c_int32()
_dll.openmc_get_cell(key, index)
_dll.openmc_get_cell_index(key, index)
return CellView(index.value)
def __iter__(self):
@ -84,4 +118,7 @@ class _CellMapping(Mapping):
def __len__(self):
return c_int32.in_dll(_dll, 'n_cells').value
def __repr__(self):
return repr(dict(self))
cells = _CellMapping()

27
openmc/capi/core.py
View file

@ -153,5 +153,28 @@ def run_in_memory(intracomm=None):
"""
init(intracomm)
yield
finalize()
try:
yield
finally:
finalize()
class _DLLGlobal(object):
"""Data descriptor that exposes global variables from libopenmc."""
def __init__(self, ctype, name):
self.ctype = ctype
self.name = name
def __get__(self, instance, owner):
return self.ctype.in_dll(_dll, self.name).value
def __set__(self, instance, value):
self.ctype.in_dll(_dll, self.name).value = value
class _View(object):
def __init__(self, index):
self._index = index
def __repr__(self):
return "{}[{}]".format(type(self).__name__, self._index)

109
openmc/capi/error.py
View file

@ -1,10 +1,45 @@
from ctypes import c_int
from ctypes import c_int, c_char
from . import _dll
class GeometryError(Exception):
pass
class Error(Exception):
"""Root exception class for OpenMC."""
class GeometryError(Error):
"""Geometry-related error"""
class InvalidIDError(Error):
"""Use of an ID that is invalid."""
class AllocationError(Error):
"""Error related to memory allocation."""
class OutOfBoundsError(Error):
"""Index in array out of bounds."""
class DataError(Error):
"""Error relating to nuclear data."""
class PhysicsError(Error):
"""Error relating to performing physics."""
class InvalidArgumentError(Error):
"""Argument passed was invalid."""
class InvalidTypeError(Error):
"""Tried to perform an operation on the wrong type."""
_errmsg = (c_char*256).in_dll(_dll, 'openmc_err_msg')
def _error_handler(err, func, args):
@ -14,53 +49,27 @@ def _error_handler(err, func, args):
def errcode(s):
return c_int.in_dll(_dll, s).value
if err == errcode('e_out_of_bounds'):
raise IndexError('Array index out of bounds.')
elif err == errcode('e_cell_not_allocated'):
raise MemoryError("Memory has not been allocated for cells.")
elif err == errcode('e_cell_invalid_id'):
raise KeyError("No cell exists with ID={}.".format(args[0]))
elif err == errcode('e_cell_not_found'):
raise GeometryError("Could not find cell at position ({}, {}, {})"
.format(*args[0]))
elif err == errcode('e_nuclide_not_allocated'):
raise MemoryError("Memory has not been allocated for nuclides.")
elif err == errcode('e_nuclide_not_loaded'):
raise KeyError("No nuclide named '{}' has been loaded.")
elif err == errcode('e_nuclide_not_in_library'):
raise KeyError("Specified nuclide doesn't exist in the cross "
"section library.")
elif err == errcode('e_material_not_allocated'):
raise MemoryError("Memory has not been allocated for materials.")
elif err == errcode('e_material_invalid_id'):
raise KeyError("No material exists with ID={}.".format(args[0]))
elif err == errcode('e_tally_not_allocated'):
raise MemoryError("Memory has not been allocated for tallies.")
elif err == errcode('e_tally_invalid_id'):
raise KeyError("No tally exists with ID={}.".format(args[0]))
elif err == errcode('e_invalid_size'):
raise MemoryError("Array size mismatch with memory allocated.")
elif err == errcode('e_cell_no_material'):
raise GeometryError("Operation on cell requires that it be filled"
" with a material.")
elif err == errcode('w_below_min_bound'):
warn("Data has not been loaded beyond lower bound of {}.".format(args[0]))
elif err == errcode('w_above_max_bound'):
warn("Data has not been loaded beyond upper bound of {}.".format(args[0]))
# Get error message set by OpenMC library
msg = _errmsg.value.decode()
# Raise exception type corresponding to error code
if err == errcode('e_allocate'):
raise AllocationError(msg)
elif err == errcode('e_out_of_bounds'):
raise OutOfBoundsError(msg)
elif err == errcode('e_invalid_argument'):
raise InvalidArgumentError(msg)
elif err == errcode('e_invalid_type'):
raise InvalidTypeError(msg)
if err == errcode('e_invalid_id'):
raise InvalidIDError(msg)
elif err == errcode('e_geometry'):
raise GeometryError(msg)
elif err == errcode('e_data'):
raise DataError(msg)
elif err == errcode('e_physics'):
raise PhysicsError(msg)
elif err == errcode('e_warning'):
warn(msg)
elif err < 0:
raise Exception("Unknown error encountered (code {}).".format(err))

224
openmc/capi/filter.py Normal file
View file

@ -0,0 +1,224 @@
from collections import Mapping
from ctypes import c_int, c_int32, c_double, c_char_p, POINTER, \
create_string_buffer
from weakref import WeakValueDictionary
import numpy as np
from numpy.ctypeslib import as_array
from . import _dll
from .core import _View
from .error import _error_handler
from .material import MaterialView
__all__ = ['FilterView', 'AzimuthalFilterView', 'CellFilterView',
'CellbornFilterView', 'CellfromFilterView', 'DistribcellFilterView',
'DelayedGroupFilterView', 'EnergyFilterView', 'EnergyoutFilterView',
'EnergyFunctionFilterView', 'MaterialFilterView', 'MeshFilterView',
'MuFilterView', 'PolarFilterView', 'SurfaceFilterView',
'UniverseFilterView', 'filters']
# Tally functions
_dll.openmc_energy_filter_get_bins.argtypes = [
c_int32, POINTER(POINTER(c_double)), POINTER(c_int32)]
_dll.openmc_energy_filter_get_bins.restype = c_int
_dll.openmc_energy_filter_get_bins.errcheck = _error_handler
_dll.openmc_energy_filter_set_bins.argtypes = [c_int32, c_int32, POINTER(c_double)]
_dll.openmc_energy_filter_set_bins.restype = c_int
_dll.openmc_energy_filter_set_bins.errcheck = _error_handler
_dll.openmc_extend_filters.argtypes = [c_int32, POINTER(c_int32), POINTER(c_int32)]
_dll.openmc_extend_filters.restype = c_int
_dll.openmc_extend_filters.errcheck = _error_handler
_dll.openmc_filter_get_id.argtypes = [c_int32, POINTER(c_int32)]
_dll.openmc_filter_get_id.restype = c_int
_dll.openmc_filter_get_id.errcheck = _error_handler
_dll.openmc_filter_get_type.argtypes = [c_int32, c_char_p]
_dll.openmc_filter_get_type.restype = c_int
_dll.openmc_filter_get_type.errcheck = _error_handler
_dll.openmc_filter_set_id.argtypes = [c_int32, c_int32]
_dll.openmc_filter_set_id.restype = c_int
_dll.openmc_filter_set_id.errcheck = _error_handler
_dll.openmc_filter_set_type.argtypes = [c_int32, c_char_p]
_dll.openmc_filter_set_type.restype = c_int
_dll.openmc_filter_set_type.errcheck = _error_handler
_dll.openmc_get_filter_index.argtypes = [c_int32, POINTER(c_int32)]
_dll.openmc_get_filter_index.restype = c_int
_dll.openmc_get_filter_index.errcheck = _error_handler
_dll.openmc_material_filter_get_bins.argtypes = [
c_int32, POINTER(POINTER(c_int32)), POINTER(c_int32)]
_dll.openmc_material_filter_get_bins.restype = c_int
_dll.openmc_material_filter_get_bins.errcheck = _error_handler
_dll.openmc_material_filter_set_bins.argtypes = [c_int32, c_int32, POINTER(c_int32)]
_dll.openmc_material_filter_set_bins.restype = c_int
_dll.openmc_material_filter_set_bins.errcheck = _error_handler
_dll.openmc_mesh_filter_set_mesh.argtypes = [c_int32, c_int32]
_dll.openmc_mesh_filter_set_mesh.restype = c_int
_dll.openmc_mesh_filter_set_mesh.errcheck = _error_handler
class FilterView(_View):
__instances = WeakValueDictionary()
def __new__(cls, *args):
if args not in cls.__instances:
instance = super().__new__(cls)
cls.__instances[args] = instance
return cls.__instances[args]
@property
def id(self):
filter_id = c_int32()
_dll.openmc_filter_get_id(self._index, filter_id)
return filter_id.value
@id.setter
def id(self, filter_id):
_dll.openmc_filter_set_id(self._index, filter_id)
class EnergyFilterView(FilterView):
@property
def bins(self):
energies = POINTER(c_double)()
n = c_int32()
_dll.openmc_energy_filter_get_bins(self._index, energies, n)
return as_array(energies, (n.value,))
@bins.setter
def bins(self, bins):
# Get numpy array as a double*
energies = np.asarray(bins)
energies_p = energies.ctypes.data_as(POINTER(c_double))
_dll.openmc_energy_filter_set_bins(
self._index, len(energies), energies_p)
class EnergyoutFilterView(FilterView):
pass
class AzimuthalFilterView(FilterView):
pass
class CellFilterView(FilterView):
pass
class CellbornFilterView(FilterView):
pass
class CellfromFilterView(FilterView):
pass
class DelayedGroupFilterView(FilterView):
pass
class DistribcellFilterView(FilterView):
pass
class EnergyFunctionFilterView(FilterView):
pass
class MaterialFilterView(FilterView):
@property
def bins(self):
materials = POINTER(c_int32)()
n = c_int32()
_dll.openmc_material_filter_get_bins(self._index, materials, n)
return [MaterialView(materials[i]) for i in range(n.value)]
@bins.setter
def bins(self, materials):
# Get material indices as int32_t[]
n = len(materials)
bins = (c_int32*n)(*(m._index for m in materials))
_dll.openmc_material_filter_set_bins(self._index, n, bins)
@classmethod
def new(cls, bins=None, filter_id=None):
# Determine filter ID to assign
if filter_id is None:
filter_id = max(filters) + 1
index = c_int32()
_dll.openmc_extend_filters(1, index, None)
_dll.openmc_filter_set_type(index, b'material')
f = cls(index.value)
f.id = filter_id
if bins is not None:
f.bins = bins
return f
class MeshFilterView(FilterView):
pass
class MuFilterView(FilterView):
pass
class PolarFilterView(FilterView):
pass
class SurfaceFilterView(FilterView):
pass
class UniverseFilterView(FilterView):
pass
_filter_type_map = {
'azimuthal': AzimuthalFilterView,
'cell': CellFilterView,
'cellborn': CellbornFilterView,
'cellfrom': CellfromFilterView,
'delayedgroup': DelayedGroupFilterView,
'distribcell': DistribcellFilterView,
'energy': EnergyFilterView,
'energyout': EnergyoutFilterView,
'energyfunction': EnergyFunctionFilterView,
'material': MaterialFilterView,
'mesh': MeshFilterView,
'mu': MuFilterView,
'polar': PolarFilterView,
'surface': SurfaceFilterView,
'universe': UniverseFilterView,
}
def _get_filter(index):
filter_type = create_string_buffer(20)
_dll.openmc_filter_get_type(index, filter_type)
filter_type = filter_type.value.decode()
return _filter_type_map[filter_type](index)
class _FilterMapping(Mapping):
def __getitem__(self, key):
index = c_int32()
_dll.openmc_get_filter_index(key, index)
return _get_filter(index.value)
def __iter__(self):
for i in range(len(self)):
yield TallyView(i + 1).id
def __len__(self):
return c_int32.in_dll(_dll, 'n_filters').value
def __repr__(self):
return repr(dict(self))
filters = _FilterMapping()

47
openmc/capi/material.py
View file

@ -6,15 +6,19 @@ import numpy as np
from numpy.ctypeslib import as_array
from . import _dll, NuclideView
from .core import _View
from .error import _error_handler
__all__ = ['MaterialView', 'materials']
# Material functions
_dll.openmc_get_material.argtypes = [c_int32, POINTER(c_int32)]
_dll.openmc_get_material.restype = c_int
_dll.openmc_get_material.errcheck = _error_handler
_dll.openmc_extend_materials.argtypes = [c_int32, POINTER(c_int32), POINTER(c_int32)]
_dll.openmc_extend_materials.restype = c_int
_dll.openmc_extend_materials.errcheck = _error_handler
_dll.openmc_get_material_index.argtypes = [c_int32, POINTER(c_int32)]
_dll.openmc_get_material_index.restype = c_int
_dll.openmc_get_material_index.errcheck = _error_handler
_dll.openmc_material_add_nuclide.argtypes = [
c_int32, c_char_p, c_double]
_dll.openmc_material_add_nuclide.restype = c_int
@ -34,9 +38,12 @@ _dll.openmc_material_set_densities.argtypes = [
c_int32, c_int, POINTER(c_char_p), POINTER(c_double)]
_dll.openmc_material_set_densities.restype = c_int
_dll.openmc_material_set_densities.errcheck = _error_handler
_dll.openmc_material_set_id.argtypes = [c_int32, c_int32]
_dll.openmc_material_set_id.restype = c_int
_dll.openmc_material_set_id.errcheck = _error_handler
class MaterialView(object):
class MaterialView(_View):
"""View of a material.
This class exposes a material that is stored internally in the OpenMC
@ -60,21 +67,16 @@ class MaterialView(object):
"""
__instances = WeakValueDictionary()
def __new__(cls, *args):
if args not in cls.__instances:
instance = super().__new__(cls)
cls.__instances[args] = instance
return cls.__instances[args]
def __init__(self, index):
self._index = index
@property
def id(self):
mat_id = c_int32()
_dll.openmc_material_get_id(self._index, mat_id)
return mat_id.value
@id.setter
def id(self, mat_id):
_dll.openmc_material_set_id(self._index, mat_id)
@property
def nuclides(self):
return self._get_densities()[0]
@ -108,7 +110,7 @@ class MaterialView(object):
density_array = as_array(densities, (n.value,))
return nuclide_list, density_array
def add_nuclide(name, density):
def add_nuclide(self, name, density):
"""Add a nuclide to a material.
Parameters
@ -121,6 +123,18 @@ class MaterialView(object):
"""
_dll.openmc_material_add_nuclide(self._index, name.encode(), density)
@classmethod
def new(cls, material_id=None):
# Determine ID to assign
if material_id is None:
material_id = max(materials) + 1
index = c_int32()
_dll.openmc_extend_materials(1, index, None)
mat = cls(index.value)
mat.id = material_id
return mat
def set_density(self, density):
"""Set density of a material.
@ -157,7 +171,7 @@ class MaterialView(object):
class _MaterialMapping(Mapping):
def __getitem__(self, key):
index = c_int32()
_dll.openmc_get_material(key, index)
_dll.openmc_get_material_index(key, index)
return MaterialView(index.value)
def __iter__(self):
@ -167,4 +181,7 @@ class _MaterialMapping(Mapping):
def __len__(self):
return c_int32.in_dll(_dll, 'n_materials').value
def __repr__(self):
return repr(dict(self))
materials = _MaterialMapping()

19
openmc/capi/nuclide.py
View file

@ -6,15 +6,16 @@ import numpy as np
from numpy.ctypeslib import as_array
from . import _dll
from .core import _View
from .error import _error_handler
__all__ = ['NuclideView', 'nuclides', 'load_nuclide']
# Nuclide functions
_dll.openmc_get_nuclide.argtypes = [c_char_p, POINTER(c_int)]
_dll.openmc_get_nuclide.restype = c_int
_dll.openmc_get_nuclide.errcheck = _error_handler
_dll.openmc_get_nuclide_index.argtypes = [c_char_p, POINTER(c_int)]
_dll.openmc_get_nuclide_index.restype = c_int
_dll.openmc_get_nuclide_index.errcheck = _error_handler
_dll.openmc_load_nuclide.argtypes = [c_char_p]
_dll.openmc_load_nuclide.restype = c_int
_dll.openmc_load_nuclide.errcheck = _error_handler
@ -35,7 +36,7 @@ def load_nuclide(name):
_dll.openmc_load_nuclide(name.encode())
class NuclideView(object):
class NuclideView(_View):
"""View of a nuclide.
This class exposes a nuclide that is stored internally in the OpenMC
@ -61,9 +62,6 @@ class NuclideView(object):
cls.__instances[args] = instance
return cls.__instances[args]
def __init__(self, index):
self._index = index
@property
def name(self):
name = c_char_p()
@ -80,8 +78,8 @@ class _NuclideMapping(Mapping):
"""Provide mapping from nuclide name to index in nuclides array."""
def __getitem__(self, key):
index = c_int()
_dll.openmc_get_nuclide(key.encode(), index)
return NuclideView(index)
_dll.openmc_get_nuclide_index(key.encode(), index)
return NuclideView(index.value)
def __iter__(self):
for i in range(len(self)):
@ -90,4 +88,7 @@ class _NuclideMapping(Mapping):
def __len__(self):
return c_int.in_dll(_dll, 'n_nuclides').value
def __repr__(self):
return repr(dict(self))
nuclides = _NuclideMapping()

41
openmc/capi/settings.py Normal file
View file

@ -0,0 +1,41 @@
from ctypes import c_int, c_int32, c_int64, c_double, c_char_p, POINTER
from . import _dll
from .core import _DLLGlobal
from .error import _error_handler
_RUN_MODES = {1: 'fixed source',
2: 'eigenvalue',
3: 'plot',
4: 'particle restart',
5: 'volume'}
class _Settings(object):
# Attributes that are accessed through a descriptor
batches = _DLLGlobal(c_int32, 'n_batches')
generations_per_batch = _DLLGlobal(c_int32, 'gen_per_batch')
inactive = _DLLGlobal(c_int32, 'n_inactive')
particles = _DLLGlobal(c_int64, 'n_particles')
verbosity = _DLLGlobal(c_int, 'verbosity')
@property
def run_mode(self):
i = c_int.in_dll(_dll, 'run_mode').value
try:
return _RUN_MODES[i]
except KeyError:
return None
@run_mode.setter
def run_mode(self, mode):
current_idx = c_int.in_dll(_dll, 'run_mode')
for idx, mode_value in _RUN_MODES.items():
if mode_value == mode:
current_idx.value = idx
break
else:
raise ValueError('Invalid run mode: {}'.format(mode))
settings = _Settings()

83
openmc/capi/tally.py
View file

@ -5,18 +5,27 @@ from weakref import WeakValueDictionary
from numpy.ctypeslib import as_array
from . import _dll, NuclideView
from .core import _View
from .error import _error_handler
from .filter import _get_filter
__all__ = ['TallyView', 'tallies']
# Tally functions
_dll.openmc_get_tally.argtypes = [c_int32, POINTER(c_int32)]
_dll.openmc_get_tally.restype = c_int
_dll.openmc_get_tally.errcheck = _error_handler
_dll.openmc_get_tally_index.argtypes = [c_int32, POINTER(c_int32)]
_dll.openmc_get_tally_index.restype = c_int
_dll.openmc_get_tally_index.errcheck = _error_handler
_dll.openmc_extend_tallies.argtypes = [c_int32, POINTER(c_int32), POINTER(c_int32)]
_dll.openmc_extend_tallies.restype = c_int
_dll.openmc_extend_tallies.errcheck = _error_handler
_dll.openmc_tally_get_id.argtypes = [c_int32, POINTER(c_int32)]
_dll.openmc_tally_get_id.restype = c_int
_dll.openmc_tally_get_id.errcheck = _error_handler
_dll.openmc_tally_get_filters.argtypes = [
c_int32, POINTER(POINTER(c_int32)), POINTER(c_int)]
_dll.openmc_tally_get_filters.restype = c_int
_dll.openmc_tally_get_filters.errcheck = _error_handler
_dll.openmc_tally_get_nuclides.argtypes = [
c_int32, POINTER(POINTER(c_int)), POINTER(c_int)]
_dll.openmc_tally_get_nuclides.restype = c_int
@ -25,12 +34,24 @@ _dll.openmc_tally_results.argtypes = [
c_int32, POINTER(POINTER(c_double)), POINTER(c_int*3)]
_dll.openmc_tally_results.restype = c_int
_dll.openmc_tally_results.errcheck = _error_handler
_dll.openmc_tally_set_filters.argtypes = [c_int32, c_int, POINTER(c_int32)]
_dll.openmc_tally_set_filters.restype = c_int
_dll.openmc_tally_set_filters.errcheck = _error_handler
_dll.openmc_tally_set_id.argtypes = [c_int32, c_int32]
_dll.openmc_tally_set_id.restype = c_int
_dll.openmc_tally_set_id.errcheck = _error_handler
_dll.openmc_tally_set_nuclides.argtypes = [c_int32, c_int, POINTER(c_char_p)]
_dll.openmc_tally_set_nuclides.restype = c_int
_dll.openmc_tally_set_nuclides.errcheck = _error_handler
_dll.openmc_tally_set_scores.argtypes = [c_int32, c_int, POINTER(c_char_p)]
_dll.openmc_tally_set_scores.restype = c_int
_dll.openmc_tally_set_scores.errcheck = _error_handler
_dll.openmc_tally_set_type.argtypes = [c_int32, c_char_p]
_dll.openmc_tally_set_type.restype = c_int
_dll.openmc_tally_set_type.errcheck = _error_handler
class TallyView(object):
class TallyView(_View):
"""View of a tally.
This class exposes a tally that is stored internally in the OpenMC
@ -40,12 +61,14 @@ class TallyView(object):
Parameters
----------
index : int
Index in the `tallys` array.
Index in the `tallies` array.
Attributes
----------
id : int
ID of the tally
filters : list
List of views to tally filters
nuclides : list of str
List of nuclides to score results for
results : numpy.ndarray
@ -60,15 +83,23 @@ class TallyView(object):
cls.__instances[args] = instance
return cls.__instances[args]
def __init__(self, index):
self._index = index
@property
def id(self):
tally_id = c_int32()
_dll.openmc_tally_get_id(self._index, tally_id)
return tally_id.value
@id.setter
def id(self, tally_id):
_dll.openmc_tally_set_id(self._index, tally_id)
@property
def filters(self):
filt_idx = POINTER(c_int32)()
n = c_int()
_dll.openmc_tally_get_filters(self._index, filt_idx, n)
return [_get_filter(filt_idx[i]) for i in range(n.value)]
@property
def nuclides(self):
nucs = POINTER(c_int)()
@ -84,17 +115,48 @@ class TallyView(object):
_dll.openmc_tally_results(self._index, data, shape)
return as_array(data, tuple(shape[::-1]))
@filters.setter
def filters(self, filters):
# Get filter indices as int32_t[]
n = len(filters)
indices = (c_int32*n)(*(f._index for f in filters))
_dll.openmc_tally_set_filters(self._index, n, indices)
@nuclides.setter
def nuclides(self, nuclides):
nucs = (c_char_p * len(nuclides))()
nucs[:] = [x.encode() for x in nuclides]
_dll.openmc_tally_set_nuclides(self._index, len(nuclides), nucs)
@property
def scores(self):
pass
@scores.setter
def scores(self, scores):
scores_ = (c_char_p * len(scores))()
scores_[:] = [x.encode() for x in scores]
_dll.openmc_tally_set_scores(self._index, len(scores), scores_)
@classmethod
def new(cls, tally_id=None):
# Determine ID to assign
if tally_id is None:
tally_id = max(tallies) + 1
index = c_int32()
_dll.openmc_extend_tallies(1, index, None)
_dll.openmc_tally_set_type(index, b'generic')
tally = cls(index.value)
tally.id = tally_id
return tally
class _TallyMapping(Mapping):
def __getitem__(self, key):
index = c_int32()
_dll.openmc_get_tally(key, index)
_dll.openmc_get_tally_index(key, index)
return TallyView(index.value)
def __iter__(self):
@ -104,4 +166,7 @@ class _TallyMapping(Mapping):
def __len__(self):
return c_int32.in_dll(_dll, 'n_tallies').value
def __repr__(self):
return repr(dict(self))
tallies = _TallyMapping()

46
openmc/settings.py
View file

@ -958,20 +958,15 @@ class Settings(object):
subelement = ET.SubElement(element, "energy")
subelement.text = str(self._cutoff['energy'])
def _create_entropy_subelement(self, root):
if self._entropy_mesh is not None:
element = ET.SubElement(root, "entropy")
def _create_entropy_mesh_subelement(self, root):
if self.entropy_mesh is not None:
# See if a <mesh> element already exists -- if not, add it
path = "./mesh[@id='{}']".format(self.entropy_mesh.id)
if root.find(path) is None:
root.append(self.entropy_mesh.to_xml_element())
if self._entropy_mesh.dimension is not None:
subelement = ET.SubElement(element, "dimension")
subelement.text = ' '.join(
str(x) for x in self._entropy_mesh.dimension)
subelement = ET.SubElement(element, "lower_left")
subelement.text = ' '.join(
str(x) for x in self._entropy_mesh.lower_left)
subelement = ET.SubElement(element, "upper_right")
subelement.text = ' '.join(
str(x) for x in self._entropy_mesh.upper_right)
subelement = ET.SubElement(root, "entropy_mesh")
subelement.text = str(self.entropy_mesh.id)
def _create_trigger_subelement(self, root):
if self._trigger_active is not None:
@ -1028,18 +1023,15 @@ class Settings(object):
element = ET.SubElement(root, "track")
element.text = ' '.join(map(str, self._track))
def _create_ufs_subelement(self, root):
if self._ufs_mesh is not None:
element = ET.SubElement(root, "uniform_fs")
subelement = ET.SubElement(element, "dimension")
subelement.text = ' '.join(str(x) for x in
self._ufs_mesh.dimension)
subelement = ET.SubElement(element, "lower_left")
subelement.text = ' '.join(str(x) for x in
self._ufs_mesh.lower_left)
subelement = ET.SubElement(element, "upper_right")
subelement.text = ' '.join(str(x) for x in
self._ufs_mesh.upper_right)
def _create_ufs_mesh_subelement(self, root):
if self.ufs_mesh is not None:
# See if a <mesh> element already exists -- if not, add it
path = "./mesh[@id='{}']".format(self.ufs_mesh.id)
if root.find(path) is None:
root.append(self.ufs_mesh.to_xml_element())
subelement = ET.SubElement(root, "ufs_mesh")
subelement.text = str(self.ufs_mesh.id)
def _create_dd_subelement(self, root):
if self._dd_mesh_lower_left is not None and \
@ -1126,7 +1118,7 @@ class Settings(object):
self._create_seed_subelement(root_element)
self._create_survival_biasing_subelement(root_element)
self._create_cutoff_subelement(root_element)
self._create_entropy_subelement(root_element)
self._create_entropy_mesh_subelement(root_element)
self._create_trigger_subelement(root_element)
self._create_no_reduce_subelement(root_element)
self._create_threads_subelement(root_element)
@ -1135,7 +1127,7 @@ class Settings(object):
self._create_temperature_subelements(root_element)
self._create_trace_subelement(root_element)
self._create_track_subelement(root_element)
self._create_ufs_subelement(root_element)
self._create_ufs_mesh_subelement(root_element)
self._create_dd_subelement(root_element)
self._create_resonance_scattering_subelement(root_element)
self._create_volume_calcs_subelement(root_element)

11
openmc/statepoint.py
View file

@ -402,14 +402,6 @@ class StatePoint(object):
scores = group['score_bins'].value
n_score_bins = group['n_score_bins'].value
# Compute and set the filter strides
for i in range(n_filters):
tally_filter = tally.filters[i]
tally_filter.stride = n_score_bins * len(nuclide_names)
for j in range(i+1, n_filters):
tally_filter.stride *= tally.filters[j].num_bins
# Read scattering moment order strings (e.g., P3, Y1,2, etc.)
moments = group['moment_orders'].value
@ -423,6 +415,9 @@ class StatePoint(object):
tally.scores.append(score)
# Compute and set the filter strides
tally._update_filter_strides()
# Add Tally to the global dictionary of all Tallies
tally.sparse = self.sparse
self._tallies[tally_id] = tally

6
setup.py
View file

@ -30,13 +30,13 @@ with open('openmc/__init__.py', 'r') as f:
kwargs = {'name': 'openmc',
'version': version,
'packages': ['openmc', 'openmc.data', 'openmc.mgxs', 'openmc.model',
'openmc.stats'],
'packages': ['openmc', 'openmc.capi', 'openmc.data', 'openmc.mgxs',
'openmc.model', 'openmc.stats'],
'scripts': glob.glob('scripts/openmc-*'),
# Data files and librarries
'package_data': {
'openmc': ['_libopenmc.{}'.format(suffix)],
'openmc.capi': ['libopenmc.{}'.format(suffix)],
'openmc.data': ['mass.mas12', 'fission_Q_data_endfb71.h5']
},

734
src/api.F90
View file

@ -6,17 +6,27 @@ module openmc_api
use constants, only: K_BOLTZMANN
use eigenvalue, only: k_sum, openmc_get_keff
use error
use geometry, only: find_cell
use geometry_header, only: root_universe
use global
use geometry_header
use hdf5_interface
use material_header
use mesh_header
use message_passing
use nuclide_header
use initialize, only: openmc_init
use input_xml, only: assign_0K_elastic_scattering, check_data_version
use particle_header, only: Particle
use plot, only: openmc_plot_geometry
use random_lcg, only: seed, initialize_prng
use settings
use simulation_header
use tally_header
use tally_filter_header
use tally_filter
use tally, only: openmc_tally_set_type
use simulation, only: openmc_run
use string, only: to_f_string
use timer_header
use volume_calc, only: openmc_calculate_volumes
implicit none
@ -24,14 +34,26 @@ module openmc_api
private
public :: openmc_calculate_volumes
public :: openmc_cell_get_id
public :: openmc_cell_get_fill
public :: openmc_cell_set_fill
public :: openmc_cell_set_temperature
public :: openmc_energy_filter_get_bins
public :: openmc_energy_filter_set_bins
public :: openmc_extend_filters
public :: openmc_extend_materials
public :: openmc_extend_tallies
public :: openmc_filter_get_id
public :: openmc_filter_get_type
public :: openmc_filter_set_id
public :: openmc_filter_set_type
public :: openmc_finalize
public :: openmc_find
public :: openmc_get_cell
public :: openmc_get_cell_index
public :: openmc_get_keff
public :: openmc_get_material
public :: openmc_get_nuclide
public :: openmc_get_tally
public :: openmc_get_filter_index
public :: openmc_get_material_index
public :: openmc_get_nuclide_index
public :: openmc_get_tally_index
public :: openmc_hard_reset
public :: openmc_init
public :: openmc_load_nuclide
@ -40,147 +62,26 @@ module openmc_api
public :: openmc_material_get_densities
public :: openmc_material_set_density
public :: openmc_material_set_densities
public :: openmc_material_set_id
public :: openmc_material_filter_get_bins
public :: openmc_material_filter_set_bins
public :: openmc_mesh_filter_set_mesh
public :: openmc_nuclide_name
public :: openmc_plot_geometry
public :: openmc_reset
public :: openmc_run
public :: openmc_tally_get_id
public :: openmc_tally_get_filters
public :: openmc_tally_get_nuclides
public :: openmc_tally_results
public :: openmc_tally_set_filters
public :: openmc_tally_set_id
public :: openmc_tally_set_nuclides
! Error codes
integer(C_INT), public, bind(C) :: E_UNASSIGNED = -1
integer(C_INT), public, bind(C) :: E_OUT_OF_BOUNDS = -2
integer(C_INT), public, bind(C) :: E_CELL_NOT_ALLOCATED = -3
integer(C_INT), public, bind(C) :: E_CELL_INVALID_ID = -4
integer(C_INT), public, bind(C) :: E_CELL_NOT_FOUND = -5
integer(C_INT), public, bind(C) :: E_NUCLIDE_NOT_ALLOCATED = -6
integer(C_INT), public, bind(C) :: E_NUCLIDE_NOT_LOADED = -7
integer(C_INT), public, bind(C) :: E_NUCLIDE_NOT_IN_LIBRARY = -8
integer(C_INT), public, bind(C) :: E_MATERIAL_NOT_ALLOCATED = -9
integer(C_INT), public, bind(C) :: E_MATERIAL_INVALID_ID = -10
integer(C_INT), public, bind(C) :: E_TALLY_NOT_ALLOCATED = -11
integer(C_INT), public, bind(C) :: E_TALLY_INVALID_ID = -12
integer(C_INT), public, bind(C) :: E_INVALID_SIZE = -13
integer(C_INT), public, bind(C) :: E_CELL_NO_MATERIAL = -14
! Warning codes
integer(C_INT), public, bind(C) :: W_BELOW_MIN_BOUND = 1
integer(C_INT), public, bind(C) :: W_ABOVE_MAX_BOUND = 2
public :: openmc_tally_set_scores
public :: openmc_tally_set_type
contains
!===============================================================================
! OPENMC_CELL_GET_ID returns the ID of a cell
!===============================================================================
function openmc_cell_get_id(index, id) result(err) bind(C)
integer(C_INT32_T), value :: index
integer(C_INT32_T), intent(out) :: id
integer(C_INT) :: err
if (index >= 1 .and. index <= size(cells)) then
id = cells(index) % id
err = 0
else
err = E_OUT_OF_BOUNDS
end if
end function openmc_cell_get_id
!===============================================================================
! OPENMC_CELL_SET_TEMPERATURE sets the temperature of a cell
!===============================================================================
function openmc_cell_set_temperature(index, T, instance) result(err) bind(C)
integer(C_INT32_T), value, intent(in) :: index ! cell index in cells
real(C_DOUBLE), value, intent(in) :: T ! temperature
integer(C_INT32_T), optional, intent(in) :: instance ! cell instance
integer(C_INT) :: err ! error code
integer :: j ! looping variable
integer :: n ! number of cell instances
integer :: material_index ! material index in materials array
integer :: num_nuclides ! num nuclides in material
integer :: nuclide_index ! index of nuclide in nuclides array
real(8) :: min_temp ! min common-denominator avail temp
real(8) :: max_temp ! max common-denominator avail temp
real(8) :: temp ! actual temp we'll assign
logical :: outside_low ! lower than available data
logical :: outside_high ! higher than available data
outside_low = .false.
outside_high = .false.
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(cells)) then
! error if the cell is filled with another universe
if (cells(index) % fill /= NONE) then
err = E_CELL_NO_MATERIAL
else
! find which material is associated with this cell (material_index
! is the index into the materials array)
if (present(instance)) then
material_index = cells(index) % material(instance)
else
material_index = cells(index) % material(1)
end if
! number of nuclides associated with this material
num_nuclides = size(materials(material_index) % nuclide)
min_temp = ZERO
max_temp = INFINITY
do j = 1, num_nuclides
nuclide_index = materials(material_index) % nuclide(j)
min_temp = max(min_temp, minval(nuclides(nuclide_index) % kTs))
max_temp = min(max_temp, maxval(nuclides(nuclide_index) % kTs))
end do
! adjust the temperature to be within bounds if necessary
if (K_BOLTZMANN * T < min_temp) then
outside_low = .true.
temp = min_temp / K_BOLTZMANN
else if (K_BOLTZMANN * T > max_temp) then
outside_high = .true.
temp = max_temp / K_BOLTZMANN
else
temp = T
end if
associate (c => cells(index))
if (allocated(c % sqrtkT)) then
n = size(c % sqrtkT)
if (present(instance) .and. n > 1) then
if (instance >= 0 .and. instance < n) then
c % sqrtkT(instance + 1) = sqrt(K_BOLTZMANN * temp)
err = 0
end if
else
c % sqrtkT(:) = sqrt(K_BOLTZMANN * temp)
err = 0
end if
end if
end associate
! Assign error codes for outside of temperature bounds provided the
! temperature was changed correctly. This needs to be done after
! changing the temperature based on the logical structure above.
if (err == 0) then
if (outside_low) err = W_BELOW_MIN_BOUND
if (outside_high) err = W_ABOVE_MAX_BOUND
end if
end if
else
err = E_OUT_OF_BOUNDS
end if
end function openmc_cell_set_temperature
!===============================================================================
! OPENMC_FINALIZE frees up memory by deallocating arrays and resetting global
! variables
@ -203,21 +104,14 @@ contains
energy_min_neutron = ZERO
entropy_on = .false.
gen_per_batch = 1
i_user_tallies = -1
i_cmfd_tallies = -1
keff = ONE
legendre_to_tabular = .true.
legendre_to_tabular_points = 33
n_batch_interval = 1
n_filters = 0
n_meshes = 0
n_particles = 0
n_source_points = 0
n_state_points = 0
n_tallies = 0
n_user_filters = 0
n_user_meshes = 0
n_user_tallies = 0
output_summary = .true.
output_tallies = .true.
particle_restart_run = .false.
@ -304,103 +198,14 @@ contains
instance = p % cell_instance - 1
err = 0
else
err = E_CELL_NOT_FOUND
err = E_GEOMETRY
call set_errmsg("Could not find cell/material at position (" // &
trim(to_str(xyz(1))) // "," // trim(to_str(xyz(2))) // "," // &
trim(to_str(xyz(3))) // ").")
end if
end function openmc_find
!===============================================================================
! OPENMC_GET_CELL returns the index in the cells array of a cell with a given ID
!===============================================================================
function openmc_get_cell(id, index) result(err) bind(C)
integer(C_INT32_T), value :: id
integer(C_INT32_T), intent(out) :: index
integer(C_INT) :: err
if (allocated(cells)) then
if (cell_dict % has_key(id)) then
index = cell_dict % get_key(id)
err = 0
else
err = E_CELL_INVALID_ID
end if
else
err = E_CELL_NOT_ALLOCATED
end if
end function openmc_get_cell
!===============================================================================
! OPENMC_GET_MATERIAL returns the index in the materials array of a material
! with a given ID
!===============================================================================
function openmc_get_material(id, index) result(err) bind(C)
integer(C_INT32_T), value :: id
integer(C_INT32_T), intent(out) :: index
integer(C_INT) :: err
if (allocated(materials)) then
if (material_dict % has_key(id)) then
index = material_dict % get_key(id)
err = 0
else
err = E_MATERIAL_INVALID_ID
end if
else
err = E_MATERIAL_NOT_ALLOCATED
end if
end function openmc_get_material
!===============================================================================
! OPENMC_GET_NUCLIDE returns the index in the nuclides array of a nuclide
! with a given name
!===============================================================================
function openmc_get_nuclide(name, index) result(err) bind(C)
character(kind=C_CHAR), intent(in) :: name(*)
integer(C_INT), intent(out) :: index
integer(C_INT) :: err
character(:), allocatable :: name_
! Copy array of C_CHARs to normal Fortran string
name_ = to_f_string(name)
if (allocated(nuclides)) then
if (nuclide_dict % has_key(to_lower(name_))) then
index = nuclide_dict % get_key(to_lower(name_))
err = 0
else
err = E_NUCLIDE_NOT_LOADED
end if
else
err = E_NUCLIDE_NOT_ALLOCATED
end if
end function openmc_get_nuclide
!===============================================================================
! OPENMC_GET_TALLY returns the index in the tallies array of a tally
! with a given ID
!===============================================================================
function openmc_get_tally(id, index) result(err) bind(C)
integer(C_INT32_T), value :: id
integer(C_INT32_T), intent(out) :: index
integer(C_INT) :: err
if (allocated(tallies)) then
if (tally_dict % has_key(id)) then
index = tally_dict % get_key(id)
err = 0
else
err = E_TALLY_INVALID_ID
end if
else
err = E_TALLY_NOT_ALLOCATED
end if
end function openmc_get_tally
!===============================================================================
! OPENMC_HARD_RESET reset tallies and timers as well as the pseudorandom
! generator state
@ -419,278 +224,6 @@ contains
call initialize_prng()
end subroutine openmc_hard_reset
!===============================================================================
! OPENMC_LOAD_NUCLIDE loads a nuclide from the cross section library
!===============================================================================
function openmc_load_nuclide(name) result(err) bind(C)
character(kind=C_CHAR), intent(in) :: name(*)
integer(C_INT) :: err
integer :: i_library
integer :: n
integer(HID_T) :: file_id
integer(HID_T) :: group_id
character(:), allocatable :: name_
real(8) :: minmax(2) = [ZERO, INFINITY]
type(VectorReal) :: temperature
type(Nuclide), allocatable :: new_nuclides(:)
! Copy array of C_CHARs to normal Fortran string
name_ = to_f_string(name)
err = 0
if (.not. nuclide_dict % has_key(to_lower(name_))) then
if (library_dict % has_key(to_lower(name_))) then
! allocate extra space in nuclides array
n = n_nuclides_total
allocate(new_nuclides(n + 1))
new_nuclides(1:n) = nuclides(:)
call move_alloc(FROM=new_nuclides, TO=nuclides)
n = n + 1
i_library = library_dict % get_key(to_lower(name_))
! Open file and make sure version is sufficient
file_id = file_open(libraries(i_library) % path, 'r')
call check_data_version(file_id)
! Read nuclide data from HDF5
group_id = open_group(file_id, name_)
call nuclides(n) % from_hdf5(group_id, temperature, &
temperature_method, temperature_tolerance, minmax, &
master)
call close_group(group_id)
call file_close(file_id)
! Add entry to nuclide dictionary
call nuclide_dict % add_key(to_lower(name_), n)
n_nuclides_total = n
! Assign resonant scattering data
if (res_scat_on) call assign_0K_elastic_scattering(nuclides(n))
! Initialize nuclide grid
call nuclides(n) % init_grid(energy_min_neutron, &
energy_max_neutron, n_log_bins)
else
err = E_NUCLIDE_NOT_IN_LIBRARY
end if
end if
end function openmc_load_nuclide
!===============================================================================
! OPENMC_MATERIAL_ADD_NUCLIDE
!===============================================================================
function openmc_material_add_nuclide(index, name, density) result(err) bind(C)
integer(C_INT32_T), value, intent(in) :: index
character(kind=C_CHAR) :: name(*)
real(C_DOUBLE), value, intent(in) :: density
integer(C_INT) :: err
integer :: j, k, n
real(8) :: awr
integer, allocatable :: new_nuclide(:)
real(8), allocatable :: new_density(:)
character(:), allocatable :: name_
name_ = to_f_string(name)
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(materials)) then
associate (m => materials(index))
! Check if nuclide is already in material
do j = 1, size(m % nuclide)
k = m % nuclide(j)
if (nuclides(k) % name == name_) then
awr = nuclides(k) % awr
m % density = m % density + density - m % atom_density(j)
m % density_gpcc = m % density_gpcc + (density - &
m % atom_density(j)) * awr * MASS_NEUTRON / N_AVOGADRO
m % atom_density(j) = density
err = 0
end if
end do
! If nuclide wasn't found, extend nuclide/density arrays
if (err /= 0) then
! If nuclide hasn't been loaded, load it now
err = openmc_load_nuclide(name)
if (err == 0) then
! Extend arrays
n = size(m % nuclide)
allocate(new_nuclide(n + 1))
new_nuclide(1:n) = m % nuclide
call move_alloc(FROM=new_nuclide, TO=m % nuclide)
allocate(new_density(n + 1))
new_density(1:n) = m % atom_density
call move_alloc(FROM=new_density, TO=m % atom_density)
! Append new nuclide/density
k = nuclide_dict % get_key(to_lower(name_))
m % nuclide(n + 1) = k
m % atom_density(n + 1) = density
m % density = m % density + density
m % density_gpcc = m % density_gpcc + &
density * nuclides(k) % awr * MASS_NEUTRON / N_AVOGADRO
m % n_nuclides = n + 1
end if
end if
end associate
else
err = E_OUT_OF_BOUNDS
end if
end function openmc_material_add_nuclide
!===============================================================================
! OPENMC_MATERIAL_GET_DENSITIES returns an array of nuclide densities in a
! material
!===============================================================================
function openmc_material_get_densities(index, nuclides, densities, n) &
result(err) bind(C)
integer(C_INT32_T), value :: index
type(C_PTR), intent(out) :: nuclides
type(C_PTR), intent(out) :: densities
integer(C_INT), intent(out) :: n
integer(C_INT) :: err
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(materials)) then
associate (m => materials(index))
if (allocated(m % atom_density)) then
nuclides = C_LOC(m % nuclide(1))
densities = C_LOC(m % atom_density(1))
n = size(m % atom_density)
err = 0
end if
end associate
else
err = E_OUT_OF_BOUNDS
end if
end function openmc_material_get_densities
!===============================================================================
! OPENMC_MATERIAL_GET_ID returns the ID of a material
!===============================================================================
function openmc_material_get_id(index, id) result(err) bind(C)
integer(C_INT32_T), value :: index
integer(C_INT32_T), intent(out) :: id
integer(C_INT) :: err
if (index >= 1 .and. index <= size(materials)) then
id = materials(index) % id
err = 0
else
err = E_OUT_OF_BOUNDS
end if
end function openmc_material_get_id
!===============================================================================
! OPENMC_MATERIAL_SET_DENSITY sets the total density of a material in atom/b-cm
!===============================================================================
function openmc_material_set_density(index, density) result(err) bind(C)
integer(C_INT32_T), value, intent(in) :: index
real(C_DOUBLE), value, intent(in) :: density
integer(C_INT) :: err
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(materials)) then
associate (m => materials(index))
err = m % set_density(density, nuclides)
end associate
else
err = E_OUT_OF_BOUNDS
end if
end function openmc_material_set_density
!===============================================================================
! OPENMC_MATERIAL_SET_DENSITIES sets the densities for a list of nuclides in a
! material. If the nuclides don't already exist in the material, they will be
! added
!===============================================================================
function openmc_material_set_densities(index, n, name, density) result(err) bind(C)
integer(C_INT32_T), value, intent(in) :: index
integer(C_INT), value, intent(in) :: n
type(C_PTR), intent(in) :: name(n)
real(C_DOUBLE), intent(in) :: density(n)
integer(C_INT) :: err
integer :: i
character(C_CHAR), pointer :: string(:)
character(len=:, kind=C_CHAR), allocatable :: name_
if (index >= 1 .and. index <= size(materials)) then
associate (m => materials(index))
! If nuclide/density arrays are not correct size, reallocate
if (n /= size(m % nuclide)) then
deallocate(m % nuclide, m % atom_density, m % p0)
allocate(m % nuclide(n), m % atom_density(n), m % p0(n))
end if
do i = 1, n
! Convert C string to Fortran string
call c_f_pointer(name(i), string, [10])
name_ = to_lower(to_f_string(string))
if (.not. nuclide_dict % has_key(name_)) then
err = openmc_load_nuclide(string)
if (err < 0) return
end if
m % nuclide(i) = nuclide_dict % get_key(name_)
m % atom_density(i) = density(i)
end do
m % n_nuclides = n
! Set isotropic flags to flags
m % p0(:) = .false.
! Set total density to the sum of the vector
err = m % set_density(sum(density), nuclides)
! Assign S(a,b) tables
call m % assign_sab_tables(nuclides, sab_tables)
end associate
else
err = E_OUT_OF_BOUNDS
end if
end function openmc_material_set_densities
!===============================================================================
! OPENMC_NUCLIDE_NAME returns the name of a nuclide with a given index
!===============================================================================
function openmc_nuclide_name(index, name) result(err) bind(C)
integer(C_INT), value, intent(in) :: index
type(c_ptr), intent(out) :: name
integer(C_INT) :: err
character(C_CHAR), pointer :: name_
err = E_UNASSIGNED
if (allocated(nuclides)) then
if (index >= 1 .and. index <= size(nuclides)) then
name_ => nuclides(index) % name(1:1)
name = C_LOC(name_)
err = 0
else
err = E_OUT_OF_BOUNDS
end if
else
err = E_NUCLIDE_NOT_ALLOCATED
end if
end function openmc_nuclide_name
!===============================================================================
! OPENMC_RESET resets tallies and timers
!===============================================================================
@ -700,10 +233,13 @@ contains
if (allocated(tallies)) then
do i = 1, size(tallies)
tallies(i) % n_realizations = 0
if (allocated(tallies(i) % results)) then
tallies(i) % results(:, :, :) = ZERO
end if
associate (t => tallies(i) % obj)
t % active = .false.
t % n_realizations = 0
if (allocated(t % results)) then
t % results(:, :, :) = ZERO
end if
end associate
end do
end if
@ -717,10 +253,6 @@ contains
k_abs_tra = ZERO
k_sum(:) = ZERO
! Turn off tally flags
tallies_on = .false.
active_batches = .false.
! Clear active tally lists
call active_analog_tallies % clear()
call active_tracklength_tallies % clear()
@ -746,147 +278,43 @@ contains
end subroutine openmc_reset
!===============================================================================
! OPENMC_TALLY_GET_ID returns the ID of a tally
! FREE_MEMORY deallocates and clears all global allocatable arrays in the
! program
!===============================================================================
function openmc_tally_get_id(index, id) result(err) bind(C)
integer(C_INT32_T), value :: index
integer(C_INT32_T), intent(out) :: id
integer(C_INT) :: err
subroutine free_memory()
if (index >= 1 .and. index <= size(tallies)) then
id = tallies(index) % id
err = 0
else
err = E_OUT_OF_BOUNDS
end if
end function openmc_tally_get_id
use cmfd_header
use mgxs_header
use plot_header
use sab_header
use settings
use source_header
use surface_header
use tally_derivative_header
use trigger_header
use volume_header
!===============================================================================
! OPENMC_TALLY_NUCLIDES returns the list of nuclides assigned to a tally
!===============================================================================
call free_memory_geometry()
call free_memory_surfaces()
call free_memory_material()
call free_memory_plot()
call free_memory_volume()
call free_memory_simulation()
call free_memory_nuclide()
call free_memory_settings()
call free_memory_mgxs()
call free_memory_sab()
call free_memory_source()
call free_memory_mesh()
call free_memory_tally()
call free_memory_tally_filter()
call free_memory_tally_derivative()
call free_memory_bank()
function openmc_tally_get_nuclides(index, nuclides, n) result(err) bind(C)
integer(C_INT32_T), value :: index
type(C_PTR), intent(out) :: nuclides
integer(C_INT), intent(out) :: n
integer(C_INT) :: err
! Deallocate CMFD
call deallocate_cmfd(cmfd)
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(tallies)) then
associate (t => tallies(index))
if (allocated(t % nuclide_bins)) then
nuclides = C_LOC(t % nuclide_bins(1))
n = size(t % nuclide_bins)
err = 0
end if
end associate
else
err = E_OUT_OF_BOUNDS
end if
end function openmc_tally_get_nuclides
!===============================================================================
! OPENMC_TALLY_RESULTS returns a pointer to a tally results array along with its
! shape. This allows a user to obtain in-memory tally results from Python
! directly.
!===============================================================================
function openmc_tally_results(index, ptr, shape_) result(err) bind(C)
integer(C_INT32_T), intent(in), value :: index
type(C_PTR), intent(out) :: ptr
integer(C_INT), intent(out) :: shape_(3)
integer(C_INT) :: err
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(tallies)) then
if (allocated(tallies(index) % results)) then
ptr = C_LOC(tallies(index) % results(1,1,1))
shape_(:) = shape(tallies(index) % results)
err = 0
end if
else
err = E_OUT_OF_BOUNDS
end if
end function openmc_tally_results
!===============================================================================
! OPENMC_TALLY_SET_NUCLIDES sets the nuclides in the tally which results should
! be scored for
!===============================================================================
function openmc_tally_set_nuclides(index, n, nuclides) result(err) bind(C)
integer(C_INT32_T), value :: index
integer(C_INT), value :: n
type(C_PTR), intent(in) :: nuclides(n)
integer(C_INT) :: err
integer :: i
character(C_CHAR), pointer :: string(:)
character(len=:, kind=C_CHAR), allocatable :: nuclide_
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(tallies)) then
associate (t => tallies(index))
if (allocated(t % nuclide_bins)) deallocate(t % nuclide_bins)
allocate(t % nuclide_bins(n))
t % n_nuclide_bins = n
do i = 1, n
! Convert C string to Fortran string
call c_f_pointer(nuclides(i), string, [10])
nuclide_ = to_lower(to_f_string(string))
select case (nuclide_)
case ('total')
t % nuclide_bins(i) = -1
case default
if (nuclide_dict % has_key(nuclide_)) then
t % nuclide_bins(i) = nuclide_dict % get_key(nuclide_)
else
err = E_NUCLIDE_NOT_LOADED
return
end if
end select
end do
! Recalculate total number of scoring bins
t % total_score_bins = t % n_score_bins * t % n_nuclide_bins
! (Re)allocate results array
if (allocated(t % results)) deallocate(t % results)
allocate(t % results(3, t % total_score_bins, t % total_filter_bins))
t % results(:,:,:) = ZERO
err = 0
end associate
else
err = E_OUT_OF_BOUNDS
end if
end function openmc_tally_set_nuclides
!===============================================================================
! TO_F_STRING takes a null-terminated array of C chars and turns it into a
! deferred-length character string. Yay Fortran 2003!
!===============================================================================
function to_f_string(c_string) result(f_string)
character(kind=C_CHAR), intent(in) :: c_string(*)
character(:), allocatable :: f_string
integer :: i, n
! Determine length of original string
n = 0
do while (c_string(n + 1) /= C_NULL_CHAR)
n = n + 1
end do
! Copy C string character by character
allocate(character(len=n) :: f_string)
do i = 1, n
f_string(i:i) = c_string(i)
end do
end function to_f_string
end subroutine free_memory
end module openmc_api

30
src/bank_header.F90
View file

@ -18,4 +18,34 @@ module bank_header
integer(C_INT) :: delayed_group ! delayed group
end type Bank
! Source and fission bank
type(Bank), allocatable, target :: source_bank(:)
type(Bank), allocatable, target :: fission_bank(:)
#ifdef _OPENMP
type(Bank), allocatable, target :: master_fission_bank(:)
#endif
integer(8) :: n_bank ! # of sites in fission bank
!$omp threadprivate(fission_bank, n_bank)
contains
!===============================================================================
! FREE_MEMORY_BANK deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_bank()
! Deallocate fission and source bank and entropy
!$omp parallel
if (allocated(fission_bank)) deallocate(fission_bank)
!$omp end parallel
#ifdef _OPENMP
if (allocated(master_fission_bank)) deallocate(master_fission_bank)
#endif
if (allocated(source_bank)) deallocate(source_bank)
end subroutine free_memory_bank
end module bank_header

46
src/cmfd_data.F90
View file

@ -5,8 +5,10 @@ module cmfd_data
! parameters for CMFD calculation.
!==============================================================================
use cmfd_header, only: allocate_cmfd, cmfd, cmfd_coremap, &
cmfd_downscatter, cmfd_tallies, dhat_reset
use constants
use tally_filter, only: MeshFilter
use tally_filter_mesh, only: MeshFilter
implicit none
private
@ -20,9 +22,7 @@ contains
subroutine set_up_cmfd()
use cmfd_header, only: allocate_cmfd
use constants, only: CMFD_NOACCEL
use global, only: cmfd, cmfd_coremap, cmfd_downscatter
! Check for core map and set it up
if ((cmfd_coremap) .and. (cmfd%mat_dim == CMFD_NOACCEL)) call set_coremap()
@ -56,12 +56,9 @@ contains
IN_BACK, IN_FRONT, IN_BOTTOM, IN_TOP, CMFD_NOACCEL, &
ZERO, ONE, TINY_BIT
use error, only: fatal_error
use global, only: cmfd, n_cmfd_tallies, cmfd_tallies, meshes, &
filters, filter_matches
use mesh, only: mesh_indices_to_bin
use mesh_header, only: RegularMesh
use mesh_header, only: RegularMesh, meshes
use string, only: to_str
use tally_header, only: TallyObject
use tally_filter_header, only: filters, filter_matches
integer :: nx ! number of mesh cells in x direction
integer :: ny ! number of mesh cells in y direction
@ -76,7 +73,6 @@ contains
integer :: ital ! tally object index
integer :: ijk(3) ! indices for mesh cell
integer :: score_index ! index to pull from tally object
integer :: i_mesh ! index in meshes array
integer :: i_filt ! index in filters array
integer :: i_filter_mesh ! index for mesh filter
integer :: i_filter_ein ! index for incoming energy filter
@ -85,7 +81,6 @@ contains
integer :: stride_surf ! stride for surface filter
logical :: energy_filters! energy filters present
real(8) :: flux ! temp variable for flux
type(TallyObject), pointer :: t ! pointer for tally object
type(RegularMesh), pointer :: m ! pointer for mesh object
! Extract spatial and energy indices from object
@ -99,13 +94,14 @@ contains
cmfd % openmc_src = ZERO
! Associate tallies and mesh
t => cmfd_tallies(1)
i_filt = t % filter(t % find_filter(FILTER_MESH))
associate (t => cmfd_tallies(1) % obj)
i_filt = t % filter(t % find_filter(FILTER_MESH))
end associate
select type(filt => filters(i_filt) % obj)
type is (MeshFilter)
i_mesh = filt % mesh
m => meshes(filt % mesh)
end select
m => meshes(i_mesh)
! Set mesh widths
cmfd % hxyz(1,:,:,:) = m % width(1) ! set x width
@ -115,16 +111,15 @@ contains
cmfd % keff_bal = ZERO
! Begin loop around tallies
TAL: do ital = 1, n_cmfd_tallies
TAL: do ital = 1, size(cmfd_tallies)
! Associate tallies and mesh
t => cmfd_tallies(ital)
associate (t => cmfd_tallies(ital) % obj)
i_filt = t % filter(t % find_filter(FILTER_MESH))
select type(filt => filters(i_filt) % obj)
type is (MeshFilter)
i_mesh = filt % mesh
m => meshes(filt % mesh)
end select
m => meshes(i_mesh)
! Check for energy filters
energy_filters = (t % find_filter(FILTER_ENERGYIN) > 0)
@ -166,7 +161,7 @@ contains
! Get bin number for mesh indices
filter_matches(i_filter_mesh) % bins % data(1) = &
mesh_indices_to_bin(m,ijk)
m % get_bin_from_indices(ijk)
! Apply energy in filter
if (energy_filters) then
@ -217,7 +212,7 @@ contains
! Get bin number for mesh indices
filter_matches(i_filter_mesh) % bins % data(1) = &
mesh_indices_to_bin(m,ijk)
m % get_bin_from_indices(ijk)
if (energy_filters) then
! Apply energy in filter
@ -266,7 +261,7 @@ contains
! Get the bin for this mesh cell
filter_matches(i_filter_mesh) % bins % data(1) = &
mesh_indices_to_bin(m, (/ i, j, k /))
m % get_bin_from_indices([ i, j, k ])
score_index = 1
do l = 1, size(t % filter)
@ -321,13 +316,13 @@ contains
end do ZLOOP
end associate
end do TAL
! Normalize openmc source distribution
cmfd % openmc_src = cmfd % openmc_src/sum(cmfd % openmc_src)*cmfd%norm
! Nullify all pointers
if (associated(t)) nullify(t)
if (associated(m)) nullify(m)
end subroutine compute_xs
@ -339,7 +334,6 @@ contains
subroutine set_coremap()
use constants, only: CMFD_NOACCEL
use global, only: cmfd
integer :: counter=1 ! counter for unique fuel assemblies
integer :: nx ! number of mesh cells in x direction
@ -400,7 +394,7 @@ contains
subroutine neutron_balance()
use constants, only: ONE, ZERO, CMFD_NOACCEL, CMFD_NORES
use global, only: cmfd, keff, current_batch
use simulation_header, only: keff, current_batch
integer :: nx ! number of mesh cells in x direction
integer :: ny ! number of mesh cells in y direction
@ -509,7 +503,6 @@ contains
subroutine compute_dtilde()
use constants, only: CMFD_NOACCEL, ZERO_FLUX, TINY_BIT
use global, only: cmfd, cmfd_coremap
integer :: nx ! maximum number of cells in x direction
integer :: ny ! maximum number of cells in y direction
@ -651,7 +644,6 @@ contains
subroutine compute_dhat()
use constants, only: CMFD_NOACCEL, ZERO
use global, only: cmfd, cmfd_coremap, dhat_reset
use output, only: write_message
use string, only: to_str
@ -801,7 +793,6 @@ contains
function get_reflector_albedo(l, g, i, j, k)
use constants, only: ONE
use global, only: cmfd
real(8) :: get_reflector_albedo ! reflector albedo
integer, intent(in) :: i ! iteration counter for x
@ -840,7 +831,6 @@ contains
subroutine compute_effective_downscatter()
use constants, only: ZERO, CMFD_NOACCEL
use global, only: cmfd
integer :: nx ! number of mesh cells in x direction
integer :: ny ! number of mesh cells in y direction

58
src/cmfd_execute.F90
View file

@ -5,7 +5,9 @@ module cmfd_execute
! cross section generation, diffusion calculation, and source re-weighting
!==============================================================================
use global
use cmfd_header
use settings
use simulation_header
implicit none
private
@ -63,10 +65,6 @@ contains
subroutine cmfd_init_batch()
use global, only: cmfd_begin, cmfd_on, &
cmfd_reset, cmfd_run, &
current_batch
! Check to activate CMFD diffusion and possible feedback
! this guarantees that when cmfd begins at least one batch of tallies are
! accumulated
@ -91,7 +89,6 @@ contains
subroutine calc_fission_source()
use constants, only: CMFD_NOACCEL, ZERO, TWO
use global, only: cmfd, cmfd_coremap, entropy_on, current_batch
use message_passing
use string, only: to_str
@ -214,11 +211,11 @@ contains
subroutine cmfd_reweight(new_weights)
use algorithm, only: binary_search
use bank_header, only: source_bank
use constants, only: ZERO, ONE
use error, only: warning, fatal_error
use global, only: meshes, source_bank, work, n_user_meshes, cmfd
use mesh_header, only: RegularMesh
use mesh, only: count_bank_sites, get_mesh_indices
use mesh, only: count_bank_sites
use message_passing
use string, only: to_str
@ -229,19 +226,18 @@ contains
integer :: nz ! maximum number of cells in z direction
integer :: ng ! maximum number of energy groups
integer :: i ! iteration counter
integer :: g ! index for group
integer :: ijk(3) ! spatial bin location
integer :: e_bin ! energy bin of source particle
integer :: mesh_bin ! mesh bin of soruce particle
integer :: n_groups ! number of energy groups
real(8) :: norm ! normalization factor
logical :: outside ! any source sites outside mesh
logical :: in_mesh ! source site is inside mesh
type(RegularMesh), pointer :: m ! point to mesh
#ifdef MPI
integer :: mpi_err
#endif
! Associate pointer
m => meshes(n_user_meshes + 1)
! Get maximum of spatial and group indices
nx = cmfd % indices(1)
ny = cmfd % indices(2)
@ -250,7 +246,7 @@ contains
! allocate arrays in cmfd object (can take out later extend to multigroup)
if (.not.allocated(cmfd%sourcecounts)) then
allocate(cmfd%sourcecounts(ng,nx,ny,nz))
allocate(cmfd%sourcecounts(ng, nx*ny*nz))
cmfd % sourcecounts = 0
end if
if (.not.allocated(cmfd % weightfactors)) then
@ -265,9 +261,8 @@ contains
cmfd%weightfactors = ONE
! Count bank sites in mesh and reverse due to egrid structure
call count_bank_sites(m, source_bank, cmfd%sourcecounts, cmfd % egrid, &
sites_outside=outside, size_bank=work)
cmfd % sourcecounts = cmfd%sourcecounts(ng:1:-1,:,:,:)
call count_bank_sites(cmfd_mesh, source_bank, cmfd%sourcecounts, &
cmfd % egrid, sites_outside=outside, size_bank=work)
! Check for sites outside of the mesh
if (master .and. outside) then
@ -276,10 +271,21 @@ contains
! Have master compute weight factors (watch for 0s)
if (master) then
where(cmfd % cmfd_src > ZERO .and. cmfd % sourcecounts > ZERO)
cmfd % weightfactors = cmfd % cmfd_src/sum(cmfd % cmfd_src)* &
sum(cmfd % sourcecounts) / cmfd % sourcecounts
end where
! Calculate normalization factor
norm = sum(cmfd % sourcecounts) / sum(cmfd % cmfd_src)
do mesh_bin = 1, nx*ny*nz
call cmfd_mesh % get_indices_from_bin(mesh_bin, ijk)
do g = 1, ng
if (cmfd % sourcecounts(ng - g + 1, mesh_bin) > ZERO) then
if (cmfd % cmfd_src(g,ijk(1),ijk(2),ijk(3)) > ZERO) then
cmfd % weightfactors(g,ijk(1),ijk(2),ijk(3)) = &
cmfd % cmfd_src(g,ijk(1),ijk(2),ijk(3)) * norm &
/ cmfd % sourcecounts(ng - g + 1, mesh_bin)
end if
end if
end do
end do
end if
if (.not. cmfd_feedback) return
@ -295,7 +301,7 @@ contains
do i = 1, int(work,4)
! Determine spatial bin
call get_mesh_indices(m, source_bank(i) % xyz, ijk, in_mesh)
call cmfd_mesh % get_indices(source_bank(i) % xyz, ijk, in_mesh)
! Determine energy bin
n_groups = size(cmfd % egrid) - 1
@ -319,8 +325,7 @@ contains
! Reweight particle
source_bank(i) % wgt = source_bank(i) % wgt * &
cmfd % weightfactors(e_bin, ijk(1), ijk(2), ijk(3))
cmfd % weightfactors(e_bin, ijk(1), ijk(2), ijk(3))
end do
end subroutine cmfd_reweight
@ -331,8 +336,6 @@ contains
function get_matrix_idx(g, i, j, k, ng, nx, ny) result (matidx)
use global, only: cmfd, cmfd_coremap
integer :: matidx ! the index location in matrix
integer, intent(in) :: i ! current x index
integer, intent(in) :: j ! current y index
@ -363,7 +366,6 @@ contains
subroutine cmfd_tally_reset()
use global, only: cmfd_tallies
use output, only: write_message
integer :: i ! loop counter
@ -373,8 +375,8 @@ contains
! Reset CMFD tallies
do i = 1, size(cmfd_tallies)
cmfd_tallies(i) % n_realizations = 0
cmfd_tallies(i) % results(:,:,:) = ZERO
cmfd_tallies(i) % obj % n_realizations = 0
cmfd_tallies(i) % obj % results(:,:,:) = ZERO
end do
end subroutine cmfd_tally_reset

69
src/cmfd_header.F90
View file

@ -1,6 +1,10 @@
module cmfd_header
use constants, only: CMFD_NOACCEL, ZERO, ONE
use mesh_header, only: RegularMesh
use set_header, only: SetInt
use tally_header, only: TallyContainer
use timer_header, only: Timer
implicit none
private
@ -49,7 +53,7 @@ module cmfd_header
real(8), allocatable :: openmc_src(:,:,:,:)
! Source sites in each mesh box
real(8), allocatable :: sourcecounts(:,:,:,:)
real(8), allocatable :: sourcecounts(:,:)
! Weight adjustment factors
real(8), allocatable :: weightfactors(:,:,:,:)
@ -88,6 +92,67 @@ module cmfd_header
end type cmfd_type
! Main object
type(cmfd_type), public :: cmfd
type(RegularMesh), public, pointer :: cmfd_mesh => null()
! Pointers for different tallies
type(TallyContainer), public, pointer :: cmfd_tallies(:) => null()
! Timing objects
type(Timer), public :: time_cmfd ! timer for whole cmfd calculation
type(Timer), public :: time_cmfdbuild ! timer for matrix build
type(Timer), public :: time_cmfdsolve ! timer for solver
! Flag for active core map
logical, public :: cmfd_coremap = .false.
! Flag to reset dhats to zero
logical, public :: dhat_reset = .false.
! Flag to activate neutronic feedback via source weights
logical, public :: cmfd_feedback = .false.
! Adjoint method type
character(len=10), public :: cmfd_adjoint_type = 'physical'
! Number of incomplete ilu factorization levels
integer, public :: cmfd_ilu_levels = 1
! Batch to begin cmfd
integer, public :: cmfd_begin = 1
! Tally reset list
integer, public :: n_cmfd_resets
type(SetInt), public :: cmfd_reset
! Compute effective downscatter cross section
logical, public :: cmfd_downscatter = .false.
! Convergence monitoring
logical, public :: cmfd_power_monitor = .false.
! Cmfd output
logical, public :: cmfd_write_matrices = .false.
! Run an adjoint calculation (last batch only)
logical, public :: cmfd_run_adjoint = .false.
! CMFD run logicals
logical, public :: cmfd_on = .false.
! CMFD display info
character(len=25), public :: cmfd_display = 'balance'
! Estimate of spectral radius of CMFD matrices and tolerances
real(8), public :: cmfd_spectral = ZERO
real(8), public :: cmfd_shift = 1.e6
real(8), public :: cmfd_ktol = 1.e-8_8
real(8), public :: cmfd_stol = 1.e-8_8
real(8), public :: cmfd_atoli = 1.e-10_8
real(8), public :: cmfd_rtoli = 1.e-5_8
contains
!==============================================================================
@ -133,7 +198,7 @@ contains
if (.not. allocated(this % openmc_src)) allocate(this % openmc_src(ng,nx,ny,nz))
! Allocate source weight modification vars
if (.not. allocated(this % sourcecounts)) allocate(this % sourcecounts(ng,nx,ny,nz))
if (.not. allocated(this % sourcecounts)) allocate(this % sourcecounts(ng,nx*ny*nz))
if (.not. allocated(this % weightfactors)) allocate(this % weightfactors(ng,nx,ny,nz))
! Allocate batchwise parameters

183
src/cmfd_input.F90
View file

@ -1,6 +1,13 @@
module cmfd_input
use global
use, intrinsic :: ISO_C_BINDING
use cmfd_header
use mesh_header, only: mesh_dict
use mgxs_header, only: energy_bins
use tally
use tally_header
use timer_header
implicit none
private
@ -14,21 +21,9 @@ contains
subroutine configure_cmfd()
use cmfd_header, only: allocate_cmfd
use message_passing, only: master
integer :: color ! color group of processor
! Read in cmfd input file
call read_cmfd_xml()
! Assign color
if (master) then
color = 1
else
color = 2
end if
! Initialize timers
call time_cmfd % reset()
call time_cmfdbuild % reset()
@ -47,7 +42,6 @@ contains
use constants, only: ZERO, ONE
use error, only: fatal_error, warning
use global
use output, only: write_message
use string, only: to_lower
use xml_interface
@ -248,13 +242,12 @@ contains
use constants, only: MAX_LINE_LEN
use error, only: fatal_error, warning
use mesh_header, only: RegularMesh
use mesh_header, only: RegularMesh, openmc_extend_meshes
use string
use tally, only: setup_active_cmfdtallies
use tally_header, only: TallyObject
use tally, only: openmc_tally_set_type
use tally_header, only: openmc_extend_tallies
use tally_filter_header
use tally_filter
use tally_initialize, only: add_tallies
use xml_interface
type(XMLNode), intent(in) :: root ! XML root element
@ -262,25 +255,27 @@ contains
logical :: energy_filters
integer :: i ! loop counter
integer :: n ! size of arrays in mesh specification
integer :: ng ! number of energy groups (default 1)
integer(C_INT32_T) :: ng ! number of energy groups (default 1)
integer :: n_filter ! number of filters
integer :: i_start, i_end
integer :: i_filt_start, i_filt_end
integer(C_INT32_T), allocatable :: filter_indices(:)
integer(C_INT) :: err
integer :: i_filt ! index in filters array
integer :: iarray3(3) ! temp integer array
real(8) :: rarray3(3) ! temp double array
type(TallyObject), pointer :: t
real(C_DOUBLE), allocatable :: energies(:)
type(RegularMesh), pointer :: m
type(XMLNode) :: node_mesh
! Set global variables if they are 0 (this can happen if there is no tally
! file)
if (n_meshes == 0) n_meshes = n_user_meshes + n_cmfd_meshes
err = openmc_extend_meshes(1, i_start)
! Allocate mesh
if (.not. allocated(meshes)) allocate(meshes(n_meshes))
m => meshes(n_user_meshes+1)
cmfd_mesh => meshes(i_start)
m => meshes(i_start)
! Set mesh id
m % id = n_user_meshes + 1
m % id = i_start
! Set mesh type to rectangular
m % type = LATTICE_RECT
@ -374,71 +369,50 @@ contains
m % volume_frac = ONE/real(product(m % dimension),8)
! Add mesh to dictionary
call mesh_dict % add_key(m % id, n_user_meshes + 1)
call mesh_dict % add_key(m % id, i_start)
! Determine number of filters
energy_filters = check_for_node(node_mesh, "energy")
n_cmfd_filters = merge(5, 3, energy_filters)
n = merge(5, 3, energy_filters)
! Extend filters array so we can add CMFD filters
call add_filters(n_cmfd_filters)
err = openmc_extend_filters(n, i_filt_start, i_filt_end)
! Set up mesh filter
i_filt = n_user_filters + 1
allocate(MeshFilter :: filters(i_filt) % obj)
select type (filt => filters(i_filt) % obj)
type is (MeshFilter)
filt % id = i_filt
filt % n_bins = product(m % dimension)
filt % mesh = n_user_meshes + 1
! Add filter to dictionary
call filter_dict % add_key(filt % id, i_filt)
end select
i_filt = i_filt_start
err = openmc_filter_set_type(i_filt, C_CHAR_'mesh' // C_NULL_CHAR)
err = openmc_filter_set_id(i_filt, i_filt)
err = openmc_mesh_filter_set_mesh(i_filt, i_start)
if (energy_filters) then
! Read and set incoming energy mesh filter
i_filt = i_filt + 1
allocate(EnergyFilter :: filters(i_filt) % obj)
select type (filt => filters(i_filt) % obj)
type is (EnergyFilter)
filt % id = i_filt
ng = node_word_count(node_mesh, "energy")
filt % n_bins = ng - 1
allocate(filt % bins(ng))
call get_node_array(node_mesh, "energy", filt % bins)
! Add filter to dictionary
call filter_dict % add_key(filt % id, i_filt)
end select
err = openmc_filter_set_type(i_filt, C_CHAR_'energy' // C_NULL_CHAR)
err = openmc_filter_set_id(i_filt, i_filt)
! Get energies and set bins
ng = node_word_count(node_mesh, "energy")
allocate(energies(ng))
call get_node_array(node_mesh, "energy", energies)
err = openmc_energy_filter_set_bins(i_filt, ng, energies)
! Read and set outgoing energy mesh filter
i_filt = i_filt + 1
allocate(EnergyoutFilter :: filters(i_filt) % obj)
select type (filt => filters(i_filt) % obj)
type is (EnergyoutFilter)
filt % id = i_filt
ng = node_word_count(node_mesh, "energy")
filt % n_bins = ng - 1
allocate(filt % bins(ng))
call get_node_array(node_mesh, "energy", filt % bins)
! Add filter to dictionary
call filter_dict % add_key(filt % id, i_filt)
end select
err = openmc_filter_set_type(i_filt, C_CHAR_'energyout' // C_NULL_CHAR)
err = openmc_filter_set_id(i_filt, i_filt)
err = openmc_energy_filter_set_bins(i_filt, ng, energies)
end if
! Duplicate the mesh filter for the mesh current tally since other
! tallies use this filter and we need to change the dimension
i_filt = i_filt + 1
allocate(MeshFilter :: filters(i_filt) % obj)
select type (filt => filters(i_filt) % obj)
type is (MeshFilter)
filt % id = i_filt
! We need to increase the dimension by one since we also need
! currents coming into and out of the boundary mesh cells.
filt % n_bins = product(m % dimension + 1)
filt % mesh = n_user_meshes + 1
! Add filter to dictionary
call filter_dict % add_key(filt % id, i_filt)
end select
err = openmc_filter_set_type(i_filt, C_CHAR_'mesh' // C_NULL_CHAR)
err = openmc_filter_set_id(i_filt, i_filt)
err = openmc_mesh_filter_set_mesh(i_filt, i_start)
! We need to increase the dimension by one since we also need
! currents coming into and out of the boundary mesh cells.
filters(i_filt) % obj % n_bins = product(m % dimension + 1)
! Set up surface filter
i_filt = i_filt + 1
@ -461,29 +435,38 @@ contains
call filter_dict % add_key(filt % id, i_filt)
end select
! Initialize filters
do i = i_filt_start, i_filt_end
select type (filt => filters(i) % obj)
type is (SurfaceFilter)
! Don't do anything
class default
call filt % initialize()
end select
end do
! Allocate tallies
call add_tallies("cmfd", n_cmfd_tallies)
err = openmc_extend_tallies(3, i_start, i_end)
cmfd_tallies => tallies(i_start:i_end)
! Begin loop around tallies
do i = 1, n_cmfd_tallies
do i = 1, size(cmfd_tallies)
! Allocate tally
err = openmc_tally_set_type(i_start + i - 1, C_CHAR_'generic' // C_NULL_CHAR)
! Point t to tally variable
t => cmfd_tallies(i)
associate (t => cmfd_tallies(i) % obj)
! Set reset property
if (check_for_node(root, "reset")) then
call get_node_value(root, "reset", t % reset)
end if
! Set the mesh filter index in the tally find_filter array
n_filter = 1
t % find_filter(FILTER_MESH) = n_filter
! Set the incoming energy mesh filter index in the tally find_filter
! array
n_filter = 1
if (energy_filters) then
n_filter = n_filter + 1
t % find_filter(FILTER_ENERGYIN) = n_filter
end if
! Set number of nucilde bins
@ -492,7 +475,7 @@ contains
t % n_nuclide_bins = 1
! Record tally id which is equivalent to loop number
t % id = i_cmfd_tallies + i
t % id = i_start + i - 1
if (i == 1) then
@ -506,11 +489,13 @@ contains
t % type = TALLY_VOLUME
! Allocate and set filters
allocate(t % filter(n_filter))
t % filter(1) = n_user_filters + 1
allocate(filter_indices(n_filter))
filter_indices(1) = i_filt_start
if (energy_filters) then
t % filter(2) = n_user_filters + 2
filter_indices(2) = i_filt_start + 1
end if
err = openmc_tally_set_filters(i_start + i - 1, n_filter, filter_indices)
deallocate(filter_indices)
! Allocate scoring bins
allocate(t % score_bins(3))
@ -542,16 +527,17 @@ contains
! array
if (energy_filters) then
n_filter = n_filter + 1
t % find_filter(FILTER_ENERGYOUT) = n_filter
end if
! Allocate and set indices in filters array
allocate(t % filter(n_filter))
t % filter(1) = n_user_filters + 1
allocate(filter_indices(n_filter))
filter_indices(1) = i_filt_start
if (energy_filters) then
t % filter(2) = n_user_filters + 2
t % filter(3) = n_user_filters + 3
filter_indices(2) = i_filt_start + 1
filter_indices(3) = i_filt_start + 2
end if
err = openmc_tally_set_filters(i_start + i - 1, n_filter, filter_indices)
deallocate(filter_indices)
! Allocate macro reactions
allocate(t % score_bins(2))
@ -576,15 +562,16 @@ contains
! Set the surface filter index in the tally find_filter array
n_filter = n_filter + 1
t % find_filter(FILTER_SURFACE) = n_filter
! Allocate and set filters
allocate(t % filter(n_filter))
t % filter(1) = n_user_filters + n_cmfd_filters - 1
t % filter(n_filter) = n_user_filters + n_cmfd_filters
allocate(filter_indices(n_filter))
filter_indices(1) = i_filt_end - 1
filter_indices(n_filter) = i_filt_end
if (energy_filters) then
t % filter(2) = n_user_filters + 2
filter_indices(2) = i_filt_start + 1
end if
err = openmc_tally_set_filters(i_start + i - 1, n_filter, filter_indices)
deallocate(filter_indices)
! Allocate macro reactions
allocate(t % score_bins(1))
@ -600,11 +587,11 @@ contains
t % type = TALLY_MESH_CURRENT
end if
end do
! Make CMFD tallies active from the start
t % active = .true.
! Put cmfd tallies into active tally array and turn tallies on
call setup_active_cmfdtallies()
tallies_on = .true.
end associate
end do
end subroutine create_cmfd_tally

2
src/cmfd_loss_operator.F90
View file

@ -1,7 +1,7 @@
module cmfd_loss_operator
use constants, only: CMFD_NOACCEL, ZERO
use global, only: cmfd, cmfd_coremap
use cmfd_header, only: cmfd, cmfd_coremap
use matrix_header, only: Matrix
implicit none

2
src/cmfd_prod_operator.F90
View file

@ -1,7 +1,7 @@
module cmfd_prod_operator
use constants, only: CMFD_NOACCEL
use global, only: cmfd, cmfd_coremap
use cmfd_header, only: cmfd, cmfd_coremap
use matrix_header, only: Matrix
implicit none

23
src/cmfd_solver.F90
View file

@ -53,7 +53,7 @@ contains
subroutine cmfd_solver_execute(adjoint)
use global, only: cmfd_adjoint_type, time_cmfdbuild, time_cmfdsolve
use cmfd_header, only: cmfd_adjoint_type, time_cmfdbuild, time_cmfdsolve
logical, optional, intent(in) :: adjoint ! adjoint calc
@ -100,8 +100,8 @@ contains
subroutine init_data(adjoint)
use constants, only: ONE, ZERO
use global, only: cmfd_shift, keff, cmfd_ktol, cmfd_stol, &
cmfd_write_matrices
use cmfd_header, only: cmfd_shift, cmfd_ktol, cmfd_stol, cmfd_write_matrices
use simulation_header, only: keff
logical, intent(in) :: adjoint
@ -167,7 +167,7 @@ contains
subroutine compute_adjoint()
use error, only: fatal_error
use global, only: cmfd_write_matrices
use cmfd_header, only: cmfd_write_matrices
! Transpose matrices
loss = loss % transpose()
@ -190,7 +190,7 @@ contains
use constants, only: ONE
use error, only: fatal_error
use global, only: cmfd, cmfd_atoli, cmfd_rtoli
use cmfd_header, only: cmfd, cmfd_atoli, cmfd_rtoli
integer :: i ! iteration counter
integer :: innerits ! # of inner iterations
@ -304,7 +304,7 @@ contains
use, intrinsic :: ISO_FORTRAN_ENV
use constants, only: ONE, ZERO
use global, only: cmfd_power_monitor
use cmfd_header, only: cmfd_power_monitor
use message_passing, only: master
integer, intent(in) :: iter ! outer iteration number
@ -346,7 +346,7 @@ contains
use constants, only: ONE, ZERO
use error, only: fatal_error
use global, only: cmfd, cmfd_spectral
use cmfd_header, only: cmfd, cmfd_spectral
type(Matrix), intent(inout) :: A ! coefficient matrix
type(Vector), intent(inout) :: b ! right hand side vector
@ -452,7 +452,7 @@ contains
use constants, only: ONE, ZERO
use error, only: fatal_error
use global, only: cmfd, cmfd_spectral
use cmfd_header, only: cmfd, cmfd_spectral
type(Matrix), intent(inout) :: A ! coefficient matrix
type(Vector), intent(inout) :: b ! right hand side vector
@ -597,7 +597,7 @@ contains
use constants, only: ONE, ZERO
use error, only: fatal_error
use global, only: cmfd, cmfd_spectral
use cmfd_header, only: cmfd, cmfd_spectral
type(Matrix), intent(inout) :: A ! coefficient matrix
type(Vector), intent(inout) :: b ! right hand side vector
@ -693,7 +693,8 @@ contains
subroutine extract_results()
use global, only: cmfd, cmfd_write_matrices, current_batch
use cmfd_header, only: cmfd, cmfd_write_matrices
use simulation_header, only: current_batch
character(len=25) :: filename ! name of file to write data
integer :: n ! problem size
@ -750,7 +751,7 @@ contains
subroutine matrix_to_indices(irow, g, i, j, k, ng, nx, ny, nz)
use global, only: cmfd, cmfd_coremap
use cmfd_header, only: cmfd, cmfd_coremap
integer, intent(out) :: i ! iteration counter for x
integer, intent(out) :: j ! iteration counter for y

7
src/cross_section.F90
View file

@ -3,9 +3,8 @@ module cross_section
use algorithm, only: binary_search
use constants
use error, only: fatal_error
use global
use list_header, only: ListElemInt
use material_header, only: Material
use material_header, only: Material, materials
use math, only: faddeeva, w_derivative, broaden_wmp_polynomials
use multipole_header, only: FORM_RM, FORM_MLBW, MP_EA, RM_RT, RM_RA, RM_RF, &
MLBW_RT, MLBW_RX, MLBW_RA, MLBW_RF, FIT_T, FIT_A,&
@ -13,7 +12,9 @@ module cross_section
use nuclide_header
use particle_header, only: Particle
use random_lcg, only: prn, future_prn, prn_set_stream
use sab_header, only: SAlphaBeta
use sab_header, only: SAlphaBeta, sab_tables
use settings
use simulation_header
implicit none

97
src/distribution_multivariate.F90
View file

@ -1,9 +1,11 @@
module distribution_multivariate
use constants, only: ONE, TWO, PI
use distribution_univariate, only: Distribution
use distribution_univariate
use error, only: fatal_error
use random_lcg, only: prn
use math, only: rotate_angle
use xml_interface
implicit none
@ -58,10 +60,17 @@ module distribution_multivariate
type, abstract :: SpatialDistribution
contains
procedure(spatial_distribution_from_xml_), deferred :: from_xml
procedure(spatial_distribution_sample_), deferred :: sample
end type SpatialDistribution
abstract interface
subroutine spatial_distribution_from_xml_(this, node)
import SpatialDistribution, XMLNode
class(SpatialDistribution), intent(inout) :: this
type(XMLNode), intent(in) :: node
end subroutine spatial_distribution_from_xml_
function spatial_distribution_sample_(this) result(xyz)
import SpatialDistribution
class(SpatialDistribution), intent(in) :: this
@ -74,6 +83,7 @@ module distribution_multivariate
class(Distribution), allocatable :: y
class(Distribution), allocatable :: z
contains
procedure :: from_xml => cartesian_independent_from_xml
procedure :: sample => cartesian_independent_sample
end type CartesianIndependent
@ -82,12 +92,14 @@ module distribution_multivariate
real(8) :: upper_right(3)
logical :: only_fissionable = .false.
contains
procedure :: from_xml => spatial_box_from_xml
procedure :: sample => spatial_box_sample
end type SpatialBox
type, extends(SpatialDistribution) :: SpatialPoint
real(8) :: xyz(3)
contains
procedure :: from_xml => spatial_point_from_xml
procedure :: sample => spatial_point_sample
end type SpatialPoint
@ -132,6 +144,55 @@ contains
uvw(:) = this % reference_uvw
end function monodirectional_sample
subroutine cartesian_independent_from_xml(this, node)
class(CartesianIndependent), intent(inout) :: this
type(XMLNode), intent(in) :: node
type(XMLNode) :: node_dist
! Read distribution for x coordinate
if (check_for_node(node, "x")) then
node_dist = node % child("x")
call distribution_from_xml(this % x, node_dist)
else
allocate(Discrete :: this % x)
select type (dist => this % x)
type is (Discrete)
allocate(dist % x(1), dist % p(1))
dist % x(1) = ZERO
dist % p(1) = ONE
end select
end if
! Read distribution for y coordinate
if (check_for_node(node, "y")) then
node_dist = node % child("y")
call distribution_from_xml(this % y, node_dist)
else
allocate(Discrete :: this % y)
select type (dist => this % y)
type is (Discrete)
allocate(dist % x(1), dist % p(1))
dist % x(1) = ZERO
dist % p(1) = ONE
end select
end if
if (check_for_node(node, "z")) then
node_dist = node % child("z")
call distribution_from_xml(this % z, node_dist)
else
allocate(Discrete :: this % z)
select type (dist => this % z)
type is (Discrete)
allocate(dist % x(1), dist % p(1))
dist % x(1) = ZERO
dist % p(1) = ONE
end select
end if
end subroutine cartesian_independent_from_xml
function cartesian_independent_sample(this) result(xyz)
class(CartesianIndependent), intent(in) :: this
real(8) :: xyz(3)
@ -141,6 +202,26 @@ contains
xyz(3) = this % z % sample()
end function cartesian_independent_sample
subroutine spatial_box_from_xml(this, node)
class(SpatialBox), intent(inout) :: this
type(XMLNode), intent(in) :: node
real(8), allocatable :: temp_real(:)
! Make sure correct number of parameters are given
if (node_word_count(node, "parameters") /= 6) then
call fatal_error('Box/fission spatial source must have &
&six parameters specified.')
end if
! Read lower-right/upper-left coordinates
allocate(temp_real(6))
call get_node_array(node, "parameters", temp_real)
this % lower_left(:) = temp_real(1:3)
this % upper_right(:) = temp_real(4:6)
deallocate(temp_real)
end subroutine spatial_box_from_xml
function spatial_box_sample(this) result(xyz)
class(SpatialBox), intent(in) :: this
real(8) :: xyz(3)
@ -152,6 +233,20 @@ contains
xyz(:) = this % lower_left + r*(this % upper_right - this % lower_left)
end function spatial_box_sample
subroutine spatial_point_from_xml(this, node)
class(SpatialPoint), intent(inout) :: this
type(XMLNode), intent(in) :: node
! Make sure correct number of parameters are given
if (node_word_count(node, "parameters") /= 3) then
call fatal_error('Point spatial source must have &
&three parameters specified.')
end if
! Read location of point source
call get_node_array(node, "parameters", this % xyz)
end subroutine spatial_point_from_xml
function spatial_point_sample(this) result(xyz)
class(SpatialPoint), intent(in) :: this
real(8) :: xyz(3)

94
src/eigenvalue.F90
View file

@ -5,13 +5,16 @@ module eigenvalue
use algorithm, only: binary_search
use constants, only: ZERO
use error, only: fatal_error, warning
use global
use math, only: t_percentile
use mesh, only: count_bank_sites
use mesh_header, only: RegularMesh
use mesh_header, only: RegularMesh, meshes
use message_passing
use random_lcg, only: prn, set_particle_seed, advance_prn_seed
use settings
use simulation_header
use string, only: to_str
use tally_header
use timer_header
implicit none
@ -299,69 +302,34 @@ contains
subroutine shannon_entropy()
integer :: ent_idx ! entropy index
integer :: i, j, k ! index for bank sites
integer :: n ! # of boxes in each dimension
integer :: i ! index for mesh elements
logical :: sites_outside ! were there sites outside entropy box?
type(RegularMesh), pointer :: m
! Get pointer to entropy mesh
m => entropy_mesh
! On the first pass through this subroutine, we need to determine how big
! the entropy mesh should be in each direction and then allocate a
! three-dimensional array to store the fraction of source sites in each mesh
! box
if (.not. allocated(entropy_p)) then
if (.not. allocated(m % dimension)) then
! If the user did not specify how many mesh cells are to be used in
! each direction, we automatically determine an appropriate number of
! cells
n = ceiling((n_particles/20)**(ONE/THREE))
! copy dimensions
m % n_dimension = 3
allocate(m % dimension(3))
m % dimension = n
! determine width
m % width = (m % upper_right - m % lower_left) / m % dimension
associate (m => meshes(index_entropy_mesh))
! count number of fission sites over mesh
call count_bank_sites(m, fission_bank, entropy_p, &
size_bank=n_bank, sites_outside=sites_outside)
! display warning message if there were sites outside entropy box
if (sites_outside) then
if (master) call warning("Fission source site(s) outside of entropy box.")
end if
! allocate p
allocate(entropy_p(1, m % dimension(1), m % dimension(2), &
m % dimension(3)))
end if
! sum values to obtain shannon entropy
if (master) then
! Normalize to total weight of bank sites
entropy_p = entropy_p / sum(entropy_p)
! count number of fission sites over mesh
call count_bank_sites(m, fission_bank, entropy_p, &
size_bank=n_bank, sites_outside=sites_outside)
! display warning message if there were sites outside entropy box
if (sites_outside) then
if (master) call warning("Fission source site(s) outside of entropy box.")
end if
! sum values to obtain shannon entropy
if (master) then
! Normalize to total weight of bank sites
entropy_p = entropy_p / sum(entropy_p)
ent_idx = current_gen + gen_per_batch*(current_batch - 1)
entropy(ent_idx) = ZERO
do i = 1, m % dimension(1)
do j = 1, m % dimension(2)
do k = 1, m % dimension(3)
if (entropy_p(1,i,j,k) > ZERO) then
entropy(ent_idx) = entropy(ent_idx) - &
entropy_p(1,i,j,k) * log(entropy_p(1,i,j,k))/log(TWO)
end if
end do
ent_idx = current_gen + gen_per_batch*(current_batch - 1)
entropy(ent_idx) = ZERO
do i = 1, size(entropy_p, 2)
if (entropy_p(1,i) > ZERO) then
entropy(ent_idx) = entropy(ent_idx) - &
entropy_p(1,i) * log(entropy_p(1,i))/log(TWO)
end if
end do
end do
end if
end if
end associate
end subroutine shannon_entropy
!===============================================================================
@ -621,16 +589,18 @@ contains
integer :: mpi_err ! MPI error code
#endif
associate (m => meshes(index_ufs_mesh))
if (current_batch == 1 .and. current_gen == 1) then
! On the first generation, just assume that the source is already evenly
! distributed so that effectively the production of fission sites is not
! biased
source_frac = ufs_mesh % volume_frac
source_frac = m % volume_frac
else
! count number of source sites in each ufs mesh cell
call count_bank_sites(ufs_mesh, source_bank, source_frac, &
call count_bank_sites(m, source_bank, source_frac, &
sites_outside=sites_outside, size_bank=work)
! Check for sites outside of the mesh
@ -640,7 +610,7 @@ contains
#ifdef MPI
! Send source fraction to all processors
n = product(ufs_mesh % dimension)
n = product(m % dimension)
call MPI_BCAST(source_frac, n, MPI_REAL8, 0, mpi_intracomm, mpi_err)
#endif
@ -654,6 +624,8 @@ contains
source_bank % wgt = source_bank % wgt * n_particles / total
end if
end associate
end subroutine count_source_for_ufs
#ifdef _OPENMP

45
src/error.F90
View file

@ -1,14 +1,57 @@
module error
use, intrinsic :: ISO_C_BINDING
use, intrinsic :: ISO_FORTRAN_ENV
use constants
use constants
use message_passing
implicit none
private
public :: fatal_error
public :: warning
! Error codes
integer(C_INT), public, bind(C) :: E_UNASSIGNED = -1
integer(C_INT), public, bind(C) :: E_ALLOCATE = -2
integer(C_INT), public, bind(C) :: E_OUT_OF_BOUNDS = -3
integer(C_INT), public, bind(C) :: E_INVALID_SIZE = -4
integer(C_INT), public, bind(C) :: E_INVALID_ARGUMENT = -5
integer(C_INT), public, bind(C) :: E_INVALID_TYPE = -6
integer(C_INT), public, bind(C) :: E_INVALID_ID = -7
integer(C_INT), public, bind(C) :: E_GEOMETRY = -8
integer(C_INT), public, bind(C) :: E_DATA = -9
integer(C_INT), public, bind(C) :: E_PHYSICS = -10
! Warning codes
integer(C_INT), public, bind(C) :: E_WARNING = 1
! Error message
character(kind=C_CHAR), public, bind(C) :: openmc_err_msg(256)
public :: set_errmsg
contains
!===============================================================================
! SET_ERRMSG sets the 'openmc_err_msg' module variable that is exposed via the C
! API
!===============================================================================
subroutine set_errmsg(f_string)
character(*), intent(in) :: f_string
integer :: i, n
! Copy Fortran string to null-terminated C char array
n = len_trim(f_string)
do i = 1, n
openmc_err_msg(i) = f_string(i:i)
end do
openmc_err_msg(n + 1) = C_NULL_CHAR
end subroutine set_errmsg
!===============================================================================
! WARNING issues a warning to the user in the log file and the standard output
! stream.

11
src/geometry.F90
View file

@ -2,16 +2,17 @@ module geometry
use constants
use error, only: fatal_error, warning
use geometry_header, only: Cell, Universe, Lattice, &
&RectLattice, HexLattice
use global
use geometry_header
use output, only: write_message
use particle_header, only: LocalCoord, Particle
use particle_restart_write, only: write_particle_restart
use simulation_header
use settings
use surface_header
use stl_vector, only: VectorInt
use string, only: to_str
use tally, only: score_surface_current
use tally_header
implicit none
@ -424,9 +425,7 @@ contains
end if
! Score to global leakage tally
if (tallies_on) then
global_tally_leakage = global_tally_leakage + p % wgt
end if
global_tally_leakage = global_tally_leakage + p % wgt
! Display message
if (verbosity >= 10 .or. trace) then

273
src/geometry_header.F90
View file

@ -1,10 +1,14 @@
module geometry_header
use, intrinsic :: ISO_C_BINDING
use algorithm, only: find
use constants, only: HALF, TWO, THREE, INFINITY, K_BOLTZMANN, &
MATERIAL_VOID, NONE
use dict_header, only: DictCharInt, DictIntInt
use material_header, only: Material
use material_header, only: Material, materials, material_dict, n_materials
use nuclide_header
use sab_header
use stl_vector, only: VectorReal
use string, only: to_lower
@ -155,6 +159,19 @@ module geometry_header
! array index of the root universe
integer :: root_universe = -1
integer(C_INT32_T), bind(C) :: n_cells ! # of cells
integer(C_INT32_T), bind(C) :: n_universes ! # of universes
integer(C_INT32_T), bind(C) :: n_lattices ! # of lattices
type(Cell), allocatable, target :: cells(:)
type(Universe), allocatable, target :: universes(:)
type(LatticeContainer), allocatable, target :: lattices(:)
! Dictionaries which map user IDs to indices in the global arrays
type(DictIntInt) :: cell_dict
type(DictIntInt) :: universe_dict
type(DictIntInt) :: lattice_dict
contains
!===============================================================================
@ -330,16 +347,8 @@ contains
! temperatures to read (which may be different if interpolation is used)
!===============================================================================
subroutine get_temperatures(cells, materials, material_dict, nuclide_dict, &
n_nucs, nuc_temps, sab_dict, n_sabs, sab_temps)
type(Cell), allocatable, intent(in) :: cells(:)
type(Material), allocatable, intent(in) :: materials(:)
type(DictIntInt), intent(in) :: material_dict
type(DictCharInt), intent(in) :: nuclide_dict
integer, intent(in) :: n_nucs
subroutine get_temperatures(nuc_temps, sab_temps)
type(VectorReal), allocatable, intent(out) :: nuc_temps(:)
type(DictCharInt), optional, intent(in) :: sab_dict
integer, optional, intent(in) :: n_sabs
type(VectorReal), optional, allocatable, intent(out) :: sab_temps(:)
integer :: i, j, k
@ -348,8 +357,8 @@ contains
integer :: i_material
real(8) :: temperature ! temperature in Kelvin
allocate(nuc_temps(n_nucs))
if (present(n_sabs) .and. present(sab_temps)) allocate(sab_temps(n_sabs))
allocate(nuc_temps(n_nuclides))
if (present(sab_temps)) allocate(sab_temps(n_sab_tables))
do i = 1, size(cells)
do j = 1, size(cells(i) % material)
@ -364,7 +373,7 @@ contains
temperature = cells(i) % sqrtkT(1)**2 / K_BOLTZMANN
end if
i_material = material_dict % get_key(cells(i) % material(j))
i_material = cells(i) % material(j)
associate (mat => materials(i_material))
NUC_NAMES_LOOP: do k = 1, size(mat % names)
! Get index in nuc_temps array
@ -376,8 +385,7 @@ contains
end if
end do NUC_NAMES_LOOP
if (present(sab_temps) .and. present(sab_dict) .and. &
mat % n_sab > 0) then
if (present(sab_temps) .and. mat % n_sab > 0) then
SAB_NAMES_LOOP: do k = 1, size(mat % sab_names)
! Get index in nuc_temps array
i_sab = sab_dict % get_key(to_lower(mat % sab_names(k)))
@ -394,4 +402,239 @@ contains
end subroutine get_temperatures
!===============================================================================
! FREE_MEMORY_GEOMETRY deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_geometry()
n_cells = 0
n_universes = 0
n_lattices = 0
if (allocated(cells)) deallocate(cells)
if (allocated(universes)) deallocate(universes)
if (allocated(lattices)) deallocate(lattices)
call cell_dict % clear()
call universe_dict % clear()
call lattice_dict % clear()
end subroutine free_memory_geometry
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_get_cell_index(id, index) result(err) bind(C)
! Return the index in the cells array of a cell with a given ID
integer(C_INT32_T), value :: id
integer(C_INT32_T), intent(out) :: index
integer(C_INT) :: err
if (allocated(cells)) then
if (cell_dict % has_key(id)) then
index = cell_dict % get_key(id)
err = 0
else
err = E_INVALID_ID
call set_errmsg("No cell exists with ID=" // trim(to_str(id)) // ".")
end if
else
err = E_ALLOCATE
call set_errmsg("Memory has not been allocated for cells.")
end if
end function openmc_get_cell_index
function openmc_cell_get_fill(index, type, indices, n) result(err) bind(C)
integer(C_INT32_T), value, intent(in) :: index
integer(C_INT), intent(out) :: type
integer(C_INT32_T), intent(out) :: n
type(C_PTR), intent(out) :: indices
integer(C_INT) :: err
err = 0
if (index >= 1 .and. index <= size(cells)) then
associate (c => cells(index))
type = c % type
select case (type)
case (FILL_MATERIAL)
n = size(c % material)
indices = C_LOC(c % material(1))
case (FILL_UNIVERSE, FILL_LATTICE)
n = 1
indices = C_LOC(c % fill)
end select
end associate
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in cells array is out of bounds.")
end if
end function openmc_cell_get_fill
function openmc_cell_get_id(index, id) result(err) bind(C)
! Return the ID of a cell
integer(C_INT32_T), value :: index
integer(C_INT32_T), intent(out) :: id
integer(C_INT) :: err
if (index >= 1 .and. index <= size(cells)) then
id = cells(index) % id
err = 0
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in cells array is out of bounds.")
end if
end function openmc_cell_get_id
function openmc_cell_set_fill(index, type, n, indices) result(err) bind(C)
! Set the fill for a fill
integer(C_INT32_T), value, intent(in) :: index ! index in cells
integer(C_INT), value, intent(in) :: type
integer(c_INT32_T), value, intent(in) :: n
integer(C_INT32_T), intent(in) :: indices(n)
integer(C_INT) :: err
integer :: i, j
err = 0
if (index >= 1 .and. index <= size(cells)) then
associate (c => cells(index))
select case (type)
case (FILL_MATERIAL)
if (allocated(c % material)) deallocate(c % material)
allocate(c % material(n))
c % type = FILL_MATERIAL
do i = 1, n
j = indices(i)
if (j == 0) then
c % material(i) = MATERIAL_VOID
else
if (j >= 1 .and. j <= n_materials) then
c % material(i) = j
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index " // trim(to_str(j)) // " in the &
&materials array is out of bounds.")
end if
end if
end do
case (FILL_UNIVERSE)
c % type = FILL_UNIVERSE
case (FILL_LATTICE)
c % type = FILL_LATTICE
end select
end associate
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in cells array is out of bounds.")
end if
end function openmc_cell_set_fill
function openmc_cell_set_temperature(index, T, instance) result(err) bind(C)
! Set the temperature of a cell
integer(C_INT32_T), value, intent(in) :: index ! index in cells
real(C_DOUBLE), value, intent(in) :: T ! temperature
integer(C_INT32_T), optional, intent(in) :: instance ! cell instance
integer(C_INT) :: err ! error code
integer :: j ! looping variable
integer :: n ! number of cell instances
integer :: material_index ! material index in materials array
integer :: num_nuclides ! num nuclides in material
integer :: nuclide_index ! index of nuclide in nuclides array
real(8) :: min_temp ! min common-denominator avail temp
real(8) :: max_temp ! max common-denominator avail temp
real(8) :: temp ! actual temp we'll assign
logical :: outside_low ! lower than available data
logical :: outside_high ! higher than available data
outside_low = .false.
outside_high = .false.
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(cells)) then
! error if the cell is filled with another universe
if (cells(index) % fill /= NONE) then
err = E_GEOMETRY
call set_errmsg("Cannot set temperature on a cell filled &
&with a universe.")
else
! find which material is associated with this cell (material_index
! is the index into the materials array)
if (present(instance)) then
material_index = cells(index) % material(instance)
else
material_index = cells(index) % material(1)
end if
! number of nuclides associated with this material
num_nuclides = size(materials(material_index) % nuclide)
min_temp = ZERO
max_temp = INFINITY
do j = 1, num_nuclides
nuclide_index = materials(material_index) % nuclide(j)
min_temp = max(min_temp, minval(nuclides(nuclide_index) % kTs))
max_temp = min(max_temp, maxval(nuclides(nuclide_index) % kTs))
end do
! adjust the temperature to be within bounds if necessary
if (K_BOLTZMANN * T < min_temp) then
outside_low = .true.
temp = min_temp / K_BOLTZMANN
else if (K_BOLTZMANN * T > max_temp) then
outside_high = .true.
temp = max_temp / K_BOLTZMANN
else
temp = T
end if
associate (c => cells(index))
if (allocated(c % sqrtkT)) then
n = size(c % sqrtkT)
if (present(instance) .and. n > 1) then
if (instance >= 0 .and. instance < n) then
c % sqrtkT(instance + 1) = sqrt(K_BOLTZMANN * temp)
err = 0
end if
else
c % sqrtkT(:) = sqrt(K_BOLTZMANN * temp)
err = 0
end if
end if
end associate
! Assign error codes for outside of temperature bounds provided the
! temperature was changed correctly. This needs to be done after
! changing the temperature based on the logical structure above.
if (err == 0) then
if (outside_low) then
err = E_WARNING
call set_errmsg("Nuclear data has not been loaded beyond lower &
&bound of T=" // trim(to_str(T)) // " K.")
else if (outside_high) then
err = E_WARNING
call set_errmsg("Nuclear data has not been loaded beyond upper &
&bound of T=" // trim(to_str(T)) // " K.")
end if
end if
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in cells array is out of bounds.")
end if
end function openmc_cell_set_temperature
end module geometry_header

588
src/global.F90
View file

@ -1,588 +0,0 @@
module global
use, intrinsic :: ISO_C_BINDING
#ifdef MPIF08
use mpi_f08
#endif
use bank_header, only: Bank
use cmfd_header
use constants
use dict_header, only: DictCharInt, DictIntInt
use geometry_header, only: Cell, Universe, Lattice, LatticeContainer
use material_header, only: Material
use mesh_header, only: RegularMesh
use mgxs_header, only: Mgxs, MgxsContainer
use nuclide_header
use plot_header, only: ObjectPlot
use sab_header, only: SAlphaBeta
use set_header, only: SetInt
use stl_vector, only: VectorInt
use surface_header, only: SurfaceContainer
use source_header, only: SourceDistribution
use tally_header, only: TallyObject, TallyDerivative
use tally_filter_header, only: TallyFilterContainer, TallyFilterMatch
use trigger_header, only: KTrigger
use timer_header, only: Timer
use volume_header, only: VolumeCalculation
implicit none
! ============================================================================
! GEOMETRY-RELATED VARIABLES
! Main arrays
type(Cell), allocatable, target :: cells(:)
type(Universe), allocatable, target :: universes(:)
type(LatticeContainer), allocatable, target :: lattices(:)
type(SurfaceContainer), allocatable, target :: surfaces(:)
type(Material), allocatable, target :: materials(:)
type(ObjectPlot), allocatable, target :: plots(:)
type(VolumeCalculation), allocatable :: volume_calcs(:)
! Size of main arrays
integer(C_INT32_T), bind(C) :: n_cells ! # of cells
integer :: n_universes ! # of universes
integer :: n_lattices ! # of lattices
integer :: n_surfaces ! # of surfaces
integer(C_INT32_T), bind(C) :: n_materials ! # of materials
integer :: n_plots ! # of plots
! These dictionaries provide a fast lookup mechanism -- the key is the
! user-specified identifier and the value is the index in the corresponding
! array
type(DictIntInt) :: cell_dict
type(DictIntInt) :: universe_dict
type(DictIntInt) :: lattice_dict
type(DictIntInt) :: surface_dict
type(DictIntInt) :: material_dict
type(DictIntInt) :: mesh_dict
type(DictIntInt) :: filter_dict
type(DictIntInt) :: tally_dict
type(DictIntInt) :: plot_dict
! Number of lost particles
integer :: n_lost_particles
! ============================================================================
! ENERGY TREATMENT RELATED VARIABLES
logical :: run_CE = .true. ! Run in CE mode?
! ============================================================================
! CROSS SECTION RELATED VARIABLES NEEDED REGARDLESS OF CE OR MG
! Number of nuclide cross section tables
integer(C_INT), bind(C, name='n_nuclides') :: n_nuclides_total
! Cross section caches
type(NuclideMicroXS), allocatable :: micro_xs(:) ! Cache for each nuclide
type(MaterialMacroXS) :: material_xs ! Cache for current material
! Dictionaries to look up cross sections and listings
type(DictCharInt) :: nuclide_dict
type(DictCharInt) :: library_dict
! Cross section libraries
type(Library), allocatable :: libraries(:)
! ============================================================================
! CONTINUOUS-ENERGY CROSS SECTION RELATED VARIABLES
! Cross section arrays
type(Nuclide), allocatable, target :: nuclides(:) ! Nuclide cross-sections
type(SAlphaBeta), allocatable, target :: sab_tables(:) ! S(a,b) tables
integer :: n_sab_tables ! Number of S(a,b) thermal scattering tables
! Minimum/maximum energies
real(8) :: energy_min_neutron = ZERO
real(8) :: energy_max_neutron = INFINITY
! Dictionaries to look up cross sections and listings
type(DictCharInt) :: sab_dict
! Unreoslved resonance probablity tables
logical :: urr_ptables_on = .true.
! Default temperature and method for choosing temperatures
integer :: temperature_method = TEMPERATURE_NEAREST
logical :: temperature_multipole = .false.
real(8) :: temperature_tolerance = 10.0_8
real(8) :: temperature_default = 293.6_8
real(8) :: temperature_range(2) = [ZERO, ZERO]
integer :: n_log_bins ! number of bins for logarithmic grid
real(8) :: log_spacing ! spacing on logarithmic grid
! ============================================================================
! MULTI-GROUP CROSS SECTION RELATED VARIABLES
! Cross section arrays
type(MgxsContainer), allocatable, target :: nuclides_MG(:)
! Cross section caches
type(MgxsContainer), target, allocatable :: macro_xs(:)
! Number of energy groups
integer :: num_energy_groups
! Number of delayed groups
integer :: num_delayed_groups
! Energy group structure
real(8), allocatable :: energy_bins(:)
! Midpoint of the energy group structure
real(8), allocatable :: energy_bin_avg(:)
! Maximum Data Order
integer :: max_order
! Whether or not to convert Legendres to tabulars
logical :: legendre_to_tabular = .true.
! Number of points to use in the Legendre to tabular conversion
integer :: legendre_to_tabular_points = 33
! ============================================================================
! TALLY-RELATED VARIABLES
type(RegularMesh), allocatable, target :: meshes(:)
type(TallyObject), allocatable, target :: tallies(:)
type(TallyFilterContainer), allocatable, target :: filters(:)
type(TallyFilterMatch), allocatable :: filter_matches(:)
! Pointers for different tallies
type(TallyObject), pointer :: user_tallies(:) => null()
type(TallyObject), pointer :: cmfd_tallies(:) => null()
! Starting index (minus 1) in tallies for each tally group
integer :: i_user_tallies = -1
integer :: i_cmfd_tallies = -1
! Active tally lists
type(VectorInt) :: active_analog_tallies
type(VectorInt) :: active_tracklength_tallies
type(VectorInt) :: active_current_tallies
type(VectorInt) :: active_collision_tallies
type(VectorInt) :: active_tallies
type(VectorInt) :: active_surface_tallies
! Global tallies
! 1) collision estimate of k-eff
! 2) absorption estimate of k-eff
! 3) track-length estimate of k-eff
! 4) leakage fraction
real(C_DOUBLE), allocatable, target :: global_tallies(:,:)
! It is possible to protect accumulate operations on global tallies by using
! an atomic update. However, when multiple threads accumulate to the same
! global tally, it can cause a higher cache miss rate due to
! invalidation. Thus, we use threadprivate variables to accumulate global
! tallies and then reduce at the end of a generation.
real(8) :: global_tally_collision = ZERO
real(8) :: global_tally_absorption = ZERO
real(8) :: global_tally_tracklength = ZERO
real(8) :: global_tally_leakage = ZERO
!$omp threadprivate(global_tally_collision, global_tally_absorption, &
!$omp& global_tally_tracklength, global_tally_leakage)
integer :: n_meshes = 0 ! # of structured meshes
integer :: n_user_meshes = 0 ! # of structured user meshes
integer :: n_filters = 0 ! # of filters
integer :: n_user_filters = 0 ! # of user filters
integer(C_INT32_T), bind(C) :: n_tallies = 0 ! # of tallies
integer :: n_user_tallies = 0 ! # of user tallies
! Tally derivatives
type(TallyDerivative), allocatable :: tally_derivs(:)
!$omp threadprivate(tally_derivs)
! Normalization for statistics
integer :: n_realizations = 0 ! # of independent realizations
real(8) :: total_weight ! total starting particle weight in realization
! Flag for turning tallies on
logical :: tallies_on = .false.
logical :: active_batches = .false.
! Assume all tallies are spatially distinct
logical :: assume_separate = .false.
! Use confidence intervals for results instead of standard deviations
logical :: confidence_intervals = .false.
! ============================================================================
! EIGENVALUE SIMULATION VARIABLES
integer(8) :: n_particles = 0 ! # of particles per generation
integer :: n_batches ! # of batches
integer :: n_inactive ! # of inactive batches
integer :: n_active ! # of active batches
integer :: gen_per_batch = 1 ! # of generations per batch
integer :: current_batch ! current batch
integer :: current_gen ! current generation within a batch
integer :: total_gen = 0 ! total number of generations simulated
! ============================================================================
! TALLY PRECISION TRIGGER VARIABLES
integer :: n_max_batches ! max # of batches
integer :: n_batch_interval = 1 ! batch interval for triggers
logical :: pred_batches = .false. ! predict batches for triggers
logical :: trigger_on = .false. ! flag for turning triggers on/off
type(KTrigger) :: keff_trigger ! trigger for k-effective
logical :: satisfy_triggers = .false. ! whether triggers are satisfied
! External source
type(SourceDistribution), allocatable :: external_source(:)
! Source and fission bank
type(Bank), allocatable, target :: source_bank(:)
type(Bank), allocatable, target :: fission_bank(:)
#ifdef _OPENMP
type(Bank), allocatable, target :: master_fission_bank(:)
#endif
integer(8) :: n_bank ! # of sites in fission bank
integer(8) :: work ! number of particles per processor
integer(8), allocatable :: work_index(:) ! starting index in source bank for each process
integer(8) :: current_work ! index in source bank of current history simulated
! Temporary k-effective values
real(8), allocatable :: k_generation(:) ! single-generation estimates of k
real(8) :: keff = ONE ! average k over active batches
real(8) :: keff_std ! standard deviation of average k
real(8) :: k_col_abs = ZERO ! sum over batches of k_collision * k_absorption
real(8) :: k_col_tra = ZERO ! sum over batches of k_collision * k_tracklength
real(8) :: k_abs_tra = ZERO ! sum over batches of k_absorption * k_tracklength
! Shannon entropy
logical :: entropy_on = .false.
real(8), allocatable :: entropy(:) ! shannon entropy at each generation
real(8), allocatable :: entropy_p(:,:,:,:) ! % of source sites in each cell
type(RegularMesh), pointer :: entropy_mesh
! Uniform fission source weighting
logical :: ufs = .false.
type(RegularMesh), pointer :: ufs_mesh => null()
real(8), allocatable :: source_frac(:,:,:,:)
! Write source at end of simulation
logical :: source_separate = .false.
logical :: source_write = .true.
logical :: source_latest = .false.
! ============================================================================
! PARALLEL PROCESSING VARIABLES
#ifdef _OPENMP
integer :: n_threads = NONE ! number of OpenMP threads
integer :: thread_id ! ID of a given thread
#endif
! No reduction at end of batch
logical :: reduce_tallies = .true.
! ============================================================================
! TIMING VARIABLES
type(Timer) :: time_total ! timer for total run
type(Timer) :: time_initialize ! timer for initialization
type(Timer) :: time_read_xs ! timer for reading cross sections
type(Timer) :: time_unionize ! timer for material xs-energy grid union
type(Timer) :: time_bank ! timer for fission bank synchronization
type(Timer) :: time_bank_sample ! timer for fission bank sampling
type(Timer) :: time_bank_sendrecv ! timer for fission bank SEND/RECV
type(Timer) :: time_tallies ! timer for accumulate tallies
type(Timer) :: time_inactive ! timer for inactive batches
type(Timer) :: time_active ! timer for active batches
type(Timer) :: time_transport ! timer for transport only
type(Timer) :: time_finalize ! timer for finalization
! ===========================================================================
! VARIANCE REDUCTION VARIABLES
logical :: survival_biasing = .false.
real(8) :: weight_cutoff = 0.25_8
real(8) :: energy_cutoff = ZERO
real(8) :: weight_survive = ONE
! ============================================================================
! MISCELLANEOUS VARIABLES
! Mode to run in (fixed source, eigenvalue, plotting, etc)
integer :: run_mode = NONE
! Restart run
logical :: restart_run = .false.
integer :: restart_batch
character(MAX_FILE_LEN) :: path_input ! Path to input file
character(MAX_FILE_LEN) :: path_cross_sections = '' ! Path to cross_sections.xml
character(MAX_FILE_LEN) :: path_multipole ! Path to wmp library
character(MAX_FILE_LEN) :: path_source = '' ! Path to binary source
character(MAX_FILE_LEN) :: path_state_point ! Path to binary state point
character(MAX_FILE_LEN) :: path_source_point ! Path to binary source point
character(MAX_FILE_LEN) :: path_particle_restart ! Path to particle restart
character(MAX_FILE_LEN) :: path_output = '' ! Path to output directory
! The verbosity controls how much information will be printed to the
! screen and in logs
integer :: verbosity = 7
! Flag for enabling cell overlap checking during transport
logical :: check_overlaps = .false.
integer(8), allocatable :: overlap_check_cnt(:)
! Trace for single particle
logical :: trace
integer :: trace_batch
integer :: trace_gen
integer(8) :: trace_particle
! Particle tracks
logical :: write_all_tracks = .false.
integer, allocatable :: track_identifiers(:,:)
! Particle restart run
logical :: particle_restart_run = .false.
! Number of distribcell maps
integer :: n_maps
! Write out initial source
logical :: write_initial_source = .false.
! Whether create fission neutrons or not. Only applied for MODE_FIXEDSOURCE
logical :: create_fission_neutrons = .true.
! ============================================================================
! CMFD VARIABLES
! Main object
type(cmfd_type) :: cmfd
! Is CMFD active
logical :: cmfd_run = .false.
! Timing objects
type(Timer) :: time_cmfd ! timer for whole cmfd calculation
type(Timer) :: time_cmfdbuild ! timer for matrix build
type(Timer) :: time_cmfdsolve ! timer for solver
! Flag for active core map
logical :: cmfd_coremap = .false.
! Flag to reset dhats to zero
logical :: dhat_reset = .false.
! Flag to activate neutronic feedback via source weights
logical :: cmfd_feedback = .false.
! User-defined tally information
integer :: n_cmfd_meshes = 1 ! # of structured meshes
integer :: n_cmfd_filters = 0 ! # of filters
integer :: n_cmfd_tallies = 3 ! # of user-defined tallies
! Adjoint method type
character(len=10) :: cmfd_adjoint_type = 'physical'
! Number of incomplete ilu factorization levels
integer :: cmfd_ilu_levels = 1
! Batch to begin cmfd
integer :: cmfd_begin = 1
! Tally reset list
integer :: n_cmfd_resets
type(SetInt) :: cmfd_reset
! Compute effective downscatter cross section
logical :: cmfd_downscatter = .false.
! Convergence monitoring
logical :: cmfd_power_monitor = .false.
! Cmfd output
logical :: cmfd_write_matrices = .false.
! Run an adjoint calculation (last batch only)
logical :: cmfd_run_adjoint = .false.
! CMFD run logicals
logical :: cmfd_on = .false.
! CMFD display info
character(len=25) :: cmfd_display = 'balance'
! Estimate of spectral radius of CMFD matrices and tolerances
real(8) :: cmfd_spectral = ZERO
real(8) :: cmfd_shift = 1.e6
real(8) :: cmfd_ktol = 1.e-8_8
real(8) :: cmfd_stol = 1.e-8_8
real(8) :: cmfd_atoli = 1.e-10_8
real(8) :: cmfd_rtoli = 1.e-5_8
! Information about state points to be written
integer :: n_state_points = 0
type(SetInt) :: statepoint_batch
! Information about source points to be written
integer :: n_source_points = 0
type(SetInt) :: sourcepoint_batch
! Various output options
logical :: output_summary = .true.
logical :: output_tallies = .true.
! ============================================================================
! RESONANCE SCATTERING VARIABLES
logical :: res_scat_on = .false. ! is resonance scattering treated?
integer :: res_scat_method = RES_SCAT_ARES ! resonance scattering method
real(8) :: res_scat_energy_min = 0.01_8
real(8) :: res_scat_energy_max = 1000.0_8
character(10), allocatable :: res_scat_nuclides(:)
!$omp threadprivate(micro_xs, material_xs, fission_bank, n_bank, &
!$omp& trace, thread_id, current_work, filter_matches)
contains
!===============================================================================
! FREE_MEMORY deallocates and clears all global allocatable arrays in the
! program
!===============================================================================
subroutine free_memory()
integer :: i ! Loop Index
! Deallocate cells, surfaces, materials
if (allocated(cells)) deallocate(cells)
if (allocated(universes)) deallocate(universes)
if (allocated(lattices)) deallocate(lattices)
if (allocated(surfaces)) deallocate(surfaces)
if (allocated(materials)) deallocate(materials)
if (allocated(plots)) deallocate(plots)
if (allocated(volume_calcs)) deallocate(volume_calcs)
! Deallocate geometry debugging information
if (allocated(overlap_check_cnt)) deallocate(overlap_check_cnt)
! Deallocate cross section data, listings, and cache
if (allocated(nuclides)) then
! First call the clear routines
do i = 1, size(nuclides)
call nuclides(i) % clear()
end do
deallocate(nuclides)
end if
if (allocated(libraries)) deallocate(libraries)
if (allocated(res_scat_nuclides)) deallocate(res_scat_nuclides)
if (allocated(nuclides_MG)) deallocate(nuclides_MG)
if (allocated(macro_xs)) deallocate(macro_xs)
if (allocated(sab_tables)) deallocate(sab_tables)
! Deallocate external source
if (allocated(external_source)) deallocate(external_source)
! Deallocate k and entropy
if (allocated(k_generation)) deallocate(k_generation)
if (allocated(entropy)) deallocate(entropy)
if (allocated(entropy_p)) deallocate(entropy_p)
! Deallocate tally-related arrays
if (allocated(global_tallies)) deallocate(global_tallies)
if (allocated(meshes)) deallocate(meshes)
if (allocated(filters)) deallocate(filters)
if (allocated(tallies)) deallocate(tallies)
! Deallocate fission and source bank and entropy
!$omp parallel
if (allocated(fission_bank)) deallocate(fission_bank)
if (allocated(filter_matches)) deallocate(filter_matches)
if (allocated(tally_derivs)) deallocate(tally_derivs)
!$omp end parallel
#ifdef _OPENMP
if (allocated(master_fission_bank)) deallocate(master_fission_bank)
#endif
if (allocated(source_bank)) deallocate(source_bank)
! Deallocate array of work indices
if (allocated(work_index)) deallocate(work_index)
if (allocated(energy_bins)) deallocate(energy_bins)
if (allocated(energy_bin_avg)) deallocate(energy_bin_avg)
! Deallocate CMFD
call deallocate_cmfd(cmfd)
! Deallocate tally node lists
call active_analog_tallies % clear()
call active_tracklength_tallies % clear()
call active_current_tallies % clear()
call active_collision_tallies % clear()
call active_surface_tallies % clear()
call active_tallies % clear()
! Deallocate track_identifiers
if (allocated(track_identifiers)) deallocate(track_identifiers)
! Deallocate dictionaries
call cell_dict % clear()
call universe_dict % clear()
call lattice_dict % clear()
call surface_dict % clear()
call material_dict % clear()
call mesh_dict % clear()
call filter_dict % clear()
call tally_dict % clear()
call plot_dict % clear()
call nuclide_dict % clear()
call sab_dict % clear()
call library_dict % clear()
! Clear statepoint and sourcepoint batch set
call statepoint_batch % clear()
call sourcepoint_batch % clear()
! Deallocate entropy mesh
if (associated(entropy_mesh)) then
if (allocated(entropy_mesh % lower_left)) &
deallocate(entropy_mesh % lower_left)
if (allocated(entropy_mesh % upper_right)) &
deallocate(entropy_mesh % upper_right)
if (allocated(entropy_mesh % width)) deallocate(entropy_mesh % width)
deallocate(entropy_mesh)
end if
! Deallocate ufs
if (allocated(source_frac)) deallocate(source_frac)
if (associated(ufs_mesh)) then
if (allocated(ufs_mesh % lower_left)) deallocate(ufs_mesh % lower_left)
if (allocated(ufs_mesh % upper_right)) &
deallocate(ufs_mesh % upper_right)
if (allocated(ufs_mesh % width)) deallocate(ufs_mesh % width)
deallocate(ufs_mesh)
end if
end subroutine free_memory
!===============================================================================
! OVERALL_GENERATION determines the overall generation number
!===============================================================================
pure function overall_generation() result(gen)
integer :: gen
gen = gen_per_batch*(current_batch - 1) + current_gen
end function overall_generation
end module global

530
src/initialize.F90
View file

@ -12,27 +12,24 @@ module initialize
use dict_header, only: DictIntInt, ElemKeyValueII
use set_header, only: SetInt
use error, only: fatal_error, warning
use geometry, only: neighbor_lists, count_instance, calc_offsets, &
maximum_levels
use geometry_header, only: Cell, Universe, Lattice, RectLattice, HexLattice,&
root_universe
use global
use hdf5_interface, only: file_open, read_attribute, file_close, &
hdf5_bank_t, hdf5_integer8_t
use input_xml, only: read_input_xml, read_plots_xml
use input_xml, only: read_input_xml
use material_header, only: Material
use message_passing
use mgxs_data, only: read_mgxs, create_macro_xs
use output, only: print_version, write_message, print_usage, &
print_plot
use output, only: print_version, write_message, print_usage
use random_lcg, only: initialize_prng
use state_point, only: load_state_point
use settings
#ifdef _OPENMP
use simulation_header, only: n_threads
#endif
use string, only: to_str, starts_with, ends_with, str_to_int
use summary, only: write_summary
use tally_header, only: TallyObject
use tally_initialize,only: configure_tallies
use tally_filter
use tally, only: init_tally_routines
use timer_header
implicit none
@ -84,75 +81,16 @@ contains
! Read command line arguments
call read_command_line()
! Initialize random number generator -- if the user specifies a seed, it
! will be re-initialized later
call initialize_prng()
! Read XML input files
call read_input_xml()
! Initialize random number generator -- this has to be done after the input
! files have been read in case the user specified a seed for the random
! number generator
call initialize_prng()
! Read plots.xml if it exists -- this has to be done separate from the other
! XML files because we need the PRNG to be initialized first
if (run_mode == MODE_PLOTTING) call read_plots_xml()
! Use dictionaries to redefine index pointers
call adjust_indices()
! Initialize distribcell_filters
call prepare_distribcell()
! After reading input and basic geometry setup is complete, build lists of
! neighboring cells for efficient tracking
call neighbor_lists()
! Check to make sure there are not too many nested coordinate levels in the
! geometry since the coordinate list is statically allocated for performance
! reasons
if (maximum_levels(universes(root_universe)) > MAX_COORD) then
call fatal_error("Too many nested coordinate levels in the geometry. &
&Try increasing the maximum number of coordinate levels by &
&providing the CMake -Dmaxcoord= option.")
end if
if (run_mode /= MODE_PLOTTING) then
! Allocate and setup tally stride, filter_matches, and tally maps
call configure_tallies()
! Set up tally procedure pointers
call init_tally_routines()
! Determine how much work each processor should do
call calculate_work()
! Allocate source bank, and for eigenvalue simulations also allocate the
! fission bank
call allocate_banks()
! If this is a restart run, load the state point data and binary source
! file
if (restart_run) call load_state_point()
end if
if (master) then
if (run_mode == MODE_PLOTTING) then
! Display plotting information
if (verbosity >= 5) call print_plot()
else
! Write summary information
if (output_summary) call write_summary()
end if
end if
! Check for particle restart run
if (particle_restart_run) run_mode = MODE_PARTICLE
! Warn if overlap checking is on
if (master .and. check_overlaps .and. run_mode /= MODE_PLOTTING) then
call warning("Cell overlap checking is ON.")
end if
! Stop initialization timer
call time_initialize%stop()
@ -424,450 +362,4 @@ contains
end subroutine read_command_line
!===============================================================================
! ADJUST_INDICES changes the values for 'surfaces' for each cell and the
! material index assigned to each to the indices in the surfaces and material
! array rather than the unique IDs assigned to each surface and material. Also
! assigns boundary conditions to surfaces based on those read into the bc_dict
! dictionary
!===============================================================================
subroutine adjust_indices()
integer :: i ! index for various purposes
integer :: j ! index for various purposes
integer :: k ! loop index for lattices
integer :: m ! loop index for lattices
integer :: lid ! lattice IDs
integer :: i_array ! index in surfaces/materials array
integer :: id ! user-specified id
type(Cell), pointer :: c => null()
class(Lattice), pointer :: lat => null()
do i = 1, n_cells
! =======================================================================
! ADJUST REGION SPECIFICATION FOR EACH CELL
c => cells(i)
do j = 1, size(c%region)
id = c%region(j)
! Make sure that only regions are checked. Since OP_UNION is the
! operator with the lowest integer value, anything below it must denote
! a half-space
if (id < OP_UNION) then
if (surface_dict%has_key(abs(id))) then
i_array = surface_dict%get_key(abs(id))
c%region(j) = sign(i_array, id)
else
call fatal_error("Could not find surface " // trim(to_str(abs(id)))&
&// " specified on cell " // trim(to_str(c%id)))
end if
end if
end do
! Also adjust the indices in the reverse Polish notation
do j = 1, size(c%rpn)
id = c%rpn(j)
! Again, make sure that only regions are checked
if (id < OP_UNION) then
i_array = surface_dict%get_key(abs(id))
c%rpn(j) = sign(i_array, id)
end if
end do
! =======================================================================
! ADJUST UNIVERSE INDEX FOR EACH CELL
id = c%universe
if (universe_dict%has_key(id)) then
c%universe = universe_dict%get_key(id)
else
call fatal_error("Could not find universe " // trim(to_str(id)) &
&// " specified on cell " // trim(to_str(c%id)))
end if
! =======================================================================
! ADJUST MATERIAL/FILL POINTERS FOR EACH CELL
if (c % material(1) == NONE) then
id = c % fill
if (universe_dict % has_key(id)) then
c % type = FILL_UNIVERSE
c % fill = universe_dict % get_key(id)
elseif (lattice_dict % has_key(id)) then
lid = lattice_dict % get_key(id)
c % type = FILL_LATTICE
c % fill = lid
else
call fatal_error("Specified fill " // trim(to_str(id)) // " on cell "&
// trim(to_str(c % id)) // " is neither a universe nor a &
&lattice.")
end if
else
do j = 1, size(c % material)
id = c % material(j)
if (id == MATERIAL_VOID) then
c % type = FILL_MATERIAL
else if (material_dict % has_key(id)) then
c % type = FILL_MATERIAL
c % material(j) = material_dict % get_key(id)
else
call fatal_error("Could not find material " // trim(to_str(id)) &
// " specified on cell " // trim(to_str(c % id)))
end if
end do
end if
end do
! ==========================================================================
! ADJUST UNIVERSE INDICES FOR EACH LATTICE
do i = 1, n_lattices
lat => lattices(i)%obj
select type (lat)
type is (RectLattice)
do m = 1, lat%n_cells(3)
do k = 1, lat%n_cells(2)
do j = 1, lat%n_cells(1)
id = lat%universes(j,k,m)
if (universe_dict%has_key(id)) then
lat%universes(j,k,m) = universe_dict%get_key(id)
else
call fatal_error("Invalid universe number " &
&// trim(to_str(id)) // " specified on lattice " &
&// trim(to_str(lat%id)))
end if
end do
end do
end do
type is (HexLattice)
do m = 1, lat%n_axial
do k = 1, 2*lat%n_rings - 1
do j = 1, 2*lat%n_rings - 1
if (j + k < lat%n_rings + 1) then
cycle
else if (j + k > 3*lat%n_rings - 1) then
cycle
end if
id = lat%universes(j, k, m)
if (universe_dict%has_key(id)) then
lat%universes(j, k, m) = universe_dict%get_key(id)
else
call fatal_error("Invalid universe number " &
&// trim(to_str(id)) // " specified on lattice " &
&// trim(to_str(lat%id)))
end if
end do
end do
end do
end select
if (lat%outer /= NO_OUTER_UNIVERSE) then
if (universe_dict%has_key(lat%outer)) then
lat%outer = universe_dict%get_key(lat%outer)
else
call fatal_error("Invalid universe number " &
&// trim(to_str(lat%outer)) &
&// " specified on lattice " // trim(to_str(lat%id)))
end if
end if
end do
! =======================================================================
! ADJUST INDICES FOR EACH TALLY FILTER
FILTER_LOOP: do i = 1, n_filters
select type(filt => filters(i) % obj)
type is (SurfaceFilter)
! Check if this is a surface filter only for surface currents
if (.not. filt % current) call filt % initialize()
class default
call filt % initialize()
end select
end do FILTER_LOOP
end subroutine adjust_indices
!===============================================================================
! CALCULATE_WORK determines how many particles each processor should simulate
!===============================================================================
subroutine calculate_work()
integer :: i ! loop index
integer :: remainder ! Number of processors with one extra particle
integer(8) :: i_bank ! Running count of number of particles
integer(8) :: min_work ! Minimum number of particles on each proc
integer(8) :: work_i ! Number of particles on rank i
allocate(work_index(0:n_procs))
! Determine minimum amount of particles to simulate on each processor
min_work = n_particles/n_procs
! Determine number of processors that have one extra particle
remainder = int(mod(n_particles, int(n_procs,8)), 4)
i_bank = 0
work_index(0) = 0
do i = 0, n_procs - 1
! Number of particles for rank i
if (i < remainder) then
work_i = min_work + 1
else
work_i = min_work
end if
! Set number of particles
if (rank == i) work = work_i
! Set index into source bank for rank i
i_bank = i_bank + work_i
work_index(i+1) = i_bank
end do
end subroutine calculate_work
!===============================================================================
! ALLOCATE_BANKS allocates memory for the fission and source banks
!===============================================================================
subroutine allocate_banks()
integer :: alloc_err ! allocation error code
! Allocate source bank
allocate(source_bank(work), STAT=alloc_err)
! Check for allocation errors
if (alloc_err /= 0) then
call fatal_error("Failed to allocate source bank.")
end if
if (run_mode == MODE_EIGENVALUE) then
#ifdef _OPENMP
! If OpenMP is being used, each thread needs its own private fission
! bank. Since the private fission banks need to be combined at the end of
! a generation, there is also a 'master_fission_bank' that is used to
! collect the sites from each thread.
n_threads = omp_get_max_threads()
!$omp parallel
thread_id = omp_get_thread_num()
if (thread_id == 0) then
allocate(fission_bank(3*work))
else
allocate(fission_bank(3*work/n_threads))
end if
!$omp end parallel
allocate(master_fission_bank(3*work), STAT=alloc_err)
#else
allocate(fission_bank(3*work), STAT=alloc_err)
#endif
! Check for allocation errors
if (alloc_err /= 0) then
call fatal_error("Failed to allocate fission bank.")
end if
end if
end subroutine allocate_banks
!===============================================================================
! PREPARE_DISTRIBCELL initializes any distribcell filters present and sets the
! offsets for distribcells
!===============================================================================
subroutine prepare_distribcell()
integer :: i, j ! Tally, filter loop counters
logical :: distribcell_active ! Does simulation use distribcell?
integer, allocatable :: univ_list(:) ! Target offsets
integer, allocatable :: counts(:,:) ! Target count
logical, allocatable :: found(:,:) ! Target found
! Assume distribcell is not needed until proven otherwise.
distribcell_active = .false.
! We need distribcell if any tallies have distribcell filters.
do i = 1, n_tallies
do j = 1, size(tallies(i) % filter)
select type(filt => filters(tallies(i) % filter(j)) % obj)
type is (DistribcellFilter)
distribcell_active = .true.
end select
end do
end do
! We also need distribcell if any distributed materials or distributed
! temperatues are present.
if (.not. distribcell_active) then
do i = 1, n_cells
if (size(cells(i) % material) > 1 .or. size(cells(i) % sqrtkT) > 1) then
distribcell_active = .true.
exit
end if
end do
end if
! If distribcell isn't used in this simulation then no more work left to do.
if (.not. distribcell_active) return
! Count the number of instances of each cell.
call count_instance(universes(root_universe))
! Set the number of bins in all distribcell filters.
do i = 1, n_tallies
do j = 1, size(tallies(i) % filter)
select type(filt => filters(tallies(i) % filter(j)) % obj)
type is (DistribcellFilter)
! Set the number of bins to the number of instances of the cell.
filt % n_bins = cells(filt % cell) % instances
end select
end do
end do
! Make sure the number of materials and temperatures matches the number of
! cell instances.
do i = 1, n_cells
associate (c => cells(i))
if (size(c % material) > 1) then
if (size(c % material) /= c % instances) then
call fatal_error("Cell " // trim(to_str(c % id)) // " was &
&specified with " // trim(to_str(size(c % material))) &
// " materials but has " // trim(to_str(c % instances)) &
// " distributed instances. The number of materials must &
&equal one or the number of instances.")
end if
end if
if (size(c % sqrtkT) > 1) then
if (size(c % sqrtkT) /= c % instances) then
call fatal_error("Cell " // trim(to_str(c % id)) // " was &
&specified with " // trim(to_str(size(c % sqrtkT))) &
// " temperatures but has " // trim(to_str(c % instances)) &
// " distributed instances. The number of temperatures must &
&equal one or the number of instances.")
end if
end if
end associate
end do
! Allocate offset maps at each level in the geometry
call allocate_offsets(univ_list, counts, found)
! Calculate offsets for each target distribcell
do i = 1, n_maps
do j = 1, n_universes
call calc_offsets(univ_list(i), i, universes(j), counts, found)
end do
end do
end subroutine prepare_distribcell
!===============================================================================
! ALLOCATE_OFFSETS determines the number of maps needed and allocates required
! memory for distribcell offset tables
!===============================================================================
recursive subroutine allocate_offsets(univ_list, counts, found)
integer, intent(out), allocatable :: univ_list(:) ! Target offsets
integer, intent(out), allocatable :: counts(:,:) ! Target count
logical, intent(out), allocatable :: found(:,:) ! Target found
integer :: i, j, k ! Loop counters
type(SetInt) :: cell_list ! distribells to track
! Begin gathering list of cells in distribcell tallies
n_maps = 0
! List all cells referenced in distribcell filters.
do i = 1, n_tallies
do j = 1, size(tallies(i) % filter)
select type(filt => filters(tallies(i) % filter(j)) % obj)
type is (DistribcellFilter)
call cell_list % add(filt % cell)
end select
end do
end do
! List all cells with multiple (distributed) materials or temperatures.
do i = 1, n_cells
if (size(cells(i) % material) > 1 .or. size(cells(i) % sqrtkT) > 1) then
call cell_list % add(i)
end if
end do
! Compute the number of unique universes containing these distribcells
! to determine the number of offset tables to allocate
do i = 1, n_universes
do j = 1, size(universes(i) % cells)
if (cell_list % contains(universes(i) % cells(j))) then
n_maps = n_maps + 1
end if
end do
end do
! Allocate the list of offset tables for each unique universe
allocate(univ_list(n_maps))
! Allocate list to accumulate target distribcell counts in each universe
allocate(counts(n_universes, n_maps))
counts(:,:) = 0
! Allocate list to track if target distribcells are found in each universe
allocate(found(n_universes, n_maps))
found(:,:) = .false.
! Search through universes for distributed cells and assign each one a
! unique distribcell array index.
k = 1
do i = 1, n_universes
do j = 1, size(universes(i) % cells)
if (cell_list % contains(universes(i) % cells(j))) then
cells(universes(i) % cells(j)) % distribcell_index = k
univ_list(k) = universes(i) % id
k = k + 1
end if
end do
end do
! Allocate the offset tables for lattices
do i = 1, n_lattices
associate(lat => lattices(i) % obj)
select type(lat)
type is (RectLattice)
allocate(lat % offset(n_maps, lat % n_cells(1), lat % n_cells(2), &
lat % n_cells(3)))
type is (HexLattice)
allocate(lat % offset(n_maps, 2 * lat % n_rings - 1, &
2 * lat % n_rings - 1, lat % n_axial))
end select
lat % offset(:, :, :, :) = 0
end associate
end do
! Allocate offset table for fill cells
do i = 1, n_cells
if (cells(i) % type /= FILL_MATERIAL) then
allocate(cells(i) % offset(n_maps))
end if
end do
! Free up memory
call cell_list % clear()
end subroutine allocate_offsets
end module initialize

2270
src/input_xml.F90
View file

File diff suppressed because it is too large Load diff

2
src/main.F90
View file

@ -1,11 +1,11 @@
program main
use constants
use global
use message_passing
use openmc_api, only: openmc_init, openmc_finalize, openmc_run, &
openmc_plot_geometry, openmc_calculate_volumes
use particle_restart, only: run_particle_restart
use settings, only: run_mode
implicit none

312
src/material_header.F90
View file

@ -1,22 +1,36 @@
module material_header
use, intrinsic :: ISO_C_BINDING
use constants
use error, only: fatal_error
use nuclide_header, only: Nuclide
use sab_header, only: SAlphaBeta
use dict_header, only: DictIntInt
use error
use nuclide_header
use sab_header
use stl_vector, only: VectorReal, VectorInt
use string, only: to_str
implicit none
private
public :: free_memory_material
public :: openmc_extend_materials
public :: openmc_get_material_index
public :: openmc_material_add_nuclide
public :: openmc_material_get_id
public :: openmc_material_get_densities
public :: openmc_material_set_density
public :: openmc_material_set_densities
public :: openmc_material_set_id
!===============================================================================
! MATERIAL describes a material by its constituent nuclides
!===============================================================================
type Material
type, public :: Material
integer :: id ! unique identifier
character(len=104) :: name = "" ! User-defined name
integer :: n_nuclides ! number of nuclides
integer :: n_nuclides = 0 ! number of nuclides
integer, allocatable :: nuclide(:) ! index in nuclides array
real(8) :: density ! total atom density in atom/b-cm
real(8), allocatable :: atom_density(:) ! nuclide atom density in atom/b-cm
@ -51,23 +65,28 @@ module material_header
procedure :: assign_sab_tables => material_assign_sab_tables
end type Material
integer(C_INT32_T), public, bind(C) :: n_materials ! # of materials
type(Material), public, allocatable, target :: materials(:)
! Dictionary that maps user IDs to indices in 'materials'
type(DictIntInt), public :: material_dict
contains
!===============================================================================
! MATERIAL_SET_DENSITY sets the total density of a material in atom/b-cm.
!===============================================================================
function material_set_density(m, density, nuclides) result(err)
function material_set_density(m, density) result(err)
class(Material), intent(inout) :: m
real(8), intent(in) :: density
type(Nuclide), intent(in) :: nuclides(:)
integer :: err
integer :: i
real(8) :: sum_percent
real(8) :: awr
err = -1
if (allocated(m % atom_density)) then
! Set total density based on value provided
m % density = density
@ -87,6 +106,9 @@ contains
+ m % atom_density(i) * awr * MASS_NEUTRON / N_AVOGADRO
end do
err = 0
else
err = E_ALLOCATE
call set_errmsg("Material atom density array hasn't been allocated.")
end if
end function material_set_density
@ -95,10 +117,8 @@ contains
! materials so the code knows when to apply bound thermal scattering data
!===============================================================================
subroutine material_assign_sab_tables(this, nuclides, sab_tables)
subroutine material_assign_sab_tables(this)
class(Material), intent(inout) :: this
type(Nuclide), intent(in) :: nuclides(:)
type(SAlphaBeta), intent(in) :: sab_tables(:)
integer :: j ! index over nuclides in material
integer :: k ! index over S(a,b) tables in material
@ -205,4 +225,274 @@ contains
if (allocated(this % names)) deallocate(this % names)
end subroutine material_assign_sab_tables
!===============================================================================
! FREE_MEMORY_MATERIAL deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_material()
n_materials = 0
if (allocated(materials)) deallocate(materials)
call material_dict % clear()
end subroutine free_memory_material
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_extend_materials(n, index_start, index_end) result(err) bind(C)
! Extend the materials array by n elements
integer(C_INT32_T), value, intent(in) :: n
integer(C_INT32_T), optional, intent(out) :: index_start
integer(C_INT32_T), optional, intent(out) :: index_end
integer(C_INT) :: err
type(Material), allocatable :: temp(:) ! temporary materials array
if (n_materials == 0) then
! Allocate materials array
allocate(materials(n))
else
! Allocate materials array with increased size
allocate(temp(n_materials + n))
! Move original materials to temporary array
temp(1:n_materials) = materials(:)
! Move allocation from temporary array
call move_alloc(FROM=temp, TO=materials)
end if
! Return indices in materials array
if (present(index_start)) index_start = n_materials + 1
if (present(index_end)) index_end = n_materials + n
n_materials = n_materials + n
err = 0
end function openmc_extend_materials
function openmc_get_material_index(id, index) result(err) bind(C)
! Returns the index in the materials array of a material with a given ID
integer(C_INT32_T), value :: id
integer(C_INT32_T), intent(out) :: index
integer(C_INT) :: err
if (allocated(materials)) then
if (material_dict % has_key(id)) then
index = material_dict % get_key(id)
err = 0
else
err = E_INVALID_ID
call set_errmsg("No material exists with ID=" // trim(to_str(id)) // ".")
end if
else
err = E_ALLOCATE
call set_errmsg("Memory has not been allocated for materials.")
end if
end function openmc_get_material_index
function openmc_material_add_nuclide(index, name, density) result(err) bind(C)
! Add a nuclide at a specified density in atom/b-cm to a material
integer(C_INT32_T), value, intent(in) :: index
character(kind=C_CHAR) :: name(*)
real(C_DOUBLE), value, intent(in) :: density
integer(C_INT) :: err
integer :: j, k, n
real(8) :: awr
integer, allocatable :: new_nuclide(:)
real(8), allocatable :: new_density(:)
logical, allocatable :: new_p0(:)
character(:), allocatable :: name_
name_ = to_f_string(name)
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(materials)) then
associate (m => materials(index))
! Check if nuclide is already in material
do j = 1, m % n_nuclides
k = m % nuclide(j)
if (nuclides(k) % name == name_) then
awr = nuclides(k) % awr
m % density = m % density + density - m % atom_density(j)
m % density_gpcc = m % density_gpcc + (density - &
m % atom_density(j)) * awr * MASS_NEUTRON / N_AVOGADRO
m % atom_density(j) = density
err = 0
end if
end do
! If nuclide wasn't found, extend nuclide/density arrays
if (err /= 0) then
! If nuclide hasn't been loaded, load it now
err = openmc_load_nuclide(name)
if (err == 0) then
! Extend arrays
n = m % n_nuclides
allocate(new_nuclide(n + 1))
if (n > 0) new_nuclide(1:n) = m % nuclide
call move_alloc(FROM=new_nuclide, TO=m % nuclide)
allocate(new_density(n + 1))
if (n > 0) new_density(1:n) = m % atom_density
call move_alloc(FROM=new_density, TO=m % atom_density)
allocate(new_p0(n + 1))
if (n > 0) new_p0(1:n) = m % p0
new_p0(n + 1) = .false.
call move_alloc(FROM=new_p0, TO=m % p0)
! Append new nuclide/density
k = nuclide_dict % get_key(to_lower(name_))
m % nuclide(n + 1) = k
m % atom_density(n + 1) = density
m % density = m % density + density
m % density_gpcc = m % density_gpcc + &
density * nuclides(k) % awr * MASS_NEUTRON / N_AVOGADRO
m % n_nuclides = n + 1
end if
end if
end associate
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in materials array is out of bounds.")
end if
end function openmc_material_add_nuclide
function openmc_material_get_densities(index, nuclides, densities, n) &
result(err) bind(C)
! returns an array of nuclide densities in a material
integer(C_INT32_T), value :: index
type(C_PTR), intent(out) :: nuclides
type(C_PTR), intent(out) :: densities
integer(C_INT), intent(out) :: n
integer(C_INT) :: err
if (index >= 1 .and. index <= size(materials)) then
associate (m => materials(index))
if (allocated(m % atom_density)) then
nuclides = C_LOC(m % nuclide(1))
densities = C_LOC(m % atom_density(1))
n = size(m % atom_density)
err = 0
else
err = E_ALLOCATE
call set_errmsg("Material atom density array has not been allocated.")
end if
end associate
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in materials array is out of bounds.")
end if
end function openmc_material_get_densities
function openmc_material_get_id(index, id) result(err) bind(C)
! returns the ID of a material
integer(C_INT32_T), value :: index
integer(C_INT32_T), intent(out) :: id
integer(C_INT) :: err
if (index >= 1 .and. index <= size(materials)) then
id = materials(index) % id
err = 0
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in materials array is out of bounds.")
end if
end function openmc_material_get_id
function openmc_material_set_id(index, id) result(err) bind(C)
! Set the ID of a material
integer(C_INT32_T), value, intent(in) :: index
integer(C_INT32_T), value, intent(in) :: id
integer(C_INT) :: err
if (index >= 1 .and. index <= n_materials) then
materials(index) % id = id
call material_dict % add_key(id, index)
err = 0
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in materials array is out of bounds.")
end if
end function openmc_material_set_id
function openmc_material_set_density(index, density) result(err) bind(C)
! Set the total density of a material in atom/b-cm
integer(C_INT32_T), value, intent(in) :: index
real(C_DOUBLE), value, intent(in) :: density
integer(C_INT) :: err
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(materials)) then
associate (m => materials(index))
err = m % set_density(density)
end associate
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in materials array is out of bounds.")
end if
end function openmc_material_set_density
function openmc_material_set_densities(index, n, name, density) result(err) bind(C)
! Sets the densities for a list of nuclides in a material. If the nuclides
! don't already exist in the material, they will be added
integer(C_INT32_T), value, intent(in) :: index
integer(C_INT), value, intent(in) :: n
type(C_PTR), intent(in) :: name(n)
real(C_DOUBLE), intent(in) :: density(n)
integer(C_INT) :: err
integer :: i
integer :: stat
character(C_CHAR), pointer :: string(:)
character(len=:, kind=C_CHAR), allocatable :: name_
if (index >= 1 .and. index <= size(materials)) then
associate (m => materials(index))
! If nuclide/density arrays are not correct size, reallocate
if (n /= m % n_nuclides) then
deallocate(m % nuclide, m % atom_density, m % p0, STAT=stat)
allocate(m % nuclide(n), m % atom_density(n), m % p0(n))
end if
do i = 1, n
! Convert C string to Fortran string
call c_f_pointer(name(i), string, [10])
name_ = to_lower(to_f_string(string))
if (.not. nuclide_dict % has_key(name_)) then
err = openmc_load_nuclide(string)
if (err < 0) return
end if
m % nuclide(i) = nuclide_dict % get_key(name_)
m % atom_density(i) = density(i)
end do
m % n_nuclides = n
! Set isotropic flags to flags
m % p0(:) = .false.
! Set total density to the sum of the vector
err = m % set_density(sum(density))
! Assign S(a,b) tables
call m % assign_sab_tables()
end associate
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in materials array is out of bounds.")
end if
end function openmc_material_set_densities
end module material_header

354
src/mesh.F90
View file

@ -1,8 +1,8 @@
module mesh
use algorithm, only: binary_search
use bank_header, only: bank
use constants
use global
use mesh_header
use message_passing
@ -10,116 +10,6 @@ module mesh
contains
!===============================================================================
! GET_MESH_BIN determines the tally bin for a particle in a structured mesh
!===============================================================================
pure subroutine get_mesh_bin(m, xyz, bin)
type(RegularMesh), intent(in) :: m ! mesh pointer
real(8), intent(in) :: xyz(:) ! coordinates
integer, intent(out) :: bin ! tally bin
integer :: n ! size of mesh
integer :: d ! mesh dimension index
integer :: ijk(3) ! indices in mesh
logical :: in_mesh ! was given coordinate in mesh at all?
! Get number of dimensions
n = m % n_dimension
! Loop over the dimensions of the mesh
do d = 1, n
! Check for cases where particle is outside of mesh
if (xyz(d) < m % lower_left(d)) then
bin = NO_BIN_FOUND
return
elseif (xyz(d) > m % upper_right(d)) then
bin = NO_BIN_FOUND
return
end if
end do
! Determine indices
call get_mesh_indices(m, xyz, ijk, in_mesh)
! Convert indices to bin
if (in_mesh) then
bin = mesh_indices_to_bin(m, ijk)
else
bin = NO_BIN_FOUND
end if
end subroutine get_mesh_bin
!===============================================================================
! GET_MESH_INDICES determines the indices of a particle in a structured mesh
!===============================================================================
pure subroutine get_mesh_indices(m, xyz, ijk, in_mesh)
type(RegularMesh), intent(in) :: m
real(8), intent(in) :: xyz(:) ! coordinates to check
integer, intent(out) :: ijk(:) ! indices in mesh
logical, intent(out) :: in_mesh ! were given coords in mesh?
! Find particle in mesh
ijk(:m % n_dimension) = ceiling((xyz(:m % n_dimension) - m % lower_left)/m % width)
! Determine if particle is in mesh
if (any(ijk(:m % n_dimension) < 1) .or. &
any(ijk(:m % n_dimension) > m % dimension)) then
in_mesh = .false.
else
in_mesh = .true.
end if
end subroutine get_mesh_indices
!===============================================================================
! MESH_INDICES_TO_BIN maps (i), (i,j), or (i,j,k) indices to a single bin number
! for use in a TallyObject results array
!===============================================================================
pure function mesh_indices_to_bin(m, ijk) result(bin)
type(RegularMesh), intent(in) :: m
integer, intent(in) :: ijk(:)
integer :: bin
if (m % n_dimension == 1) then
bin = ijk(1)
elseif (m % n_dimension == 2) then
bin = (ijk(2) - 1) * m % dimension(1) + ijk(1)
elseif (m % n_dimension == 3) then
bin = ((ijk(3) - 1) * m % dimension(2) + (ijk(2) - 1)) &
* m % dimension(1) + ijk(1)
end if
end function mesh_indices_to_bin
!===============================================================================
! BIN_TO_MESH_INDICES maps a single mesh bin from a TallyObject results array to
! (i), (i,j), or (i,j,k) indices
!===============================================================================
pure subroutine bin_to_mesh_indices(m, bin, ijk)
type(RegularMesh), intent(in) :: m
integer, intent(in) :: bin
integer, intent(out) :: ijk(:)
if (m % n_dimension == 1) then
ijk(1) = bin
else if (m % n_dimension == 2) then
ijk(1) = mod(bin - 1, m % dimension(1)) + 1
ijk(2) = (bin - 1)/m % dimension(1) + 1
else if (m % n_dimension == 3) then
ijk(1) = mod(bin - 1, m % dimension(1)) + 1
ijk(2) = mod(bin - 1, m % dimension(1) * m % dimension(2)) &
/ m % dimension(1) + 1
ijk(3) = (bin - 1)/(m % dimension(1) * m % dimension(2)) + 1
end if
end subroutine bin_to_mesh_indices
!===============================================================================
! COUNT_BANK_SITES determines the number of fission bank sites in each cell of a
! given mesh as well as an optional energy group structure. This can be used for
@ -130,28 +20,27 @@ contains
subroutine count_bank_sites(m, bank_array, cnt, energies, size_bank, &
sites_outside)
type(RegularMesh), pointer :: m ! mesh to count sites
type(RegularMesh), intent(in) :: m ! mesh to count sites
type(Bank), intent(in) :: bank_array(:) ! fission or source bank
real(8), intent(out) :: cnt(:,:,:,:) ! weight of sites in each
real(8), intent(out) :: cnt(:,:) ! weight of sites in each
! cell and energy group
real(8), intent(in), optional :: energies(:) ! energy grid to search
integer(8), intent(in), optional :: size_bank ! # of bank sites (on each proc)
logical, intent(inout), optional :: sites_outside ! were there sites outside mesh?
real(8), allocatable :: cnt_(:,:,:,:)
real(8), allocatable :: cnt_(:,:)
integer :: i ! loop index for local fission sites
integer :: n_sites ! size of bank array
integer :: ijk(3) ! indices on mesh
integer :: n ! number of energy groups / size
integer :: e_bin ! energy_bin
integer :: mesh_bin ! mesh bin
integer :: e_bin ! energy bin
#ifdef MPI
integer :: mpi_err ! MPI error code
#endif
logical :: in_mesh ! was single site outside mesh?
logical :: outside ! was any site outside mesh?
! initialize variables
allocate(cnt_(size(cnt,1), size(cnt,2), size(cnt,3), size(cnt,4)))
allocate(cnt_(size(cnt,1), size(cnt,2)))
cnt_ = ZERO
outside = .false.
@ -172,10 +61,10 @@ contains
! loop over fission sites and count how many are in each mesh box
FISSION_SITES: do i = 1, n_sites
! determine scoring bin for entropy mesh
call get_mesh_indices(m, bank_array(i) % xyz, ijk, in_mesh)
call m % get_bin(bank_array(i) % xyz, mesh_bin)
! if outside mesh, skip particle
if (.not. in_mesh) then
if (mesh_bin == NO_BIN_FOUND) then
outside = .true.
cycle
end if
@ -194,8 +83,7 @@ contains
end if
! add to appropriate mesh box
cnt_(e_bin,ijk(1),ijk(2),ijk(3)) = cnt_(e_bin,ijk(1),ijk(2),ijk(3)) + &
bank_array(i) % wgt
cnt_(e_bin, mesh_bin) = cnt_(e_bin, mesh_bin) + bank_array(i) % wgt
end do FISSION_SITES
#ifdef MPI
@ -215,226 +103,4 @@ contains
end subroutine count_bank_sites
!===============================================================================
! MESH_INTERSECTS determines if a line between xyz0 and xyz1 intersects the
! outer boundary of the given mesh. This is important for determining whether a
! track will score to a mesh tally.
!===============================================================================
pure function mesh_intersects_1d(m, xyz0, xyz1) result(intersects)
type(RegularMesh), intent(in) :: m
real(8), intent(in) :: xyz0(1)
real(8), intent(in) :: xyz1(1)
logical :: intersects
real(8) :: x0 ! track start point
real(8) :: x1 ! track end point
real(8) :: xm0 ! lower-left coordinates of mesh
real(8) :: xm1 ! upper-right coordinates of mesh
! Copy coordinates of starting point
x0 = xyz0(1)
! Copy coordinates of ending point
x1 = xyz1(1)
! Copy coordinates of mesh lower_left
xm0 = m % lower_left(1)
! Copy coordinates of mesh upper_right
xm1 = m % upper_right(1)
! Set default value for intersects
intersects = .false.
! Check if line intersects left surface
if ((x0 < xm0 .and. x1 > xm0) .or. (x0 > xm0 .and. x1 < xm0)) then
intersects = .true.
return
end if
! Check if line intersects right surface
if ((x0 < xm1 .and. x1 > xm1) .or. (x0 > xm1 .and. x1 < xm1)) then
intersects = .true.
return
end if
end function mesh_intersects_1d
pure function mesh_intersects_2d(m, xyz0, xyz1) result(intersects)
type(RegularMesh), intent(in) :: m
real(8), intent(in) :: xyz0(2)
real(8), intent(in) :: xyz1(2)
logical :: intersects
real(8) :: x0, y0 ! track start point
real(8) :: x1, y1 ! track end point
real(8) :: xi, yi ! track intersection point with mesh
real(8) :: xm0, ym0 ! lower-left coordinates of mesh
real(8) :: xm1, ym1 ! upper-right coordinates of mesh
! Copy coordinates of starting point
x0 = xyz0(1)
y0 = xyz0(2)
! Copy coordinates of ending point
x1 = xyz1(1)
y1 = xyz1(2)
! Copy coordinates of mesh lower_left
xm0 = m % lower_left(1)
ym0 = m % lower_left(2)
! Copy coordinates of mesh upper_right
xm1 = m % upper_right(1)
ym1 = m % upper_right(2)
! Set default value for intersects
intersects = .false.
! Check if line intersects left surface -- calculate the intersection point
! y
if ((x0 < xm0 .and. x1 > xm0) .or. (x0 > xm0 .and. x1 < xm0)) then
yi = y0 + (xm0 - x0) * (y1 - y0) / (x1 - x0)
if (yi >= ym0 .and. yi < ym1) then
intersects = .true.
return
end if
end if
! Check if line intersects back surface -- calculate the intersection point
! x
if ((y0 < ym0 .and. y1 > ym0) .or. (y0 > ym0 .and. y1 < ym0)) then
xi = x0 + (ym0 - y0) * (x1 - x0) / (y1 - y0)
if (xi >= xm0 .and. xi < xm1) then
intersects = .true.
return
end if
end if
! Check if line intersects right surface -- calculate the intersection
! point y
if ((x0 < xm1 .and. x1 > xm1) .or. (x0 > xm1 .and. x1 < xm1)) then
yi = y0 + (xm1 - x0) * (y1 - y0) / (x1 - x0)
if (yi >= ym0 .and. yi < ym1) then
intersects = .true.
return
end if
end if
! Check if line intersects front surface -- calculate the intersection point
! x
if ((y0 < ym1 .and. y1 > ym1) .or. (y0 > ym1 .and. y1 < ym1)) then
xi = x0 + (ym1 - y0) * (x1 - x0) / (y1 - y0)
if (xi >= xm0 .and. xi < xm1) then
intersects = .true.
return
end if
end if
end function mesh_intersects_2d
pure function mesh_intersects_3d(m, xyz0, xyz1) result(intersects)
type(RegularMesh), intent(in) :: m
real(8), intent(in) :: xyz0(3)
real(8), intent(in) :: xyz1(3)
logical :: intersects
real(8) :: x0, y0, z0 ! track start point
real(8) :: x1, y1, z1 ! track end point
real(8) :: xi, yi, zi ! track intersection point with mesh
real(8) :: xm0, ym0, zm0 ! lower-left coordinates of mesh
real(8) :: xm1, ym1, zm1 ! upper-right coordinates of mesh
! Copy coordinates of starting point
x0 = xyz0(1)
y0 = xyz0(2)
z0 = xyz0(3)
! Copy coordinates of ending point
x1 = xyz1(1)
y1 = xyz1(2)
z1 = xyz1(3)
! Copy coordinates of mesh lower_left
xm0 = m % lower_left(1)
ym0 = m % lower_left(2)
zm0 = m % lower_left(3)
! Copy coordinates of mesh upper_right
xm1 = m % upper_right(1)
ym1 = m % upper_right(2)
zm1 = m % upper_right(3)
! Set default value for intersects
intersects = .false.
! Check if line intersects left surface -- calculate the intersection point
! (y,z)
if ((x0 < xm0 .and. x1 > xm0) .or. (x0 > xm0 .and. x1 < xm0)) then
yi = y0 + (xm0 - x0) * (y1 - y0) / (x1 - x0)
zi = z0 + (xm0 - x0) * (z1 - z0) / (x1 - x0)
if (yi >= ym0 .and. yi < ym1 .and. zi >= zm0 .and. zi < zm1) then
intersects = .true.
return
end if
end if
! Check if line intersects back surface -- calculate the intersection point
! (x,z)
if ((y0 < ym0 .and. y1 > ym0) .or. (y0 > ym0 .and. y1 < ym0)) then
xi = x0 + (ym0 - y0) * (x1 - x0) / (y1 - y0)
zi = z0 + (ym0 - y0) * (z1 - z0) / (y1 - y0)
if (xi >= xm0 .and. xi < xm1 .and. zi >= zm0 .and. zi < zm1) then
intersects = .true.
return
end if
end if
! Check if line intersects bottom surface -- calculate the intersection
! point (x,y)
if ((z0 < zm0 .and. z1 > zm0) .or. (z0 > zm0 .and. z1 < zm0)) then
xi = x0 + (zm0 - z0) * (x1 - x0) / (z1 - z0)
yi = y0 + (zm0 - z0) * (y1 - y0) / (z1 - z0)
if (xi >= xm0 .and. xi < xm1 .and. yi >= ym0 .and. yi < ym1) then
intersects = .true.
return
end if
end if
! Check if line intersects right surface -- calculate the intersection point
! (y,z)
if ((x0 < xm1 .and. x1 > xm1) .or. (x0 > xm1 .and. x1 < xm1)) then
yi = y0 + (xm1 - x0) * (y1 - y0) / (x1 - x0)
zi = z0 + (xm1 - x0) * (z1 - z0) / (x1 - x0)
if (yi >= ym0 .and. yi < ym1 .and. zi >= zm0 .and. zi < zm1) then
intersects = .true.
return
end if
end if
! Check if line intersects front surface -- calculate the intersection point
! (x,z)
if ((y0 < ym1 .and. y1 > ym1) .or. (y0 > ym1 .and. y1 < ym1)) then
xi = x0 + (ym1 - y0) * (x1 - x0) / (y1 - y0)
zi = z0 + (ym1 - y0) * (z1 - z0) / (y1 - y0)
if (xi >= xm0 .and. xi < xm1 .and. zi >= zm0 .and. zi < zm1) then
intersects = .true.
return
end if
end if
! Check if line intersects top surface -- calculate the intersection point
! (x,y)
if ((z0 < zm1 .and. z1 > zm1) .or. (z0 > zm1 .and. z1 < zm1)) then
xi = x0 + (zm1 - z0) * (x1 - x0) / (z1 - z0)
yi = y0 + (zm1 - z0) * (y1 - y0) / (z1 - z0)
if (xi >= xm0 .and. xi < xm1 .and. yi >= ym0 .and. yi < ym1) then
intersects = .true.
return
end if
end if
end function mesh_intersects_3d
end module mesh

578
src/mesh_header.F90
View file

@ -1,14 +1,28 @@
module mesh_header
use, intrinsic :: ISO_C_BINDING
use hdf5
use constants
use dict_header, only: DictIntInt
use error, only: warning, fatal_error
use hdf5_interface
use string, only: to_str, to_lower
use xml_interface
implicit none
private
public :: free_memory_mesh
public :: openmc_extend_meshes
!===============================================================================
! STRUCTUREDMESH represents a tessellation of n-dimensional Euclidean space by
! congruent squares or cubes
!===============================================================================
type RegularMesh
integer :: id ! user-specified id
type, public :: RegularMesh
integer :: id = -1 ! user-specified id
integer :: type ! rectangular, hexagonal
integer :: n_dimension ! rank of mesh
real(8) :: volume_frac ! volume fraction of each cell
@ -16,6 +30,566 @@ module mesh_header
real(8), allocatable :: lower_left(:) ! lower-left corner of mesh
real(8), allocatable :: upper_right(:) ! upper-right corner of mesh
real(8), allocatable :: width(:) ! width of each mesh cell
contains
procedure :: from_xml => regular_from_xml
procedure :: get_bin => regular_get_bin
procedure :: get_indices => regular_get_indices
procedure :: get_bin_from_indices => regular_get_bin_from_indices
procedure :: get_indices_from_bin => regular_get_indices_from_bin
procedure :: intersects => regular_intersects
procedure :: to_hdf5 => regular_to_hdf5
end type RegularMesh
integer(C_INT32_T), public, bind(C) :: n_meshes = 0 ! # of structured meshes
type(RegularMesh), public, allocatable, target :: meshes(:)
! Dictionary that maps user IDs to indices in 'meshes'
type(DictIntInt), public :: mesh_dict
contains
subroutine regular_from_xml(this, node)
class(RegularMesh), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: n
character(MAX_LINE_LEN) :: temp_str
! Copy mesh id
if (check_for_node(node, "id")) then
call get_node_value(node, "id", this % id)
! Check to make sure 'id' hasn't been used
if (mesh_dict % has_key(this % id)) then
call fatal_error("Two or more meshes use the same unique ID: " &
// to_str(this % id))
end if
end if
! Read mesh type
if (check_for_node(node, "type")) then
call get_node_value(node, "type", temp_str)
select case (to_lower(temp_str))
case ('rect', 'rectangle', 'rectangular')
call warning("Mesh type '" // trim(temp_str) // "' is deprecated. &
&Please use 'regular' instead.")
this % type = MESH_REGULAR
case ('regular')
this % type = MESH_REGULAR
case default
call fatal_error("Invalid mesh type: " // trim(temp_str))
end select
else
this % type = MESH_REGULAR
end if
! Determine number of dimensions for mesh
if (check_for_node(node, "dimension")) then
n = node_word_count(node, "dimension")
if (n /= 1 .and. n /= 2 .and. n /= 3) then
call fatal_error("Mesh must be one, two, or three dimensions.")
end if
this % n_dimension = n
! Allocate attribute arrays
allocate(this % dimension(n))
! Check that dimensions are all greater than zero
call get_node_array(node, "dimension", this % dimension)
if (any(this % dimension <= 0)) then
call fatal_error("All entries on the <dimension> element for a tally &
&mesh must be positive.")
end if
end if
! Check for lower-left coordinates
if (check_for_node(node, "lower_left")) then
n = node_word_count(node, "lower_left")
allocate(this % lower_left(n))
! Read mesh lower-left corner location
call get_node_array(node, "lower_left", this % lower_left)
else
call fatal_error("Must specify <lower_left> on a mesh.")
end if
if (check_for_node(node, "width")) then
! Make sure both upper-right or width were specified
if (check_for_node(node, "upper_right")) then
call fatal_error("Cannot specify both <upper_right> and <width> on a &
&mesh.")
end if
n = node_word_count(node, "width")
allocate(this % width(n))
allocate(this % upper_right(n))
! Check to ensure width has same dimensions
if (n /= size(this % lower_left)) then
call fatal_error("Number of entries on <width> must be the same as &
&the number of entries on <lower_left>.")
end if
! Check for negative widths
call get_node_array(node, "width", this % width)
if (any(this % width < ZERO)) then
call fatal_error("Cannot have a negative <width> on a tally mesh.")
end if
! Set width and upper right coordinate
this % upper_right = this % lower_left + this % dimension * this % width
elseif (check_for_node(node, "upper_right")) then
n = node_word_count(node, "upper_right")
allocate(this % upper_right(n))
allocate(this % width(n))
! Check to ensure width has same dimensions
if (n /= size(this % lower_left)) then
call fatal_error("Number of entries on <upper_right> must be the &
&same as the number of entries on <lower_left>.")
end if
! Check that upper-right is above lower-left
call get_node_array(node, "upper_right", this % upper_right)
if (any(this % upper_right < this % lower_left)) then
call fatal_error("The <upper_right> coordinates must be greater than &
&the <lower_left> coordinates on a tally mesh.")
end if
! Set width and upper right coordinate
this % width = (this % upper_right - this % lower_left) / this % dimension
else
call fatal_error("Must specify either <upper_right> and <width> on a &
&mesh.")
end if
if (allocated(this % dimension)) then
if (size(this % dimension) /= size(this % lower_left)) then
call fatal_error("Number of entries on <lower_left> must be the same &
&as the number of entries on <dimension>.")
end if
! Set volume fraction
this % volume_frac = ONE/real(product(this % dimension),8)
end if
end subroutine regular_from_xml
!===============================================================================
! GET_MESH_BIN determines the tally bin for a particle in a structured mesh
!===============================================================================
pure subroutine regular_get_bin(this, xyz, bin)
class(RegularMesh), intent(in) :: this
real(8), intent(in) :: xyz(:) ! coordinates
integer, intent(out) :: bin ! tally bin
integer :: n ! size of mesh
integer :: d ! mesh dimension index
integer :: ijk(3) ! indices in mesh
logical :: in_mesh ! was given coordinate in mesh at all?
! Get number of dimensions
n = this % n_dimension
! Loop over the dimensions of the mesh
do d = 1, n
! Check for cases where particle is outside of mesh
if (xyz(d) < this % lower_left(d)) then
bin = NO_BIN_FOUND
return
elseif (xyz(d) > this % upper_right(d)) then
bin = NO_BIN_FOUND
return
end if
end do
! Determine indices
call this % get_indices(xyz, ijk, in_mesh)
! Convert indices to bin
if (in_mesh) then
bin = this % get_bin_from_indices(ijk)
else
bin = NO_BIN_FOUND
end if
end subroutine regular_get_bin
!===============================================================================
! GET_MESH_INDICES determines the indices of a particle in a structured mesh
!===============================================================================
pure subroutine regular_get_indices(this, xyz, ijk, in_mesh)
class(RegularMesh), intent(in) :: this
real(8), intent(in) :: xyz(:) ! coordinates to check
integer, intent(out) :: ijk(:) ! indices in mesh
logical, intent(out) :: in_mesh ! were given coords in mesh?
! Find particle in mesh
ijk(:this % n_dimension) = ceiling((xyz(:this % n_dimension) - &
this % lower_left)/this % width)
! Determine if particle is in mesh
if (any(ijk(:this % n_dimension) < 1) .or. &
any(ijk(:this % n_dimension) > this % dimension)) then
in_mesh = .false.
else
in_mesh = .true.
end if
end subroutine regular_get_indices
!===============================================================================
! MESH_INDICES_TO_BIN maps (i), (i,j), or (i,j,k) indices to a single bin number
! for use in a TallyObject results array
!===============================================================================
pure function regular_get_bin_from_indices(this, ijk) result(bin)
class(RegularMesh), intent(in) :: this
integer, intent(in) :: ijk(:)
integer :: bin
if (this % n_dimension == 1) then
bin = ijk(1)
elseif (this % n_dimension == 2) then
bin = (ijk(2) - 1) * this % dimension(1) + ijk(1)
elseif (this % n_dimension == 3) then
bin = ((ijk(3) - 1) * this % dimension(2) + (ijk(2) - 1)) &
* this % dimension(1) + ijk(1)
end if
end function regular_get_bin_from_indices
!===============================================================================
! BIN_TO_MESH_INDICES maps a single mesh bin from a TallyObject results array to
! (i), (i,j), or (i,j,k) indices
!===============================================================================
pure subroutine regular_get_indices_from_bin(this, bin, ijk)
class(RegularMesh), intent(in) :: this
integer, intent(in) :: bin
integer, intent(out) :: ijk(:)
if (this % n_dimension == 1) then
ijk(1) = bin
else if (this % n_dimension == 2) then
ijk(1) = mod(bin - 1, this % dimension(1)) + 1
ijk(2) = (bin - 1)/this % dimension(1) + 1
else if (this % n_dimension == 3) then
ijk(1) = mod(bin - 1, this % dimension(1)) + 1
ijk(2) = mod(bin - 1, this % dimension(1) * this % dimension(2)) &
/ this % dimension(1) + 1
ijk(3) = (bin - 1)/(this % dimension(1) * this % dimension(2)) + 1
end if
end subroutine regular_get_indices_from_bin
!===============================================================================
! MESH_INTERSECTS determines if a line between xyz0 and xyz1 intersects the
! outer boundary of the given mesh. This is important for determining whether a
! track will score to a mesh tally.
!===============================================================================
pure function regular_intersects(this, xyz0, xyz1) result(intersects)
class(RegularMesh), intent(in) :: this
real(8), intent(in) :: xyz0(:)
real(8), intent(in) :: xyz1(:)
logical :: intersects
select case(this % n_dimension)
case (1)
intersects = mesh_intersects_1d(this, xyz0, xyz1)
case (2)
intersects = mesh_intersects_2d(this, xyz0, xyz1)
case (3)
intersects = mesh_intersects_3d(this, xyz0, xyz1)
end select
end function regular_intersects
pure function mesh_intersects_1d(m, xyz0, xyz1) result(intersects)
type(RegularMesh), intent(in) :: m
real(8), intent(in) :: xyz0(:)
real(8), intent(in) :: xyz1(:)
logical :: intersects
real(8) :: x0 ! track start point
real(8) :: x1 ! track end point
real(8) :: xm0 ! lower-left coordinates of mesh
real(8) :: xm1 ! upper-right coordinates of mesh
! Copy coordinates of starting point
x0 = xyz0(1)
! Copy coordinates of ending point
x1 = xyz1(1)
! Copy coordinates of mesh lower_left
xm0 = m % lower_left(1)
! Copy coordinates of mesh upper_right
xm1 = m % upper_right(1)
! Set default value for intersects
intersects = .false.
! Check if line intersects left surface
if ((x0 < xm0 .and. x1 > xm0) .or. (x0 > xm0 .and. x1 < xm0)) then
intersects = .true.
return
end if
! Check if line intersects right surface
if ((x0 < xm1 .and. x1 > xm1) .or. (x0 > xm1 .and. x1 < xm1)) then
intersects = .true.
return
end if
end function mesh_intersects_1d
pure function mesh_intersects_2d(m, xyz0, xyz1) result(intersects)
type(RegularMesh), intent(in) :: m
real(8), intent(in) :: xyz0(:)
real(8), intent(in) :: xyz1(:)
logical :: intersects
real(8) :: x0, y0 ! track start point
real(8) :: x1, y1 ! track end point
real(8) :: xi, yi ! track intersection point with mesh
real(8) :: xm0, ym0 ! lower-left coordinates of mesh
real(8) :: xm1, ym1 ! upper-right coordinates of mesh
! Copy coordinates of starting point
x0 = xyz0(1)
y0 = xyz0(2)
! Copy coordinates of ending point
x1 = xyz1(1)
y1 = xyz1(2)
! Copy coordinates of mesh lower_left
xm0 = m % lower_left(1)
ym0 = m % lower_left(2)
! Copy coordinates of mesh upper_right
xm1 = m % upper_right(1)
ym1 = m % upper_right(2)
! Set default value for intersects
intersects = .false.
! Check if line intersects left surface -- calculate the intersection point
! y
if ((x0 < xm0 .and. x1 > xm0) .or. (x0 > xm0 .and. x1 < xm0)) then
yi = y0 + (xm0 - x0) * (y1 - y0) / (x1 - x0)
if (yi >= ym0 .and. yi < ym1) then
intersects = .true.
return
end if
end if
! Check if line intersects back surface -- calculate the intersection point
! x
if ((y0 < ym0 .and. y1 > ym0) .or. (y0 > ym0 .and. y1 < ym0)) then
xi = x0 + (ym0 - y0) * (x1 - x0) / (y1 - y0)
if (xi >= xm0 .and. xi < xm1) then
intersects = .true.
return
end if
end if
! Check if line intersects right surface -- calculate the intersection
! point y
if ((x0 < xm1 .and. x1 > xm1) .or. (x0 > xm1 .and. x1 < xm1)) then
yi = y0 + (xm1 - x0) * (y1 - y0) / (x1 - x0)
if (yi >= ym0 .and. yi < ym1) then
intersects = .true.
return
end if
end if
! Check if line intersects front surface -- calculate the intersection point
! x
if ((y0 < ym1 .and. y1 > ym1) .or. (y0 > ym1 .and. y1 < ym1)) then
xi = x0 + (ym1 - y0) * (x1 - x0) / (y1 - y0)
if (xi >= xm0 .and. xi < xm1) then
intersects = .true.
return
end if
end if
end function mesh_intersects_2d
pure function mesh_intersects_3d(m, xyz0, xyz1) result(intersects)
type(RegularMesh), intent(in) :: m
real(8), intent(in) :: xyz0(:)
real(8), intent(in) :: xyz1(:)
logical :: intersects
real(8) :: x0, y0, z0 ! track start point
real(8) :: x1, y1, z1 ! track end point
real(8) :: xi, yi, zi ! track intersection point with mesh
real(8) :: xm0, ym0, zm0 ! lower-left coordinates of mesh
real(8) :: xm1, ym1, zm1 ! upper-right coordinates of mesh
! Copy coordinates of starting point
x0 = xyz0(1)
y0 = xyz0(2)
z0 = xyz0(3)
! Copy coordinates of ending point
x1 = xyz1(1)
y1 = xyz1(2)
z1 = xyz1(3)
! Copy coordinates of mesh lower_left
xm0 = m % lower_left(1)
ym0 = m % lower_left(2)
zm0 = m % lower_left(3)
! Copy coordinates of mesh upper_right
xm1 = m % upper_right(1)
ym1 = m % upper_right(2)
zm1 = m % upper_right(3)
! Set default value for intersects
intersects = .false.
! Check if line intersects left surface -- calculate the intersection point
! (y,z)
if ((x0 < xm0 .and. x1 > xm0) .or. (x0 > xm0 .and. x1 < xm0)) then
yi = y0 + (xm0 - x0) * (y1 - y0) / (x1 - x0)
zi = z0 + (xm0 - x0) * (z1 - z0) / (x1 - x0)
if (yi >= ym0 .and. yi < ym1 .and. zi >= zm0 .and. zi < zm1) then
intersects = .true.
return
end if
end if
! Check if line intersects back surface -- calculate the intersection point
! (x,z)
if ((y0 < ym0 .and. y1 > ym0) .or. (y0 > ym0 .and. y1 < ym0)) then
xi = x0 + (ym0 - y0) * (x1 - x0) / (y1 - y0)
zi = z0 + (ym0 - y0) * (z1 - z0) / (y1 - y0)
if (xi >= xm0 .and. xi < xm1 .and. zi >= zm0 .and. zi < zm1) then
intersects = .true.
return
end if
end if
! Check if line intersects bottom surface -- calculate the intersection
! point (x,y)
if ((z0 < zm0 .and. z1 > zm0) .or. (z0 > zm0 .and. z1 < zm0)) then
xi = x0 + (zm0 - z0) * (x1 - x0) / (z1 - z0)
yi = y0 + (zm0 - z0) * (y1 - y0) / (z1 - z0)
if (xi >= xm0 .and. xi < xm1 .and. yi >= ym0 .and. yi < ym1) then
intersects = .true.
return
end if
end if
! Check if line intersects right surface -- calculate the intersection point
! (y,z)
if ((x0 < xm1 .and. x1 > xm1) .or. (x0 > xm1 .and. x1 < xm1)) then
yi = y0 + (xm1 - x0) * (y1 - y0) / (x1 - x0)
zi = z0 + (xm1 - x0) * (z1 - z0) / (x1 - x0)
if (yi >= ym0 .and. yi < ym1 .and. zi >= zm0 .and. zi < zm1) then
intersects = .true.
return
end if
end if
! Check if line intersects front surface -- calculate the intersection point
! (x,z)
if ((y0 < ym1 .and. y1 > ym1) .or. (y0 > ym1 .and. y1 < ym1)) then
xi = x0 + (ym1 - y0) * (x1 - x0) / (y1 - y0)
zi = z0 + (ym1 - y0) * (z1 - z0) / (y1 - y0)
if (xi >= xm0 .and. xi < xm1 .and. zi >= zm0 .and. zi < zm1) then
intersects = .true.
return
end if
end if
! Check if line intersects top surface -- calculate the intersection point
! (x,y)
if ((z0 < zm1 .and. z1 > zm1) .or. (z0 > zm1 .and. z1 < zm1)) then
xi = x0 + (zm1 - z0) * (x1 - x0) / (z1 - z0)
yi = y0 + (zm1 - z0) * (y1 - y0) / (z1 - z0)
if (xi >= xm0 .and. xi < xm1 .and. yi >= ym0 .and. yi < ym1) then
intersects = .true.
return
end if
end if
end function mesh_intersects_3d
!===============================================================================
! TO_HDF5 writes the mesh data to an HDF5 group
!===============================================================================
subroutine regular_to_hdf5(this, group)
class(RegularMesh), intent(in) :: this
integer(HID_T), intent(in) :: group
integer(HID_T) :: mesh_group
mesh_group = create_group(group, "mesh " // trim(to_str(this % id)))
call write_dataset(mesh_group, "type", "regular")
call write_dataset(mesh_group, "dimension", this % dimension)
call write_dataset(mesh_group, "lower_left", this % lower_left)
call write_dataset(mesh_group, "upper_right", this % upper_right)
call write_dataset(mesh_group, "width", this % width)
call close_group(mesh_group)
end subroutine regular_to_hdf5
!===============================================================================
! FREE_MEMORY_MESH deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_mesh()
n_meshes = 0
if (allocated(meshes)) deallocate(meshes)
call mesh_dict % clear()
end subroutine free_memory_mesh
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_extend_meshes(n, index_start, index_end) result(err) bind(C)
! Extend the meshes array by n elements
integer(C_INT32_T), value, intent(in) :: n
integer(C_INT32_T), optional, intent(out) :: index_start
integer(C_INT32_T), optional, intent(out) :: index_end
integer(C_INT) :: err
type(RegularMesh), allocatable :: temp(:) ! temporary meshes array
if (n_meshes == 0) then
! Allocate meshes array
allocate(meshes(n))
else
! Allocate meshes array with increased size
allocate(temp(n_meshes + n))
! Copy original meshes to temporary array
temp(1:n_meshes) = meshes
! Move allocation from temporary array
call move_alloc(FROM=temp, TO=meshes)
end if
! Return indices in meshes array
if (present(index_start)) index_start = n_meshes + 1
if (present(index_end)) index_end = n_meshes + n
n_meshes = n_meshes + n
err = 0
end function openmc_extend_meshes
end module mesh_header

15
src/mgxs_data.F90
View file

@ -2,14 +2,16 @@ module mgxs_data
use constants
use algorithm, only: find
use dict_header, only: DictCharInt
use error, only: fatal_error
use geometry_header, only: get_temperatures
use global
use geometry_header, only: get_temperatures, cells
use hdf5_interface
use material_header, only: Material
use material_header, only: Material, materials, n_materials
use mgxs_header
use nuclide_header, only: n_nuclides
use output, only: write_message
use set_header, only: SetChar
use settings
use stl_vector, only: VectorReal
use string, only: to_lower
implicit none
@ -51,8 +53,7 @@ contains
call write_message("Loading cross section data...", 5)
! Get temperatures
call get_temperatures(cells, materials, material_dict, nuclide_dict, &
n_nuclides_total, temps)
call get_temperatures(temps)
! Open file for reading
file_id = file_open(path_cross_sections, 'r', parallel=.true.)
@ -72,7 +73,7 @@ contains
end if
! allocate arrays for MGXS storage and cross section cache
allocate(nuclides_MG(n_nuclides_total))
allocate(nuclides_MG(n_nuclides))
! ==========================================================================
! READ ALL MGXS CROSS SECTION TABLES
@ -234,7 +235,7 @@ contains
kT = cells(i) % sqrtkT(1)**2
end if
i_material = material_dict % get_key(cells(i) % material(j))
i_material = cells(i) % material(j)
! Add temperature if it hasn't already been added
if (find(kTs(i_material), kT) == -1) then

31
src/mgxs_header.F90
View file

@ -209,7 +209,25 @@ module mgxs_header
procedure :: calculate_xs => mgxsang_calculate_xs
end type MgxsAngle
contains
! Cross section arrays
type(MgxsContainer), allocatable, target :: nuclides_MG(:)
! Cross section caches
type(MgxsContainer), target, allocatable :: macro_xs(:)
! Number of energy groups
integer :: num_energy_groups
! Number of delayed groups
integer :: num_delayed_groups
! Energy group structure
real(8), allocatable :: energy_bins(:)
! Midpoint of the energy group structure
real(8), allocatable :: energy_bin_avg(:)
contains
!===============================================================================
! MGXS*_FROM_HDF5 reads in the data from the HDF5 Library. At the point of entry
@ -3533,4 +3551,15 @@ module mgxs_header
end subroutine find_angle
!===============================================================================
! FREE_MEMORY_MGXS deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_mgxs()
if (allocated(nuclides_MG)) deallocate(nuclides_MG)
if (allocated(macro_xs)) deallocate(macro_xs)
if (allocated(energy_bins)) deallocate(energy_bins)
if (allocated(energy_bin_avg)) deallocate(energy_bin_avg)
end subroutine free_memory_mgxs
end module mgxs_header

3
src/multipole.F90
View file

@ -3,10 +3,11 @@ module multipole
use hdf5
use constants
use global
use error, only: fatal_error
use hdf5_interface
use multipole_header, only: MultipoleArray, FIT_T, FIT_A, FIT_F, &
MP_FISS, FORM_MLBW, FORM_RM
use nuclide_header, only: nuclides
implicit none

250
src/nuclide_header.F90
View file

@ -7,19 +7,19 @@ module nuclide_header
use algorithm, only: sort, find
use constants
use dict_header, only: DictIntInt
use dict_header, only: DictIntInt, DictCharInt
use endf, only: reaction_name, is_fission, is_disappearance
use endf_header, only: Function1D, Polynomial, Tabulated1D
use error, only: fatal_error, warning
use hdf5_interface, only: read_attribute, open_group, close_group, &
open_dataset, read_dataset, close_dataset, get_shape, get_datasets, &
object_exists, get_name, get_groups
use error
use hdf5_interface
use list_header, only: ListInt
use math, only: evaluate_legendre
use message_passing
use multipole_header, only: MultipoleArray
use product_header, only: AngleEnergyContainer
use reaction_header, only: Reaction
use secondary_uncorrelated, only: UncorrelatedAngleEnergy
use settings
use stl_vector, only: VectorInt, VectorReal
use string
use urr_header, only: UrrData
@ -95,6 +95,7 @@ module nuclide_header
class(Function1D), allocatable :: fission_q_recov ! neutrons, gammas, betas
contains
procedure :: assign_0K_elastic_scattering
procedure :: clear => nuclide_clear
procedure :: from_hdf5 => nuclide_from_hdf5
procedure :: init_grid => nuclide_init_grid
@ -157,7 +158,79 @@ module nuclide_header
character(MAX_FILE_LEN) :: path
end type Library
contains
! Cross section libraries
type(Library), allocatable :: libraries(:)
type(DictCharInt) :: library_dict
! Nuclear data for each nuclide
type(Nuclide), allocatable, target :: nuclides(:)
integer(C_INT), bind(C) :: n_nuclides
type(DictCharInt) :: nuclide_dict
! Cross section caches
type(NuclideMicroXS), allocatable :: micro_xs(:) ! Cache for each nuclide
type(MaterialMacroXS) :: material_xs ! Cache for current material
!$omp threadprivate(micro_xs, material_xs)
! Minimum/maximum energies
real(8) :: energy_min_neutron = ZERO
real(8) :: energy_max_neutron = INFINITY
contains
!===============================================================================
! ASSIGN_0K_ELASTIC_SCATTERING
!===============================================================================
subroutine assign_0K_elastic_scattering(this)
class(Nuclide), intent(inout) :: this
integer :: i
real(8) :: xs_cdf_sum
this % resonant = .false.
if (allocated(res_scat_nuclides)) then
! If resonant nuclides were specified, check the list explicitly
do i = 1, size(res_scat_nuclides)
if (this % name == res_scat_nuclides(i)) then
this % resonant = .true.
! Make sure nuclide has 0K data
if (.not. allocated(this % energy_0K)) then
call fatal_error("Cannot treat " // trim(this % name) // " as a &
&resonant scatterer because 0 K elastic scattering data is &
&not present.")
end if
exit
end if
end do
else
! Otherwise, assume that any that have 0 K elastic scattering data are
! resonant
this % resonant = allocated(this % energy_0K)
end if
if (this % resonant) then
! Build CDF for 0K elastic scattering
xs_cdf_sum = ZERO
allocate(this % xs_cdf(0:size(this % energy_0K)))
this % xs_cdf(0) = ZERO
associate (E => this % energy_0K, xs => this % elastic_0K)
do i = 1, size(E) - 1
! Negative cross sections result in a CDF that is not monotonically
! increasing. Set all negative xs values to zero.
if (xs(i) < ZERO) xs(i) = ZERO
! build xs cdf
xs_cdf_sum = xs_cdf_sum + (sqrt(E(i))*xs(i) + sqrt(E(i+1))*xs(i+1))&
/ TWO * (E(i+1) - E(i))
this % xs_cdf(i) = xs_cdf_sum
end do
end associate
end if
end subroutine assign_0K_elastic_scattering
!===============================================================================
! NUCLIDE_CLEAR resets and deallocates data in Nuclide
@ -724,4 +797,169 @@ module nuclide_header
end subroutine nuclide_init_grid
!===============================================================================
! CHECK_DATA_VERSION checks for the right version of nuclear data within HDF5
! files
!===============================================================================
subroutine check_data_version(file_id)
integer(HID_T), intent(in) :: file_id
integer, allocatable :: version(:)
if (attribute_exists(file_id, 'version')) then
call read_attribute(version, file_id, 'version')
if (version(1) /= HDF5_VERSION(1)) then
call fatal_error("HDF5 data format uses version " // trim(to_str(&
version(1))) // "." // trim(to_str(version(2))) // " whereas &
&your installation of OpenMC expects version " // trim(to_str(&
HDF5_VERSION(1))) // ".x data.")
end if
else
call fatal_error("HDF5 data does not indicate a version. Your &
&installation of OpenMC expects version " // trim(to_str(&
HDF5_VERSION(1))) // ".x data.")
end if
end subroutine check_data_version
!===============================================================================
! FREE_MEMORY_NUCLIDE deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_nuclide()
integer :: i
! Deallocate cross section data, listings, and cache
if (allocated(nuclides)) then
! First call the clear routines
do i = 1, size(nuclides)
call nuclides(i) % clear()
end do
deallocate(nuclides)
end if
n_nuclides = 0
if (allocated(libraries)) deallocate(libraries)
call nuclide_dict % clear()
call library_dict % clear()
end subroutine free_memory_nuclide
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_get_nuclide_index(name, index) result(err) bind(C)
! Return the index in the nuclides array of a nuclide with a given name
character(kind=C_CHAR), intent(in) :: name(*)
integer(C_INT), intent(out) :: index
integer(C_INT) :: err
character(:), allocatable :: name_
! Copy array of C_CHARs to normal Fortran string
name_ = to_f_string(name)
if (allocated(nuclides)) then
if (nuclide_dict % has_key(to_lower(name_))) then
index = nuclide_dict % get_key(to_lower(name_))
err = 0
else
err = E_DATA
call set_errmsg("No nuclide named '" // trim(name_) // &
"' has been loaded.")
end if
else
err = E_ALLOCATE
call set_errmsg("Memory for nuclides has not been allocated.")
end if
end function openmc_get_nuclide_index
function openmc_load_nuclide(name) result(err) bind(C)
! Load a nuclide from the cross section library
character(kind=C_CHAR), intent(in) :: name(*)
integer(C_INT) :: err
integer :: i_library
integer :: n
integer(HID_T) :: file_id
integer(HID_T) :: group_id
character(:), allocatable :: name_
real(8) :: minmax(2) = [ZERO, INFINITY]
type(VectorReal) :: temperature
type(Nuclide), allocatable :: new_nuclides(:)
! Copy array of C_CHARs to normal Fortran string
name_ = to_f_string(name)
err = 0
if (.not. nuclide_dict % has_key(to_lower(name_))) then
if (library_dict % has_key(to_lower(name_))) then
! allocate extra space in nuclides array
n = n_nuclides
allocate(new_nuclides(n + 1))
new_nuclides(1:n) = nuclides(:)
call move_alloc(FROM=new_nuclides, TO=nuclides)
n = n + 1
i_library = library_dict % get_key(to_lower(name_))
! Open file and make sure version is sufficient
file_id = file_open(libraries(i_library) % path, 'r')
call check_data_version(file_id)
! Read nuclide data from HDF5
group_id = open_group(file_id, name_)
call nuclides(n) % from_hdf5(group_id, temperature, &
temperature_method, temperature_tolerance, minmax, &
master)
call close_group(group_id)
call file_close(file_id)
! Add entry to nuclide dictionary
call nuclide_dict % add_key(to_lower(name_), n)
n_nuclides = n
! Assign resonant scattering data
if (res_scat_on) call nuclides(n) % assign_0K_elastic_scattering()
! Initialize nuclide grid
call nuclides(n) % init_grid(energy_min_neutron, &
energy_max_neutron, n_log_bins)
else
err = E_DATA
call set_errmsg("Nuclide '" // trim(name_) // "' is not present &
&in library.")
end if
end if
end function openmc_load_nuclide
function openmc_nuclide_name(index, name) result(err) bind(C)
! Return the name of a nuclide with a given index
integer(C_INT), value, intent(in) :: index
type(c_ptr), intent(out) :: name
integer(C_INT) :: err
character(C_CHAR), pointer :: name_
err = E_UNASSIGNED
if (allocated(nuclides)) then
if (index >= 1 .and. index <= size(nuclides)) then
name_ => nuclides(index) % name(1:1)
name = C_LOC(name_)
err = 0
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in nuclides array is out of bounds.")
end if
else
err = E_ALLOCATE
call set_errmsg("Memory for nuclides has not been allocated yet.")
end if
end function openmc_nuclide_name
end module nuclide_header

62
src/output.F90
View file

@ -3,24 +3,30 @@ module output
use, intrinsic :: ISO_C_BINDING
use, intrinsic :: ISO_FORTRAN_ENV
use cmfd_header
use constants
use eigenvalue, only: openmc_get_keff
use endf, only: reaction_name
use error, only: fatal_error, warning
use geometry_header, only: Cell, Universe, Lattice, RectLattice, &
HexLattice
use global
use geometry_header
use math, only: t_percentile
use mesh_header, only: RegularMesh
use mesh, only: mesh_indices_to_bin, bin_to_mesh_indices
use mesh_header, only: RegularMesh, meshes
use message_passing, only: master, n_procs
use mgxs_header, only: nuclides_MG
use nuclide_header
use particle_header, only: LocalCoord, Particle
use plot_header
use sab_header, only: SAlphaBeta
use settings
use simulation_header
use surface_header, only: surfaces
use string, only: to_upper, to_str
use tally_header, only: TallyObject
use tally_header
use tally_derivative_header
use tally_filter
use tally_filter_mesh, only: MeshFilter
use tally_filter_header, only: TallyFilterMatch
use timer_header
implicit none
@ -531,6 +537,7 @@ contains
subroutine print_runtime()
integer :: n_active
real(8) :: speed_inactive ! # of neutrons/second in inactive batches
real(8) :: speed_active ! # of neutrons/second in active batches
character(15) :: string
@ -563,6 +570,7 @@ contains
write(ou,100) "Total time elapsed", time_total % elapsed
! Calculate particle rate in active/inactive batches
n_active = n_batches - n_inactive
if (restart_run) then
if (restart_batch < n_inactive) then
speed_inactive = real(n_particles * (n_inactive - restart_batch) * &
@ -729,11 +737,13 @@ contains
character(36) :: score_names(N_SCORE_TYPES) ! names of scoring function
character(36) :: score_name ! names of scoring function
! to be applied at write-time
type(TallyObject), pointer :: t
type(TallyFilterMatch), allocatable :: matches(:)
! Skip if there are no tallies
if (n_tallies == 0) return
allocate(matches(n_filters))
! Initialize names for scores
score_names(abs(SCORE_FLUX)) = "Flux"
score_names(abs(SCORE_TOTAL)) = "Total Reaction Rate"
@ -775,7 +785,7 @@ contains
end if
TALLY_LOOP: do i = 1, n_tallies
t => tallies(i)
associate (t => tallies(i) % obj)
nr = t % n_realizations
if (confidence_intervals) then
@ -830,8 +840,8 @@ contains
! Initialize bins, filter level, and indentation
do h = 1, size(t % filter)
call filter_matches(t % filter(h)) % bins % clear()
call filter_matches(t % filter(h)) % bins % push_back(0)
call matches(t % filter(h)) % bins % clear()
call matches(t % filter(h)) % bins % push_back(0)
end do
j = 1
indent = 0
@ -842,18 +852,18 @@ contains
if (size(t % filter) == 0) exit find_bin
! Increment bin combination
filter_matches(t % filter(j)) % bins % data(1) = &
filter_matches(t % filter(j)) % bins % data(1) + 1
matches(t % filter(j)) % bins % data(1) = &
matches(t % filter(j)) % bins % data(1) + 1
! =================================================================
! REACHED END OF BINS FOR THIS FILTER, MOVE TO NEXT FILTER
if (filter_matches(t % filter(j)) % bins % data(1) > &
if (matches(t % filter(j)) % bins % data(1) > &
filters(t % filter(j)) % obj % n_bins) then
! If this is the first filter, then exit
if (j == 1) exit print_bin
filter_matches(t % filter(j)) % bins % data(1) = 0
matches(t % filter(j)) % bins % data(1) = 0
j = j - 1
indent = indent - 2
@ -867,7 +877,7 @@ contains
! Print current filter information
write(UNIT=unit_tally, FMT='(1X,2A)') repeat(" ", indent), &
trim(filters(t % filter(j)) % obj % &
text_label(filter_matches(t % filter(j)) % bins % data(1)))
text_label(matches(t % filter(j)) % bins % data(1)))
indent = indent + 2
j = j + 1
end if
@ -878,7 +888,7 @@ contains
if (size(t % filter) > 0) then
write(UNIT=unit_tally, FMT='(1X,2A)') repeat(" ", indent), &
trim(filters(t % filter(j)) % obj % &
text_label(filter_matches(t % filter(j)) % bins % data(1)))
text_label(matches(t % filter(j)) % bins % data(1)))
end if
! Determine scoring index for this bin combination -- note that unlike
@ -887,7 +897,7 @@ contains
filter_index = 1
do h = 1, size(t % filter)
filter_index = filter_index + (max(filter_matches(t % filter(h)) &
filter_index = filter_index + (max(matches(t % filter(h)) &
% bins % data(1),1) - 1) * t % stride(h)
end do
@ -976,6 +986,7 @@ contains
end do print_bin
end associate
end do TALLY_LOOP
close(UNIT=unit_tally)
@ -1009,6 +1020,9 @@ contains
logical :: energy_filters ! energy filters present
character(MAX_LINE_LEN) :: string
type(RegularMesh), pointer :: m
type(TallyFilterMatch), allocatable :: matches(:)
allocate(matches(n_filters))
nr = t % n_realizations
@ -1025,8 +1039,8 @@ contains
! initialize bins array
do j = 1, size(t % filter)
call filter_matches(t % filter(j)) % bins % clear()
call filter_matches(t % filter(j)) % bins % push_back(1)
call matches(t % filter(j)) % bins % clear()
call matches(t % filter(j)) % bins % push_back(1)
end do
! determine how many energy in bins there are
@ -1048,8 +1062,8 @@ contains
do i = 1, n_cells
! Get the indices for this cell
call bin_to_mesh_indices(m, i, ijk)
filter_matches(i_filter_mesh) % bins % data(1) = i
call m % get_indices_from_bin(i, ijk)
matches(i_filter_mesh) % bins % data(1) = i
! Write the header for this cell
if (n_dim == 1) then
@ -1067,18 +1081,18 @@ contains
do l = 1, n
if (print_ebin) then
! Set incoming energy bin
filter_matches(i_filter_ein) % bins % data(1) = l
matches(i_filter_ein) % bins % data(1) = l
! Write incoming energy bin
write(UNIT=unit_tally, FMT='(3X,A)') &
trim(filters(i_filter_ein) % obj % text_label( &
filter_matches(i_filter_ein) % bins % data(1)))
matches(i_filter_ein) % bins % data(1)))
end if
filter_index = 1
do j = 1, size(t % filter)
if (t % filter(j) == i_filter_surf) cycle
filter_index = filter_index + (filter_matches(t % filter(j)) &
filter_index = filter_index + (matches(t % filter(j)) &
% bins % data(1) - 1) * t % stride(j)
end do

3
src/particle_header.F90
View file

@ -147,7 +147,7 @@ contains
this % fission = .false.
this % delayed_group = 0
this % n_delayed_bank(:) = 0
this % g = 1
this % g = NONE
! Set up base level coordinates
this % coord(1) % universe = root_universe
@ -214,6 +214,7 @@ contains
this % last_uvw = src % uvw
if (run_CE) then
this % E = src % E
this % g = NONE
else
this % g = int(src % E)
this % last_g = int(src % E)

8
src/particle_restart.F90
View file

@ -4,11 +4,15 @@ module particle_restart
use bank_header, only: Bank
use constants
use global
use hdf5_interface, only: file_open, file_close, read_dataset
use mgxs_header, only: energy_bin_avg
use nuclide_header, only: micro_xs, n_nuclides
use output, only: write_message, print_particle
use particle_header, only: Particle
use random_lcg, only: set_particle_seed
use settings
use simulation_header
use tally_header, only: n_tallies
use tracking, only: transport
use hdf5, only: HID_T
@ -32,7 +36,7 @@ contains
! Set verbosity high
verbosity = 10
allocate(micro_xs(n_nuclides_total))
allocate(micro_xs(n_nuclides))
! Initialize the particle to be tracked
call p % initialize()

5
src/particle_restart_write.F90
View file

@ -1,9 +1,10 @@
module particle_restart_write
use bank_header, only: Bank
use global
use bank_header, only: Bank, source_bank
use hdf5_interface
use particle_header, only: Particle
use settings
use simulation_header
use string, only: to_str
use hdf5

36
src/physics.F90
View file

@ -5,10 +5,9 @@ module physics
use cross_section, only: elastic_xs_0K
use endf, only: reaction_name
use error, only: fatal_error, warning
use global
use material_header, only: Material
use material_header, only: Material, materials
use math
use mesh, only: get_mesh_indices
use mesh_header, only: meshes
use message_passing
use nuclide_header
use output, only: write_message
@ -17,8 +16,12 @@ module physics
use physics_common
use random_lcg, only: prn, advance_prn_seed, prn_set_stream
use reaction_header, only: Reaction
use sab_header, only: sab_tables
use secondary_uncorrelated, only: UncorrelatedAngleEnergy
use settings
use simulation_header
use string, only: to_str
use tally_header
implicit none
@ -1074,10 +1077,9 @@ contains
integer :: nu_d(MAX_DELAYED_GROUPS) ! number of delayed neutrons born
integer :: i ! loop index
integer :: nu ! actual number of neutrons produced
integer :: ijk(3) ! indices in ufs mesh
integer :: mesh_bin ! mesh bin for source site
real(8) :: nu_t ! total nu
real(8) :: weight ! weight adjustment for ufs method
logical :: in_mesh ! source site in ufs mesh?
type(Nuclide), pointer :: nuc
! Get pointers
@ -1089,18 +1091,20 @@ contains
! the expected number of fission sites produced
if (ufs) then
! Determine indices on ufs mesh for current location
call get_mesh_indices(ufs_mesh, p % coord(1) % xyz, ijk, in_mesh)
if (.not. in_mesh) then
call write_particle_restart(p)
call fatal_error("Source site outside UFS mesh!")
end if
associate (m => meshes(index_ufs_mesh))
! Determine indices on ufs mesh for current location
call m % get_bin(p % coord(1) % xyz, mesh_bin)
if (mesh_bin == NO_BIN_FOUND) then
call write_particle_restart(p)
call fatal_error("Source site outside UFS mesh!")
end if
if (source_frac(1,ijk(1),ijk(2),ijk(3)) /= ZERO) then
weight = ufs_mesh % volume_frac / source_frac(1,ijk(1),ijk(2),ijk(3))
else
weight = ONE
end if
if (source_frac(1, mesh_bin) /= ZERO) then
weight = m % volume_frac / source_frac(1, mesh_bin)
else
weight = ONE
end if
end associate
else
weight = ONE
end if

2
src/physics_common.F90
View file

@ -1,9 +1,9 @@
module physics_common
use constants
use global, only: weight_cutoff, weight_survive
use particle_header, only: Particle
use random_lcg, only: prn
use settings, only: weight_cutoff, weight_survive
implicit none

40
src/physics_mg.F90
View file

@ -2,21 +2,25 @@ module physics_mg
! This module contains the multi-group specific physics routines so as to not
! hinder performance of the CE versions with multiple if-thens.
use bank_header
use constants
use error, only: fatal_error, warning
use global
use material_header, only: Material
use material_header, only: Material, materials
use math, only: rotate_angle
use mgxs_header, only: Mgxs, MgxsContainer
use mesh, only: get_mesh_indices
use mesh_header, only: meshes
use mgxs_header
use message_passing
use nuclide_header, only: material_xs
use output, only: write_message
use particle_header, only: Particle
use particle_restart_write, only: write_particle_restart
use physics_common
use random_lcg, only: prn
use scattdata_header
use settings
use simulation_header
use string, only: to_str
use tally_header
implicit none
@ -171,12 +175,11 @@ contains
integer :: dg ! delayed group
integer :: gout ! group out
integer :: nu ! actual number of neutrons produced
integer :: ijk(3) ! indices in ufs mesh
integer :: mesh_bin ! mesh bin for source site
real(8) :: nu_t ! total nu
real(8) :: mu ! fission neutron angular cosine
real(8) :: phi ! fission neutron azimuthal angle
real(8) :: weight ! weight adjustment for ufs method
logical :: in_mesh ! source site in ufs mesh?
class(Mgxs), pointer :: xs
! Get Pointers
@ -188,20 +191,21 @@ contains
! the expected number of fission sites produced
if (ufs) then
associate (m => meshes(index_ufs_mesh))
! Determine indices on ufs mesh for current location
call m % get_bin(p % coord(1) % xyz, mesh_bin)
! Determine indices on ufs mesh for current location
call get_mesh_indices(ufs_mesh, p % coord(1) % xyz, ijk, in_mesh)
if (mesh_bin == NO_BIN_FOUND) then
call write_particle_restart(p)
call fatal_error("Source site outside UFS mesh!")
end if
if (.not. in_mesh) then
call write_particle_restart(p)
call fatal_error("Source site outside UFS mesh!")
end if
if (source_frac(1,ijk(1),ijk(2),ijk(3)) /= ZERO) then
weight = ufs_mesh % volume_frac / source_frac(1,ijk(1),ijk(2),ijk(3))
else
weight = ONE
end if
if (source_frac(1, mesh_bin) /= ZERO) then
weight = m % volume_frac / source_frac(1, mesh_bin)
else
weight = ONE
end if
end associate
else
weight = ONE
end if

11
src/plot.F90
View file

@ -7,15 +7,14 @@ module plot
use constants
use error, only: fatal_error
use geometry, only: find_cell, check_cell_overlap
use geometry_header, only: Cell, root_universe
use global
use geometry_header, only: Cell, root_universe, cells
use hdf5_interface
use mesh, only: get_mesh_indices
use mesh_header, only: RegularMesh
use output, only: write_message, time_stamp
use material_header, only: materials
use particle_header, only: LocalCoord, Particle
use plot_header
use progress_header, only: ProgressBar
use settings, only: check_overlaps
use string, only: to_str
implicit none
@ -241,8 +240,8 @@ contains
width = xyz_ur_plot - xyz_ll_plot
associate (m => pl % meshlines_mesh)
call get_mesh_indices(m, xyz_ll_plot, ijk_ll(:m % n_dimension), in_mesh)
call get_mesh_indices(m, xyz_ur_plot, ijk_ur(:m % n_dimension), in_mesh)
call m % get_indices(xyz_ll_plot, ijk_ll(:m % n_dimension), in_mesh)
call m % get_indices(xyz_ur_plot, ijk_ur(:m % n_dimension), in_mesh)
! sweep through all meshbins on this plane and draw borders
do i = ijk_ll(outer), ijk_ur(outer)

24
src/plot_header.F90
View file

@ -1,7 +1,10 @@
module plot_header
use, intrinsic :: ISO_C_BINDING
use constants
use mesh_header, only: RegularMesh
use dict_header, only: DictIntInt
use mesh_header, only: RegularMesh
implicit none
@ -50,4 +53,23 @@ module plot_header
integer, parameter :: PLOT_COLOR_CELLS = 1
integer, parameter :: PLOT_COLOR_MATS = 2
integer(C_INT32_T), bind(C) :: n_plots ! # of plots
type(ObjectPlot), allocatable, target :: plots(:)
! Dictionary that maps user IDs to indices in 'plots'
type(DictIntInt) :: plot_dict
contains
!===============================================================================
! FREE_MEMORY_PLOT deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_plot()
n_plots = 0
if (allocated(plots)) deallocate(plots)
call plot_dict % clear()
end subroutine free_memory_plot
end module plot_header

36
src/relaxng/settings.rnc
View file

@ -12,14 +12,7 @@ element settings {
element energy_mode { ( "continuous-energy" | "ce" | "CE" | "multi-group" | "mg" | "MG" ) }? &
element entropy {
(element dimension { list { xsd:int+ } } |
attribute dimension { list { xsd:int+ } })? &
(element lower_left { list { xsd:double+ } } |
attribute lower_left { list { xsd:double+ } }) &
(element upper_right { list { xsd:double+ } } |
attribute upper_right { list { xsd:double+ } })
}? &
element entropy_mesh { xsd:positiveInteger }? &
element generations_per_batch { xsd:positiveInteger }? &
@ -34,6 +27,22 @@ element settings {
element max_order { xsd:nonNegativeInteger }? &
element mesh {
(element id { xsd:int } | attribute id { xsd:int }) &
(element type { ( "regular" ) } |
attribute type { ( "regular" ) })? &
(element dimension { list { xsd:positiveInteger+ } } |
attribute dimension { list { xsd:positiveInteger+ } }) &
(element lower_left { list { xsd:double+ } } |
attribute lower_left { list { xsd:double+ } }) &
(
(element upper_right { list { xsd:double+ } } |
attribute upper_right { list { xsd:double+ } }) |
(element width { list { xsd:double+ } } |
attribute width { list { xsd:double+ } })
)
}* &
element no_reduce { xsd:boolean }? &
element output {
@ -132,6 +141,8 @@ element settings {
(element batch_interval { xsd:positiveInteger } | attribute batch_interval { xsd:positiveInteger })?
}? &
element ufs_mesh { xsd:positiveInteger }? &
element verbosity { xsd:positiveInteger }? &
element volume_calc {
@ -147,15 +158,6 @@ element settings {
attribute upper_right { list { xsd:double+ } })
}* &
element uniform_fs{
(element dimension { list { xsd:positiveInteger+ } } |
attribute dimension { list { xsd:positiveInteger+ } }) &
(element lower_left { list { xsd:double+ } } |
attribute lower_left { list { xsd:double+ } }) &
(element upper_right { list { xsd:double+ } } |
attribute upper_right { list { xsd:double+ } })
}? &
element resonance_scattering {
(element enable { xsd:boolean } | attribute enable { xsd:boolean })? &
(element method { xsd:string } | attribute method { xsd:string })? &

204
src/relaxng/settings.rng
View file

@ -62,59 +62,8 @@
</element>
</optional>
<optional>
<element name="entropy">
<interleave>
<optional>
<choice>
<element name="dimension">
<list>
<oneOrMore>
<data type="int"/>
</oneOrMore>
</list>
</element>
<attribute name="dimension">
<list>
<oneOrMore>
<data type="int"/>
</oneOrMore>
</list>
</attribute>
</choice>
</optional>
<choice>
<element name="lower_left">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</element>
<attribute name="lower_left">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</attribute>
</choice>
<choice>
<element name="upper_right">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</element>
<attribute name="upper_right">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</attribute>
</choice>
</interleave>
<element name="entropy_mesh">
<data type="positiveInteger"/>
</element>
</optional>
<optional>
@ -159,6 +108,96 @@
<data type="nonNegativeInteger"/>
</element>
</optional>
<zeroOrMore>
<element name="mesh">
<interleave>
<choice>
<element name="id">
<data type="int"/>
</element>
<attribute name="id">
<data type="int"/>
</attribute>
</choice>
<optional>
<choice>
<element name="type">
<value>regular</value>
</element>
<attribute name="type">
<value>regular</value>
</attribute>
</choice>
</optional>
<choice>
<element name="dimension">
<list>
<oneOrMore>
<data type="positiveInteger"/>
</oneOrMore>
</list>
</element>
<attribute name="dimension">
<list>
<oneOrMore>
<data type="positiveInteger"/>
</oneOrMore>
</list>
</attribute>
</choice>
<choice>
<element name="lower_left">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</element>
<attribute name="lower_left">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</attribute>
</choice>
<choice>
<choice>
<element name="upper_right">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</element>
<attribute name="upper_right">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</attribute>
</choice>
<choice>
<element name="width">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</element>
<attribute name="width">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</attribute>
</choice>
</choice>
</interleave>
</element>
</zeroOrMore>
<optional>
<element name="no_reduce">
<data type="boolean"/>
@ -585,6 +624,11 @@
</interleave>
</element>
</optional>
<optional>
<element name="ufs_mesh">
<data type="positiveInteger"/>
</element>
</optional>
<optional>
<element name="verbosity">
<data type="positiveInteger"/>
@ -660,60 +704,6 @@
</interleave>
</element>
</zeroOrMore>
<optional>
<element name="uniform_fs">
<interleave>
<choice>
<element name="dimension">
<list>
<oneOrMore>
<data type="positiveInteger"/>
</oneOrMore>
</list>
</element>
<attribute name="dimension">
<list>
<oneOrMore>
<data type="positiveInteger"/>
</oneOrMore>
</list>
</attribute>
</choice>
<choice>
<element name="lower_left">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</element>
<attribute name="lower_left">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</attribute>
</choice>
<choice>
<element name="upper_right">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</element>
<attribute name="upper_right">
<list>
<oneOrMore>
<data type="double"/>
</oneOrMore>
</list>
</attribute>
</choice>
</interleave>
</element>
</optional>
<optional>
<element name="resonance_scattering">
<interleave>

18
src/sab_header.F90
View file

@ -1,10 +1,11 @@
module sab_header
use, intrinsic :: ISO_C_BINDING
use, intrinsic :: ISO_FORTRAN_ENV
use algorithm, only: find, sort
use constants
use dict_header, only: DictIntInt
use dict_header, only: DictIntInt, DictCharInt
use distribution_univariate, only: Tabular
use error, only: warning, fatal_error
use hdf5, only: HID_T, HSIZE_T, SIZE_T
@ -78,6 +79,11 @@ module sab_header
procedure :: from_hdf5 => salphabeta_from_hdf5
end type SAlphaBeta
! S(a,b) tables
type(SAlphaBeta), allocatable, target :: sab_tables(:)
integer(C_INT), bind(C) :: n_sab_tables
type(DictCharInt) :: sab_dict
contains
subroutine salphabeta_from_hdf5(this, group_id, temperature, method, &
@ -354,4 +360,14 @@ contains
call close_group(kT_group)
end subroutine salphabeta_from_hdf5
!===============================================================================
! FREE_MEMORY_SAB deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_sab()
n_sab_tables = 0
if (allocated(sab_tables)) deallocate(sab_tables)
call sab_dict % clear()
end subroutine free_memory_sab
end module sab_header

155
src/settings.F90 Normal file
View file

@ -0,0 +1,155 @@
module settings
use, intrinsic :: ISO_C_BINDING
use constants
use set_header, only: SetInt
implicit none
! ============================================================================
! ENERGY TREATMENT RELATED VARIABLES
logical :: run_CE = .true. ! Run in CE mode?
! ============================================================================
! CONTINUOUS-ENERGY CROSS SECTION RELATED VARIABLES
! Unreoslved resonance probablity tables
logical :: urr_ptables_on = .true.
! Default temperature and method for choosing temperatures
integer :: temperature_method = TEMPERATURE_NEAREST
logical :: temperature_multipole = .false.
real(8) :: temperature_tolerance = 10.0_8
real(8) :: temperature_default = 293.6_8
real(8) :: temperature_range(2) = [ZERO, ZERO]
integer :: n_log_bins ! number of bins for logarithmic grid
! ============================================================================
! MULTI-GROUP CROSS SECTION RELATED VARIABLES
! Maximum Data Order
integer :: max_order
! Whether or not to convert Legendres to tabulars
logical :: legendre_to_tabular = .true.
! Number of points to use in the Legendre to tabular conversion
integer :: legendre_to_tabular_points = 33
! Assume all tallies are spatially distinct
logical :: assume_separate = .false.
! Use confidence intervals for results instead of standard deviations
logical :: confidence_intervals = .false.
! ============================================================================
! SIMULATION VARIABLES
integer(C_INT64_T), bind(C) :: n_particles = 0 ! # of particles per generation
integer(C_INT32_T), bind(C) :: n_batches ! # of batches
integer(C_INT32_T), bind(C) :: n_inactive ! # of inactive batches
integer(C_INT32_T), bind(C) :: gen_per_batch = 1 ! # of generations per batch
integer :: n_max_batches ! max # of batches
integer :: n_batch_interval = 1 ! batch interval for triggers
logical :: pred_batches = .false. ! predict batches for triggers
logical :: trigger_on = .false. ! flag for turning triggers on/off
logical :: entropy_on = .false.
integer :: index_entropy_mesh = -1
logical :: ufs = .false.
integer :: index_ufs_mesh = -1
! Write source at end of simulation
logical :: source_separate = .false.
logical :: source_write = .true.
logical :: source_latest = .false.
! Variance reduction settins
logical :: survival_biasing = .false.
real(8) :: weight_cutoff = 0.25_8
real(8) :: energy_cutoff = ZERO
real(8) :: weight_survive = ONE
! Mode to run in (fixed source, eigenvalue, plotting, etc)
integer(C_INT), bind(C) :: run_mode = NONE
! Restart run
logical :: restart_run = .false.
! The verbosity controls how much information will be printed to the screen
! and in logs
integer(C_INT), bind(C) :: verbosity = 7
logical :: check_overlaps = .false.
! Trace for single particle
integer :: trace_batch
integer :: trace_gen
integer(8) :: trace_particle
! Particle tracks
logical :: write_all_tracks = .false.
integer, allocatable :: track_identifiers(:,:)
! Particle restart run
logical :: particle_restart_run = .false.
! Write out initial source
logical :: write_initial_source = .false.
! Whether create fission neutrons or not. Only applied for MODE_FIXEDSOURCE
logical :: create_fission_neutrons = .true.
! Information about state points to be written
integer :: n_state_points = 0
type(SetInt) :: statepoint_batch
! Information about source points to be written
integer :: n_source_points = 0
type(SetInt) :: sourcepoint_batch
character(MAX_FILE_LEN) :: path_input ! Path to input file
character(MAX_FILE_LEN) :: path_cross_sections = '' ! Path to cross_sections.xml
character(MAX_FILE_LEN) :: path_multipole ! Path to wmp library
character(MAX_FILE_LEN) :: path_source = '' ! Path to binary source
character(MAX_FILE_LEN) :: path_state_point ! Path to binary state point
character(MAX_FILE_LEN) :: path_source_point ! Path to binary source point
character(MAX_FILE_LEN) :: path_particle_restart ! Path to particle restart
character(MAX_FILE_LEN) :: path_output = '' ! Path to output directory
! Various output options
logical :: output_summary = .true.
logical :: output_tallies = .true.
! Resonance scattering settings
logical :: res_scat_on = .false. ! is resonance scattering treated?
integer :: res_scat_method = RES_SCAT_ARES ! resonance scattering method
real(8) :: res_scat_energy_min = 0.01_8
real(8) :: res_scat_energy_max = 1000.0_8
character(10), allocatable :: res_scat_nuclides(:)
! Is CMFD active
logical :: cmfd_run = .false.
! No reduction at end of batch
logical :: reduce_tallies = .true.
contains
!===============================================================================
! FREE_MEMORY_SETTINGS deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_settings()
if (allocated(res_scat_nuclides)) deallocate(res_scat_nuclides)
if (allocated(track_identifiers)) deallocate(track_identifiers)
call statepoint_batch % clear()
call sourcepoint_batch % clear()
end subroutine free_memory_settings
end module settings

163
src/simulation.F90
View file

@ -2,7 +2,13 @@ module simulation
use, intrinsic :: ISO_C_BINDING
#ifdef _OPENMP
use omp_lib
#endif
use bank_header, only: source_bank
use cmfd_execute, only: cmfd_init_batch, execute_cmfd
use cmfd_header, only: cmfd_on
use constants, only: ZERO
use eigenvalue, only: count_source_for_ufs, calculate_average_keff, &
calculate_generation_keff, shannon_entropy, &
@ -10,17 +16,27 @@ module simulation
#ifdef _OPENMP
use eigenvalue, only: join_bank_from_threads
#endif
use global
use error, only: fatal_error
use geometry_header, only: n_cells
use message_passing
use mgxs_header, only: energy_bins, energy_bin_avg
use nuclide_header, only: micro_xs, n_nuclides
use output, only: write_message, header, print_columns, &
print_batch_keff, print_generation, print_runtime, &
print_results, print_overlap_check, write_tallies
use particle_header, only: Particle
use random_lcg, only: set_particle_seed
use settings
use simulation_header
use source, only: initialize_source, sample_external_source
use state_point, only: write_state_point, write_source_point
use state_point, only: write_state_point, write_source_point, load_state_point
use string, only: to_str
use tally, only: accumulate_tallies, setup_active_usertallies
use tally, only: accumulate_tallies, setup_active_tallies, &
init_tally_routines
use tally_header
use tally_filter_header, only: filter_matches, n_filters
use tally_derivative_header, only: tally_derivs
use timer_header
use trigger, only: check_triggers
use tracking, only: transport
@ -158,6 +174,8 @@ contains
subroutine initialize_batch()
integer :: i
if (run_mode == MODE_FIXEDSOURCE) then
call write_message("Simulating batch " // trim(to_str(current_batch)) &
// "...", 6)
@ -171,12 +189,9 @@ contains
call time_inactive % stop()
call time_active % start()
! Enable active batches (and tallies_on if it hasn't been enabled)
active_batches = .true.
tallies_on = .true.
! Add user tallies to active tallies list
call setup_active_usertallies()
do i = 1, n_tallies
tallies(i) % obj % active = .true.
end do
end if
! check CMFD initialize batch
@ -184,6 +199,9 @@ contains
if (cmfd_run) call cmfd_init_batch()
end if
! Add user tallies to active tallies list
call setup_active_tallies()
end subroutine initialize_batch
!===============================================================================
@ -295,7 +313,7 @@ contains
call time_tallies % stop()
! Reset global tally results
if (.not. active_batches) then
if (current_batch <= n_inactive) then
global_tallies(:,:) = ZERO
n_realizations = 0
end if
@ -369,11 +387,34 @@ contains
subroutine initialize_simulation()
! Set up tally procedure pointers
call init_tally_routines()
! Determine how much work each processor should do
call calculate_work()
! Allocate source bank, and for eigenvalue simulations also allocate the
! fission bank
call allocate_banks()
! Allocate tally results arrays if they're not allocated yet
call configure_tallies()
!$omp parallel
allocate(micro_xs(n_nuclides_total))
! Allocate array for microscopic cross section cache
allocate(micro_xs(n_nuclides))
! Allocate array for matching filter bins
allocate(filter_matches(n_filters))
!$omp end parallel
if (.not. restart_run) call initialize_source()
! If this is a restart run, load the state point data and binary source
! file
if (restart_run) then
call load_state_point()
else
call initialize_source()
end if
! Display header
if (master) then
@ -403,7 +444,7 @@ contains
#endif
!$omp parallel
deallocate(micro_xs)
deallocate(micro_xs, filter_matches)
!$omp end parallel
! Increment total number of generations
@ -416,8 +457,8 @@ contains
! Broadcast tally results so that each process has access to results
if (allocated(tallies)) then
do i = 1, size(tallies)
n = size(tallies(i) % results)
call MPI_BCAST(tallies(i) % results, n, MPI_DOUBLE, 0, &
n = size(tallies(i) % obj % results)
call MPI_BCAST(tallies(i) % obj % results, n, MPI_DOUBLE, 0, &
mpi_intracomm, mpi_err)
end do
end if
@ -457,4 +498,96 @@ contains
end subroutine finalize_simulation
!===============================================================================
! CALCULATE_WORK determines how many particles each processor should simulate
!===============================================================================
subroutine calculate_work()
integer :: i ! loop index
integer :: remainder ! Number of processors with one extra particle
integer(8) :: i_bank ! Running count of number of particles
integer(8) :: min_work ! Minimum number of particles on each proc
integer(8) :: work_i ! Number of particles on rank i
if (.not. allocated(work_index)) allocate(work_index(0:n_procs))
! Determine minimum amount of particles to simulate on each processor
min_work = n_particles/n_procs
! Determine number of processors that have one extra particle
remainder = int(mod(n_particles, int(n_procs,8)), 4)
i_bank = 0
work_index(0) = 0
do i = 0, n_procs - 1
! Number of particles for rank i
if (i < remainder) then
work_i = min_work + 1
else
work_i = min_work
end if
! Set number of particles
if (rank == i) work = work_i
! Set index into source bank for rank i
i_bank = i_bank + work_i
work_index(i+1) = i_bank
end do
end subroutine calculate_work
!===============================================================================
! ALLOCATE_BANKS allocates memory for the fission and source banks
!===============================================================================
subroutine allocate_banks()
integer :: alloc_err ! allocation error code
! Allocate source bank
if (allocated(source_bank)) deallocate(source_bank)
allocate(source_bank(work), STAT=alloc_err)
! Check for allocation errors
if (alloc_err /= 0) then
call fatal_error("Failed to allocate source bank.")
end if
if (run_mode == MODE_EIGENVALUE) then
#ifdef _OPENMP
! If OpenMP is being used, each thread needs its own private fission
! bank. Since the private fission banks need to be combined at the end of
! a generation, there is also a 'master_fission_bank' that is used to
! collect the sites from each thread.
n_threads = omp_get_max_threads()
!$omp parallel
thread_id = omp_get_thread_num()
if (allocated(fission_bank)) deallocate(fission_bank)
if (thread_id == 0) then
allocate(fission_bank(3*work))
else
allocate(fission_bank(3*work/n_threads))
end if
!$omp end parallel
if (allocated(master_fission_bank)) deallocate(master_fission_bank)
allocate(master_fission_bank(3*work), STAT=alloc_err)
#else
if (allocated(fission_bank)) deallocate(fission_bank)
allocate(fission_bank(3*work), STAT=alloc_err)
#endif
! Check for allocation errors
if (alloc_err /= 0) then
call fatal_error("Failed to allocate fission bank.")
end if
end if
end subroutine allocate_banks
end module simulation

95
src/simulation_header.F90 Normal file
View file

@ -0,0 +1,95 @@
module simulation_header
use bank_header
use constants
use settings, only: gen_per_batch
implicit none
! ============================================================================
! GEOMETRY-RELATED VARIABLES
! Number of lost particles
integer :: n_lost_particles
real(8) :: log_spacing ! spacing on logarithmic grid
! ============================================================================
! EIGENVALUE SIMULATION VARIABLES
integer :: current_batch ! current batch
integer :: current_gen ! current generation within a batch
integer :: total_gen = 0 ! total number of generations simulated
! ============================================================================
! TALLY PRECISION TRIGGER VARIABLES
logical :: satisfy_triggers = .false. ! whether triggers are satisfied
integer(8) :: work ! number of particles per processor
integer(8), allocatable :: work_index(:) ! starting index in source bank for each process
integer(8) :: current_work ! index in source bank of current history simulated
! Temporary k-effective values
real(8), allocatable :: k_generation(:) ! single-generation estimates of k
real(8) :: keff = ONE ! average k over active batches
real(8) :: keff_std ! standard deviation of average k
real(8) :: k_col_abs = ZERO ! sum over batches of k_collision * k_absorption
real(8) :: k_col_tra = ZERO ! sum over batches of k_collision * k_tracklength
real(8) :: k_abs_tra = ZERO ! sum over batches of k_absorption * k_tracklength
! Shannon entropy
real(8), allocatable :: entropy(:) ! shannon entropy at each generation
real(8), allocatable :: entropy_p(:,:) ! % of source sites in each cell
! Uniform fission source weighting
real(8), allocatable :: source_frac(:,:)
! ============================================================================
! PARALLEL PROCESSING VARIABLES
#ifdef _OPENMP
integer :: n_threads = NONE ! number of OpenMP threads
integer :: thread_id ! ID of a given thread
#endif
! ============================================================================
! MISCELLANEOUS VARIABLES
integer :: restart_batch
! Flag for enabling cell overlap checking during transport
integer(8), allocatable :: overlap_check_cnt(:)
logical :: trace
! Number of distribcell maps
integer :: n_maps
!$omp threadprivate(trace, thread_id, current_work)
contains
!===============================================================================
! OVERALL_GENERATION determines the overall generation number
!===============================================================================
pure function overall_generation() result(gen)
integer :: gen
gen = gen_per_batch*(current_batch - 1) + current_gen
end function overall_generation
!===============================================================================
! FREE_MEMORY_SIMULATION deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_simulation()
if (allocated(overlap_check_cnt)) deallocate(overlap_check_cnt)
if (allocated(k_generation)) deallocate(k_generation)
if (allocated(entropy)) deallocate(entropy)
if (allocated(entropy_p)) deallocate(entropy_p)
if (allocated(source_frac)) deallocate(source_frac)
if (allocated(work_index)) deallocate(work_index)
end subroutine free_memory_simulation
end module simulation_header

92
src/source.F90
View file

@ -6,20 +6,23 @@ module source
#endif
use algorithm, only: binary_search
use bank_header, only: Bank
use bank_header, only: Bank, source_bank
use constants
use distribution_univariate, only: Discrete
use distribution_multivariate, only: SpatialBox
use error, only: fatal_error
use geometry, only: find_cell
use global
use hdf5_interface, only: file_create, file_open, file_close, read_dataset
use math
use message_passing, only: rank
use mgxs_header, only: energy_bins, num_energy_groups
use output, only: write_message
use particle_header, only: Particle
use random_lcg, only: prn, set_particle_seed, prn_set_stream
use settings
use simulation_header
use source_header, only: external_source
use string, only: to_str
use math
use state_point, only: read_source_bank, write_source_bank
implicit none
@ -103,14 +106,7 @@ contains
integer :: i ! dummy loop index
integer :: n_source ! number of source distributions
real(8) :: c ! cumulative frequency
real(8) :: r(3) ! sampled coordinates
logical :: found ! Does the source particle exist within geometry?
type(Particle) :: p ! Temporary particle for using find_cell
integer, save :: n_accept = 0 ! Number of samples accepted
integer, save :: n_reject = 0 ! Number of samples rejected
! Set weight to one by default
site % wgt = ONE
real(8) :: xi
! Set the random number generator to the source stream.
call prn_set_stream(STREAM_SOURCE)
@ -118,84 +114,18 @@ contains
! Sample from among multiple source distributions
n_source = size(external_source)
if (n_source > 1) then
r(1) = prn()*sum(external_source(:) % strength)
xi = prn()*sum(external_source(:) % strength)
c = ZERO
do i = 1, n_source
c = c + external_source(i) % strength
if (r(1) < c) exit
if (xi < c) exit
end do
else
i = 1
end if
! Repeat sampling source location until a good site has been found
found = .false.
do while (.not. found)
! Set particle defaults
call p % initialize()
! Sample spatial distribution
site % xyz(:) = external_source(i) % space % sample()
! Fill p with needed data
p % coord(1) % xyz(:) = site % xyz
p % coord(1) % uvw(:) = [ ONE, ZERO, ZERO ]
! Now search to see if location exists in geometry
call find_cell(p, found)
! Check if spatial site is in fissionable material
if (found) then
select type (space => external_source(i) % space)
type is (SpatialBox)
if (space % only_fissionable) then
if (p % material == MATERIAL_VOID) then
found = .false.
elseif (.not. materials(p % material) % fissionable) then
found = .false.
end if
end if
end select
end if
! Check for rejection
if (.not. found) then
n_reject = n_reject + 1
if (n_reject >= EXTSRC_REJECT_THRESHOLD .and. &
real(n_accept, 8)/n_reject <= EXTSRC_REJECT_FRACTION) then
call fatal_error("More than 95% of external source sites sampled &
&were rejected. Please check your external source definition.")
end if
end if
end do
! Increment number of accepted samples
n_accept = n_accept + 1
call p % clear()
! Sample angle
site % uvw(:) = external_source(i) % angle % sample()
! Check for monoenergetic source above maximum neutron energy
select type (energy => external_source(i) % energy)
type is (Discrete)
if (any(energy % x >= energy_max_neutron)) then
call fatal_error("Source energy above range of energies of at least &
&one cross section table")
end if
end select
do
! Sample energy spectrum
site % E = external_source(i) % energy % sample()
! resample if energy is greater than maximum neutron energy
if (site % E < energy_max_neutron) exit
end do
! Set delayed group
site % delayed_group = 0
! Sample source site from i-th source distribution
site = external_source(i) % sample()
! If running in MG, convert site % E to group
if (.not. run_CE) then

349
src/source_header.F90
View file

@ -1,20 +1,361 @@
module source_header
use distribution_univariate, only: Distribution
use distribution_multivariate, only: UnitSphereDistribution, SpatialDistribution
use, intrinsic :: ISO_C_BINDING
use bank_header, only: Bank
use constants
use distribution_univariate
use distribution_multivariate
use error
use geometry, only: find_cell
use material_header, only: materials
use nuclide_header, only: energy_max_neutron
use particle_header, only: Particle
use string, only: to_lower
use xml_interface
implicit none
private
public :: free_memory_source
integer :: n_accept = 0 ! Number of samples accepted
integer :: n_reject = 0 ! Number of samples rejected
!===============================================================================
! SOURCEDISTRIBUTION describes an external source of particles for a
! fixed-source problem or for the starting source in a k eigenvalue problem
!===============================================================================
type SourceDistribution
real(8) :: strength ! source strength
type, public :: SourceDistribution
real(8) :: strength = ONE ! source strength
class(SpatialDistribution), allocatable :: space ! spatial distribution
class(UnitSphereDistribution), allocatable :: angle ! angle distribution
class(Distribution), allocatable :: energy ! energy distribution
contains
procedure :: from_xml
procedure :: sample
end type SourceDistribution
! Number of external source distributions
integer(C_INT32_T), public, bind(C) :: n_sources = 0
! External source distributions
type(SourceDistribution), public, allocatable :: external_source(:)
contains
subroutine from_xml(this, node, path_source)
class(SourceDistribution), intent(inout) :: this
type(XMLNode), intent(in) :: node
character(MAX_FILE_LEN), intent(out) :: path_source
integer :: n
logical :: file_exists
character(MAX_WORD_LEN) :: type
type(XMLNode) :: node_space
type(XMLNode) :: node_angle
type(XMLNode) :: node_dist
! Check for source strength
if (check_for_node(node, "strength")) then
call get_node_value(node, "strength", this % strength)
end if
! Check for external source file
if (check_for_node(node, "file")) then
! Copy path of source file
call get_node_value(node, "file", path_source)
! Check if source file exists
inquire(FILE=path_source, EXIST=file_exists)
if (.not. file_exists) then
call fatal_error("Source file '" // trim(path_source) &
// "' does not exist!")
end if
else
! Spatial distribution for external source
if (check_for_node(node, "space")) then
! Get pointer to spatial distribution
node_space = node % child("space")
! Check for type of spatial distribution
type = ''
if (check_for_node(node_space, "type")) &
call get_node_value(node_space, "type", type)
select case (to_lower(type))
case ('cartesian')
allocate(CartesianIndependent :: this % space)
case ('box')
allocate(SpatialBox :: this % space)
case ('fission')
allocate(SpatialBox :: this % space)
select type(space => this % space)
type is (SpatialBox)
space % only_fissionable = .true.
end select
case ('point')
allocate(SpatialPoint :: this % space)
case default
call fatal_error("Invalid spatial distribution for external source: "&
// trim(type))
end select
! Read spatial distribution from XML
call this % space % from_xml(node_space)
else
! If no spatial distribution specified, make it a point source
allocate(SpatialPoint :: this % space)
select type (space => this % space)
type is (SpatialPoint)
space % xyz(:) = [ZERO, ZERO, ZERO]
end select
end if
! Determine external source angular distribution
if (check_for_node(node, "angle")) then
! Get pointer to angular distribution
node_angle = node % child("angle")
! Check for type of angular distribution
type = ''
if (check_for_node(node_angle, "type")) &
call get_node_value(node_angle, "type", type)
select case (to_lower(type))
case ('isotropic')
allocate(Isotropic :: this % angle)
case ('monodirectional')
allocate(Monodirectional :: this % angle)
case ('mu-phi')
allocate(PolarAzimuthal :: this % angle)
case default
call fatal_error("Invalid angular distribution for external source: "&
// trim(type))
end select
! Read reference directional unit vector
if (check_for_node(node_angle, "reference_uvw")) then
n = node_word_count(node_angle, "reference_uvw")
if (n /= 3) then
call fatal_error('Angular distribution reference direction must have &
&three parameters specified.')
end if
call get_node_array(node_angle, "reference_uvw", &
this % angle % reference_uvw)
else
! By default, set reference unit vector to be positive z-direction
this % angle % reference_uvw(:) = [ZERO, ZERO, ONE]
end if
! Read parameters for angle distribution
select type (angle => this % angle)
type is (Monodirectional)
call get_node_array(node_angle, "reference_uvw", &
this % angle % reference_uvw)
type is (PolarAzimuthal)
if (check_for_node(node_angle, "mu")) then
node_dist = node_angle % child("mu")
call distribution_from_xml(angle % mu, node_dist)
else
allocate(Uniform :: angle%mu)
select type (mu => angle%mu)
type is (Uniform)
mu % a = -ONE
mu % b = ONE
end select
end if
if (check_for_node(node_angle, "phi")) then
node_dist = node_angle % child("phi")
call distribution_from_xml(angle % phi, node_dist)
else
allocate(Uniform :: angle%phi)
select type (phi => angle%phi)
type is (Uniform)
phi % a = ZERO
phi % b = TWO*PI
end select
end if
end select
else
! Set default angular distribution isotropic
allocate(Isotropic :: this % angle)
this % angle % reference_uvw(:) = [ZERO, ZERO, ONE]
end if
! Determine external source energy distribution
if (check_for_node(node, "energy")) then
node_dist = node % child("energy")
call distribution_from_xml(this % energy, node_dist)
else
! Default to a Watt spectrum with parameters 0.988 MeV and 2.249 MeV^-1
allocate(Watt :: this % energy)
select type(energy => this % energy)
type is (Watt)
energy % a = 0.988e6_8
energy % b = 2.249e-6_8
end select
end if
end if
end subroutine from_xml
function sample(this) result(site)
class(SourceDistribution), intent(in) :: this
type(Bank) :: site
logical :: found ! Does the source particle exist within geometry?
type(Particle) :: p ! Temporary particle for using find_cell
! Set weight to one by default
site % wgt = ONE
! Repeat sampling source location until a good site has been found
found = .false.
do while (.not. found)
! Set particle defaults
call p % initialize()
! Sample spatial distribution
site % xyz(:) = this % space % sample()
! Fill p with needed data
p % coord(1) % xyz(:) = site % xyz
p % coord(1) % uvw(:) = [ ONE, ZERO, ZERO ]
! Now search to see if location exists in geometry
call find_cell(p, found)
! Check if spatial site is in fissionable material
if (found) then
select type (space => this % space)
type is (SpatialBox)
if (space % only_fissionable) then
if (p % material == MATERIAL_VOID) then
found = .false.
elseif (.not. materials(p % material) % fissionable) then
found = .false.
end if
end if
end select
end if
! Check for rejection
if (.not. found) then
n_reject = n_reject + 1
if (n_reject >= EXTSRC_REJECT_THRESHOLD .and. &
real(n_accept, 8)/n_reject <= EXTSRC_REJECT_FRACTION) then
call fatal_error("More than 95% of external source sites sampled &
&were rejected. Please check your external source definition.")
end if
end if
end do
! Increment number of accepted samples
n_accept = n_accept + 1
call p % clear()
! Sample angle
site % uvw(:) = this % angle % sample()
! Check for monoenergetic source above maximum neutron energy
select type (energy => this % energy)
type is (Discrete)
if (any(energy % x >= energy_max_neutron)) then
call fatal_error("Source energy above range of energies of at least &
&one cross section table")
end if
end select
do
! Sample energy spectrum
site % E = this % energy % sample()
! resample if energy is greater than maximum neutron energy
if (site % E < energy_max_neutron) exit
end do
! Set delayed group
site % delayed_group = 0
end function sample
!===============================================================================
! FREE_MEMORY_SOURCE deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_source()
n_sources = 0
if (allocated(external_source)) deallocate(external_source)
end subroutine free_memory_source
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_extend_sources(n, index_start, index_end) result(err) bind(C)
! Extend the external_source array by n elements
integer(C_INT32_T), value, intent(in) :: n
integer(C_INT32_T), optional, intent(out) :: index_start
integer(C_INT32_T), optional, intent(out) :: index_end
integer(C_INT) :: err
type(SourceDistribution), allocatable :: temp(:) ! temporary array
if (n_sources == 0) then
! Allocate external_source array
allocate(external_source(n))
else
! Allocate external_source array with increased size
allocate(temp(n_sources + n))
! Copy original source array to temporary array
temp(1:n_sources) = external_source
! Move allocation from temporary array
call move_alloc(FROM=temp, TO=external_source)
end if
! Return indices in external_source array
if (present(index_start)) index_start = n_sources + 1
if (present(index_end)) index_end = n_sources + n
n_sources = n_sources + n
err = 0
end function openmc_extend_sources
function openmc_source_set_strength(index, strength) result(err) bind(C)
integer(C_INT32_T), value, intent(in) :: index
real(C_DOUBLE), value, intent(in) :: strength
integer(C_INT) :: err
if (index >= 1 .and. index <= n_sources) then
if (strength > ZERO) then
external_source(index) % strength = strength
err = 0
else
err = E_INVALID_ARGUMENT
call set_errmsg("Source strength must be positive.")
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in external source array is out of bounds.")
end if
end function openmc_source_set_strength
end module source_header

60
src/state_point.F90
View file

@ -15,18 +15,25 @@ module state_point
use hdf5
use cmfd_header
use constants
use eigenvalue, only: openmc_get_keff
use endf, only: reaction_name
use error, only: fatal_error, warning
use global
use hdf5_interface
use mesh_header, only: RegularMesh
use mesh_header, only: RegularMesh, meshes, n_meshes
use message_passing
use mgxs_header, only: nuclides_MG
use nuclide_header, only: nuclides
use output, only: write_message, time_stamp
use random_lcg, only: seed
use settings
use simulation_header
use string, only: to_str, count_digits, zero_padded
use tally_header, only: TallyObject
use tally_header
use tally_filter_header
use tally_derivative_header, only: tally_derivs
use timer_header
implicit none
@ -45,13 +52,12 @@ contains
integer, allocatable :: id_array(:)
integer(HID_T) :: file_id
integer(HID_T) :: cmfd_group, tallies_group, tally_group, meshes_group, &
mesh_group, filters_group, filter_group, derivs_group, &
filters_group, filter_group, derivs_group, &
deriv_group, runtime_group
integer(C_INT) :: err
real(C_DOUBLE) :: k_combined(2)
character(MAX_WORD_LEN), allocatable :: str_array(:)
character(MAX_FILE_LEN) :: filename
type(TallyObject), pointer :: tally
! Set filename for state point
filename = trim(path_output) // 'statepoint.' // &
@ -158,21 +164,7 @@ contains
! Write information for meshes
MESH_LOOP: do i = 1, n_meshes
associate (m => meshes(i))
mesh_group = create_group(meshes_group, "mesh " &
// trim(to_str(m % id)))
select case (m % type)
case (MESH_REGULAR)
call write_dataset(mesh_group, "type", "regular")
end select
call write_dataset(mesh_group, "dimension", m % dimension)
call write_dataset(mesh_group, "lower_left", m % lower_left)
call write_dataset(mesh_group, "upper_right", m % upper_right)
call write_dataset(mesh_group, "width", m % width)
call close_group(mesh_group)
end associate
call meshes(i) % to_hdf5(meshes_group)
end do MESH_LOOP
end if
@ -241,7 +233,7 @@ contains
! Write array of tally IDs
allocate(id_array(n_tallies))
do i = 1, n_tallies
id_array(i) = tallies(i) % id
id_array(i) = tallies(i) % obj % id
end do
call write_attribute(tallies_group, "ids", id_array)
deallocate(id_array)
@ -250,7 +242,7 @@ contains
TALLY_METADATA: do i = 1, n_tallies
! Get pointer to tally
tally => tallies(i)
associate (tally => tallies(i) % obj)
tally_group = create_group(tallies_group, "tally " // &
trim(to_str(tally % id)))
@ -355,6 +347,7 @@ contains
deallocate(str_array)
call close_group(tally_group)
end associate
end do TALLY_METADATA
end if
@ -378,7 +371,7 @@ contains
call write_dataset(file_id, "global_tallies", global_tallies)
! Write tallies
if (tallies_on) then
if (active_tallies % size() > 0) then
! Indicate that tallies are on
call write_attribute(file_id, "tallies_present", 1)
@ -386,14 +379,13 @@ contains
! Write all tally results
TALLY_RESULTS: do i = 1, n_tallies
! Set point to current tally
tally => tallies(i)
! Write sum and sum_sq for each bin
tally_group = open_group(tallies_group, "tally " &
// to_str(tally % id))
call tally % write_results_hdf5(tally_group)
call close_group(tally_group)
associate (tally => tallies(i) % obj)
! Write sum and sum_sq for each bin
tally_group = open_group(tallies_group, "tally " &
// to_str(tally % id))
call tally % write_results_hdf5(tally_group)
call close_group(tally_group)
end associate
end do TALLY_RESULTS
call close_group(tallies_group)
@ -558,7 +550,7 @@ contains
call write_dataset(file_id, "global_tallies", global_temp)
end if
if (tallies_on) then
if (active_tallies % size() > 0) then
! Indicate that tallies are on
if (master) then
call write_attribute(file_id, "tallies_present", 1)
@ -566,7 +558,7 @@ contains
! Write all tally results
TALLY_RESULTS: do i = 1, n_tallies
associate (t => tallies(i))
associate (t => tallies(i) % obj)
! Determine size of tally results array
m = size(t % results, 2)
n = size(t % results, 3)
@ -775,7 +767,7 @@ contains
tallies_group = open_group(file_id, "tallies")
TALLY_RESULTS: do i = 1, n_tallies
associate (t => tallies(i))
associate (t => tallies(i) % obj)
! Read sum, sum_sq, and N for each bin
tally_group = open_group(tallies_group, "tally " // &
trim(to_str(t % id)))

43
src/string.F90
View file

@ -514,4 +514,47 @@ contains
if (inword) n = n + 1
end function word_count
!===============================================================================
! TO_F_STRING takes a null-terminated array of C chars and turns it into a
! deferred-length character string. Yay Fortran 2003!
!===============================================================================
function to_f_string(c_string) result(f_string)
character(kind=C_CHAR), intent(in) :: c_string(*)
character(:), allocatable :: f_string
integer :: i, n
! Determine length of original string
n = 0
do while (c_string(n + 1) /= C_NULL_CHAR)
n = n + 1
end do
! Copy C string character by character
allocate(character(len=n) :: f_string)
do i = 1, n
f_string(i:i) = c_string(i)
end do
end function to_f_string
!===============================================================================
! TO_C_STRING takes a space-padded Fortran character and turns it into a
! null-terminated C char array. Yay Fortran 2003!
!===============================================================================
function to_c_string(f_string) result(c_string)
character(*), intent(in) :: f_string
character(kind=C_CHAR) :: c_string(len_trim(f_string) + 1)
integer :: i, n
! Copy Fortran string character by character
n = len_trim(f_string)
do i = 1, n
c_string(i) = f_string(i:i)
end do
c_string(n + 1) = C_NULL_CHAR
end function to_c_string
end module string

18
src/summary.F90
View file

@ -4,19 +4,19 @@ module summary
use constants
use endf, only: reaction_name
use geometry_header, only: root_universe, Cell, Universe, Lattice, &
RectLattice, HexLattice
use global
use geometry_header
use hdf5_interface
use material_header, only: Material
use material_header, only: Material, n_materials
use mesh_header, only: RegularMesh
use message_passing
use mgxs_header, only: nuclides_MG
use nuclide_header
use output, only: time_stamp
use settings, only: run_CE
use surface_header
use string, only: to_str
use tally_header, only: TallyObject
use tally_filter, only: find_offset
use tally_filter_distribcell, only: find_offset
implicit none
private
@ -79,12 +79,12 @@ contains
! Write useful data from nuclide objects
nuclide_group = create_group(file_id, "nuclides")
call write_attribute(nuclide_group, "n_nuclides", n_nuclides_total)
call write_attribute(nuclide_group, "n_nuclides", n_nuclides)
! Build array of nuclide names and awrs
allocate(nucnames(n_nuclides_total))
allocate(awrs(n_nuclides_total))
do i = 1, n_nuclides_total
allocate(nucnames(n_nuclides))
allocate(awrs(n_nuclides))
do i = 1, n_nuclides
if (run_CE) then
nucnames(i) = nuclides(i) % name
awrs(i) = nuclides(i) % awr

20
src/surface_header.F90
View file

@ -1,6 +1,9 @@
module surface_header
use, intrinsic :: ISO_C_BINDING
use constants, only: NONE, ONE, TWO, ZERO, HALF, INFINITY, FP_COINCIDENT
use dict_header, only: DictIntInt
implicit none
@ -193,6 +196,13 @@ module surface_header
procedure :: normal => quadric_normal
end type SurfaceQuadric
integer(C_INT32_T), bind(C) :: n_surfaces ! # of surfaces
type(SurfaceContainer), allocatable, target :: surfaces(:)
! Dictionary that maps user IDs to indices in 'surfaces'
type(DictIntInt) :: surface_dict
contains
!===============================================================================
@ -1050,4 +1060,14 @@ contains
end associate
end function quadric_normal
!===============================================================================
! FREE_MEMORY_SURFACES deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_surfaces()
n_surfaces = 0
if (allocated(surfaces)) deallocate(surfaces)
call surface_dict % clear()
end subroutine free_memory_surfaces
end module surface_header

261
src/tally.F90 → src/tallies/tally.F90
View file

@ -7,18 +7,19 @@ module tally
use cross_section, only: multipole_deriv_eval
use error, only: fatal_error
use geometry_header
use global
use math, only: t_percentile, calc_pn, calc_rn
use mesh, only: get_mesh_bin, bin_to_mesh_indices, &
get_mesh_indices, mesh_indices_to_bin, &
mesh_intersects_1d, mesh_intersects_2d, &
mesh_intersects_3d
use mesh_header, only: RegularMesh
use mesh_header, only: RegularMesh, meshes
use message_passing
use mgxs_header
use nuclide_header
use output, only: header
use particle_header, only: LocalCoord, Particle
use settings
use simulation_header
use string, only: to_str
use tally_derivative_header, only: tally_derivs
use tally_filter
use tally_header
implicit none
@ -2162,22 +2163,18 @@ contains
! the user requests <nuclides>all</nuclides>.
!===============================================================================
subroutine score_all_nuclides(p, i_tally, flux, filter_index)
subroutine score_all_nuclides(p, t, flux, filter_index)
type(Particle), intent(in) :: p
integer, intent(in) :: i_tally
type(TallyObject), intent(inout) :: t
real(8), intent(in) :: flux
integer, intent(in) :: filter_index
integer :: i ! loop index for nuclides in material
integer :: i_nuclide ! index in nuclides array
real(8) :: atom_density ! atom density of single nuclide in atom/b-cm
type(TallyObject), pointer :: t
type(Material), pointer :: mat
! Get pointer to tally
t => tallies(i_tally)
! Get pointer to current material. We need this in order to determine what
! nuclides are in the material
mat => materials(p % material)
@ -2205,7 +2202,7 @@ contains
atom_density = ZERO
! Determine score for each bin
call score_general(p, t, n_nuclides_total*t % n_score_bins, filter_index, &
call score_general(p, t, n_nuclides*t % n_score_bins, filter_index, &
i_nuclide, atom_density, flux)
end subroutine score_all_nuclides
@ -2229,7 +2226,6 @@ contains
integer :: i_nuclide ! index in nuclides array
real(8) :: filter_weight ! combined weight of all filters
logical :: finished ! found all valid bin combinations
type(TallyObject), pointer :: t
! A loop over all tallies is necessary because we need to simultaneously
! determine different filter bins for the same tally in order to score to it
@ -2237,7 +2233,7 @@ contains
TALLY_LOOP: do i = 1, active_analog_tallies % size()
! Get index of tally and pointer to tally
i_tally = active_analog_tallies % data(i)
t => tallies(i_tally)
associate (t => tallies(i_tally) % obj)
! Find all valid bins in each filter if they have not already been found
! for a previous tally.
@ -2299,7 +2295,7 @@ contains
elseif (k == p % event_nuclide + 1) then
! After we've tallied the individual nuclide bin, we also need
! to contribute to the total material bin which is the last bin
k = n_nuclides_total + 1
k = n_nuclides + 1
else
! After we've tallied in both the individual nuclide bin and the
! total material bin, we're done
@ -2353,6 +2349,7 @@ contains
if (assume_separate) exit TALLY_LOOP
end associate
end do TALLY_LOOP
! Reset filter matches flag
@ -2374,7 +2371,6 @@ contains
real(8) :: filter_weight ! combined weight of all filters
real(8) :: atom_density
logical :: finished ! found all valid bin combinations
type(TallyObject), pointer :: t
type(Material), pointer :: mat
! A loop over all tallies is necessary because we need to simultaneously
@ -2383,7 +2379,7 @@ contains
TALLY_LOOP: do i = 1, active_analog_tallies % size()
! Get index of tally and pointer to tally
i_tally = active_analog_tallies % data(i)
t => tallies(i_tally)
associate (t => tallies(i_tally) % obj)
! Get pointer to current material. We need this in order to determine what
! nuclides are in the material
@ -2491,6 +2487,7 @@ contains
if (assume_separate) exit TALLY_LOOP
end associate
end do TALLY_LOOP
! Reset filter matches flag
@ -2750,7 +2747,6 @@ contains
real(8) :: atom_density ! atom density of single nuclide in atom/b-cm
real(8) :: filter_weight ! combined weight of all filters
logical :: finished ! found all valid bin combinations
type(TallyObject), pointer :: t
type(Material), pointer :: mat
! Determine track-length estimate of flux
@ -2762,7 +2758,7 @@ contains
TALLY_LOOP: do i = 1, active_tracklength_tallies % size()
! Get index of tally and pointer to tally
i_tally = active_tracklength_tallies % data(i)
t => tallies(i_tally)
associate (t => tallies(i_tally) % obj)
! Find all valid bins in each filter if they have not already been found
! for a previous tally.
@ -2807,8 +2803,7 @@ contains
if (t % all_nuclides) then
if (p % material /= MATERIAL_VOID) then
call score_all_nuclides(p, i_tally, flux * filter_weight, &
filter_index)
call score_all_nuclides(p, t, flux * filter_weight, filter_index)
end if
else
@ -2879,6 +2874,7 @@ contains
if (assume_separate) exit TALLY_LOOP
end associate
end do TALLY_LOOP
! Reset filter matches flag
@ -2911,7 +2907,6 @@ contains
! in atom/b-cm
real(8) :: filter_weight ! combined weight of all filters
logical :: finished ! found all valid bin combinations
type(TallyObject), pointer :: t
type(Material), pointer :: mat
! Determine collision estimate of flux
@ -2928,7 +2923,7 @@ contains
TALLY_LOOP: do i = 1, active_collision_tallies % size()
! Get index of tally and pointer to tally
i_tally = active_collision_tallies % data(i)
t => tallies(i_tally)
associate (t => tallies(i_tally) % obj)
! Find all valid bins in each filter if they have not already been found
! for a previous tally.
@ -2973,8 +2968,7 @@ contains
if (t % all_nuclides) then
if (p % material /= MATERIAL_VOID) then
call score_all_nuclides(p, i_tally, flux * filter_weight, &
filter_index)
call score_all_nuclides(p, t, flux * filter_weight, filter_index)
end if
else
@ -3045,6 +3039,7 @@ contains
if (assume_separate) exit TALLY_LOOP
end associate
end do TALLY_LOOP
! Reset filter matches flag
@ -3082,7 +3077,7 @@ contains
TALLY_LOOP: do i = 1, active_surface_tallies % size()
! Get index of tally and pointer to tally
i_tally = active_surface_tallies % data(i)
associate (t => tallies(i_tally))
associate (t => tallies(i_tally) % obj)
! Find all valid bins in each filter if they have not already been found
! for a previous tally.
@ -3215,7 +3210,6 @@ contains
logical :: end_in_mesh ! particle's ending xyz in mesh?
logical :: cross_surface ! whether the particle crosses a surface
logical :: energy_filter ! energy filter present
type(TallyObject), pointer :: t
type(RegularMesh), pointer :: m
TALLY_LOOP: do i = 1, active_current_tallies % size()
@ -3225,7 +3219,7 @@ contains
! Get pointer to tally
i_tally = active_current_tallies % data(i)
t => tallies(i_tally)
associate (t => tallies(i_tally) % obj)
! Check for energy filter
energy_filter = (t % find_filter(FILTER_ENERGYIN) > 0)
@ -3253,19 +3247,13 @@ contains
n_dim = m % n_dimension
! Determine indices for starting and ending location
call get_mesh_indices(m, xyz0, ijk0, start_in_mesh)
call get_mesh_indices(m, xyz1, ijk1, end_in_mesh)
call m % get_indices(xyz0, ijk0, start_in_mesh)
call m % get_indices(xyz1, ijk1, end_in_mesh)
! Check to see if start or end is in mesh -- if not, check if track still
! intersects with mesh
if ((.not. start_in_mesh) .and. (.not. end_in_mesh)) then
if (n_dim == 1) then
if (.not. mesh_intersects_1d(m, xyz0, xyz1)) cycle
else if (n_dim == 2) then
if (.not. mesh_intersects_2d(m, xyz0, xyz1)) cycle
else
if (.not. mesh_intersects_3d(m, xyz0, xyz1)) cycle
end if
if (.not. m % intersects(xyz0, xyz1)) cycle
end if
! Calculate number of surface crossings
@ -3344,7 +3332,7 @@ contains
all(ijk0(:n_dim) <= m % dimension)) then
filter_matches(i_filter_surf) % bins % data(1) = d1 * 4 - 1
filter_matches(i_filter_mesh) % bins % data(1) = &
mesh_indices_to_bin(m, ijk0)
m % get_bin_from_indices(ijk0)
filter_index = 1
do k = 1, size(t % filter)
filter_index = filter_index + (filter_matches(t % &
@ -3383,7 +3371,7 @@ contains
ijk0(d1) = ijk0(d1) + 1
filter_matches(i_filter_surf) % bins % data(1) = d1 * 4 - 2
filter_matches(i_filter_mesh) % bins % data(1) = &
mesh_indices_to_bin(m, ijk0)
m % get_bin_from_indices(ijk0)
filter_index = 1
do k = 1, size(t % filter)
filter_index = filter_index + (filter_matches(t % &
@ -3406,7 +3394,7 @@ contains
all(ijk0(:n_dim) <= m % dimension)) then
filter_matches(i_filter_surf) % bins % data(1) = d1 * 4 - 3
filter_matches(i_filter_mesh) % bins % data(1) = &
mesh_indices_to_bin(m, ijk0)
m % get_bin_from_indices(ijk0)
filter_index = 1
do k = 1, size(t % filter)
filter_index = filter_index + (filter_matches(t % &
@ -3445,7 +3433,7 @@ contains
ijk0(d1) = ijk0(d1) - 1
filter_matches(i_filter_surf) % bins % data(1) = d1 * 4
filter_matches(i_filter_mesh) % bins % data(1) = &
mesh_indices_to_bin(m, ijk0)
m % get_bin_from_indices(ijk0)
filter_index = 1
do k = 1, size(t % filter)
filter_index = filter_index + (filter_matches(t % &
@ -3467,6 +3455,7 @@ contains
xyz0 = xyz0 + distance * uvw
end do
end associate
end do TALLY_LOOP
end subroutine score_surface_current
@ -4272,11 +4261,11 @@ contains
if (master .or. (.not. reduce_tallies)) then
! Accumulate results for each tally
do i = 1, active_tallies % size()
call accumulate_tally(tallies(active_tallies % data(i)))
call tallies(active_tallies % data(i)) % obj % accumulate()
end do
if (run_mode == MODE_EIGENVALUE) then
if (active_batches) then
if (current_batch > n_inactive) then
! Accumulate products of different estimators of k
k_col = global_tallies(RESULT_VALUE, K_COLLISION) / total_weight
k_abs = global_tallies(RESULT_VALUE, K_ABSORPTION) / total_weight
@ -4317,7 +4306,7 @@ contains
real(C_DOUBLE) :: temp(N_GLOBAL_TALLIES), temp2(N_GLOBAL_TALLIES)
do i = 1, active_tallies % size()
associate (t => tallies(active_tallies % data(i)))
associate (t => tallies(active_tallies % data(i)) % obj)
m = size(t % results, 2)
n = size(t % results, 3)
@ -4362,123 +4351,83 @@ contains
#endif
!===============================================================================
! ACCUMULATE_TALLY
! SETUP_ACTIVE_TALLIES
!===============================================================================
subroutine accumulate_tally(t)
subroutine setup_active_tallies()
type(TallyObject), intent(inout) :: t
integer :: i ! loop counter
integer :: i, j
real(C_DOUBLE) :: val
call active_tallies % clear()
call active_analog_tallies % clear()
call active_collision_tallies % clear()
call active_tracklength_tallies % clear()
call active_surface_tallies % clear()
call active_current_tallies % clear()
! Increment number of realizations
if (reduce_tallies) then
t % n_realizations = t % n_realizations + 1
do i = 1, n_tallies
associate (t => tallies(i) % obj)
if (t % active) then
! Add tally to active tallies
call active_tallies % push_back(i)
! Check what type of tally this is and add it to the appropriate list
if (t % type == TALLY_VOLUME) then
if (t % estimator == ESTIMATOR_ANALOG) then
call active_analog_tallies % push_back(i)
elseif (t % estimator == ESTIMATOR_TRACKLENGTH) then
call active_tracklength_tallies % push_back(i)
elseif (t % estimator == ESTIMATOR_COLLISION) then
call active_collision_tallies % push_back(i)
end if
elseif (t % type == TALLY_MESH_CURRENT) then
call active_current_tallies % push_back(i)
elseif (t % type == TALLY_SURFACE) then
call active_surface_tallies % push_back(i)
end if
end if
end associate
end do
end subroutine setup_active_tallies
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_tally_set_type(index, type) result(err) bind(C)
! Set the type of the tally
integer(C_INT32_T), value, intent(in) :: index
character(kind=C_CHAR), intent(in) :: type(*)
integer(C_INT) :: err
integer(C_INT32_T) :: empty(0)
character(:), allocatable :: type_
! Convert C string to Fortran string
type_ = to_f_string(type)
err = 0
if (index >= 1 .and. index <= n_tallies) then
if (allocated(tallies(index) % obj)) then
err = E_ALLOCATE
call set_errmsg("Tally type has already been set.")
else
select case (type_)
case ('generic')
allocate(TallyObject :: tallies(index) % obj)
case default
err = E_UNASSIGNED
call set_errmsg("Unknown tally type: " // trim(type_))
end select
! When a tally is allocated, set it to have 0 filters
err = tallies(index) % obj % set_filters(empty)
end if
else
t % n_realizations = t % n_realizations + n_procs
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in tallies array is out of bounds.")
end if
! Accumulate each result
do j = 1, size(t % results, 3)
do i = 1, size(t % results, 2)
val = t % results(RESULT_VALUE, i, j)/total_weight
t % results(RESULT_VALUE, i, j) = ZERO
t % results(RESULT_SUM, i, j) = &
t % results(RESULT_SUM, i, j) + val
t % results(RESULT_SUM_SQ, i, j) = &
t % results(RESULT_SUM_SQ, i, j) + val*val
end do
end do
end subroutine accumulate_tally
!===============================================================================
! SETUP_ACTIVE_USERTALLIES
!===============================================================================
subroutine setup_active_usertallies()
integer :: i ! loop counter
do i = 1, n_user_tallies
! Add tally to active tallies
call active_tallies % push_back(i_user_tallies + i)
! Check what type of tally this is and add it to the appropriate list
if (user_tallies(i) % type == TALLY_VOLUME) then
if (user_tallies(i) % estimator == ESTIMATOR_ANALOG) then
call active_analog_tallies % push_back(i_user_tallies + i)
elseif (user_tallies(i) % estimator == ESTIMATOR_TRACKLENGTH) then
call active_tracklength_tallies % push_back(i_user_tallies + i)
elseif (user_tallies(i) % estimator == ESTIMATOR_COLLISION) then
call active_collision_tallies % push_back(i_user_tallies + i)
end if
elseif (user_tallies(i) % type == TALLY_MESH_CURRENT) then
call active_current_tallies % push_back(i_user_tallies + i)
elseif (user_tallies(i) % type == TALLY_SURFACE) then
call active_surface_tallies % push_back(i_user_tallies + i)
end if
end do
call active_tallies % shrink_to_fit()
call active_analog_tallies % shrink_to_fit()
call active_tracklength_tallies % shrink_to_fit()
call active_collision_tallies % shrink_to_fit()
call active_current_tallies % shrink_to_fit()
call active_surface_tallies % shrink_to_fit()
end subroutine setup_active_usertallies
!===============================================================================
! SETUP_ACTIVE_CMFDTALLIES
!===============================================================================
subroutine setup_active_cmfdtallies()
integer :: i ! loop counter
! check to see if any of the active tally lists has been allocated
if (active_tallies % size() > 0) then
call fatal_error("Active tallies should not exist before CMFD tallies!")
else if (active_analog_tallies % size() > 0) then
call fatal_error('Active analog tallies should not exist before CMFD &
&tallies!')
else if (active_tracklength_tallies % size() > 0) then
call fatal_error("Active tracklength tallies should not exist before &
&CMFD tallies!")
else if (active_current_tallies % size() > 0) then
call fatal_error("Active current tallies should not exist before CMFD &
&tallies!")
else if (active_surface_tallies % size() > 0) then
call fatal_error("Active cell to cell tallies should not exist before &
&CMFD tallies!")
end if
do i = 1, n_cmfd_tallies
! Add CMFD tally to active tallies
call active_tallies % push_back(i_cmfd_tallies + i)
! Check what type of tally this is and add it to the appropriate list
if (cmfd_tallies(i) % type == TALLY_VOLUME) then
if (cmfd_tallies(i) % estimator == ESTIMATOR_ANALOG) then
call active_analog_tallies % push_back(i_cmfd_tallies + i)
elseif (cmfd_tallies(i) % estimator == ESTIMATOR_TRACKLENGTH) then
call active_tracklength_tallies % push_back(i_cmfd_tallies + i)
end if
elseif (cmfd_tallies(i) % type == TALLY_MESH_CURRENT) then
call active_current_tallies % push_back(i_cmfd_tallies + i)
end if
end do
call active_tallies % shrink_to_fit()
call active_analog_tallies % shrink_to_fit()
call active_tracklength_tallies % shrink_to_fit()
call active_collision_tallies % shrink_to_fit()
call active_current_tallies % shrink_to_fit()
end subroutine setup_active_cmfdtallies
end function openmc_tally_set_type
end module tally

102
src/tallies/tally_derivative_header.F90 Normal file
View file

@ -0,0 +1,102 @@
module tally_derivative_header
use constants
use dict_header, only: DictIntInt
use error, only: fatal_error
use nuclide_header, only: nuclide_dict
use string, only: to_str, to_lower
use xml_interface
implicit none
private
public :: free_memory_tally_derivative
!===============================================================================
! TALLYDERIVATIVE describes a first-order derivative that can be applied to
! tallies.
!===============================================================================
type, public :: TallyDerivative
integer :: id
integer :: variable
integer :: diff_material
integer :: diff_nuclide
real(8) :: flux_deriv
contains
procedure :: from_xml
end type TallyDerivative
type(TallyDerivative), public, allocatable :: tally_derivs(:)
!$omp threadprivate(tally_derivs)
! Dictionary that maps user IDs to indices in 'tally_derivs'
type(DictIntInt), public :: tally_deriv_dict
contains
subroutine from_xml(this, node)
class(TallyDerivative), intent(inout) :: this
type(XMLNode), intent(in) :: node
character(MAX_WORD_LEN) :: temp_str
character(MAX_WORD_LEN) :: word
! Copy the derivative id.
if (check_for_node(node, "id")) then
call get_node_value(node, "id", this % id)
else
call fatal_error("Must specify an ID for <derivative> elements in the&
& tally XML file")
end if
! Make sure the id is > 0.
if (this % id <= 0) then
call fatal_error("<derivative> IDs must be an integer greater than &
&zero")
end if
! Make sure this id has not already been used.
if (tally_deriv_dict % has_key(this % id)) then
call fatal_error("Two or more <derivative>'s use the same unique &
&ID: " // trim(to_str(this % id)))
end if
! Read the independent variable name.
call get_node_value(node, "variable", temp_str)
temp_str = to_lower(temp_str)
select case(temp_str)
case("density")
this % variable = DIFF_DENSITY
case("nuclide_density")
this % variable = DIFF_NUCLIDE_DENSITY
call get_node_value(node, "nuclide", word)
word = trim(to_lower(word))
if (.not. nuclide_dict % has_key(word)) then
call fatal_error("Could not find the nuclide " &
// trim(word) // " specified in derivative " &
// trim(to_str(this % id)) // " in any material.")
end if
this % diff_nuclide = nuclide_dict % get_key(word)
case("temperature")
this % variable = DIFF_TEMPERATURE
end select
call get_node_value(node, "material", this % diff_material)
end subroutine from_xml
!===============================================================================
! FREE_MEMORY_TALLY_DERIVATIVE deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_tally_derivative()
!$omp parallel
if (allocated(tally_derivs)) deallocate(tally_derivs)
!$omp end parallel
end subroutine free_memory_tally_derivative
end module tally_derivative_header

158
src/tallies/tally_filter.F90 Normal file
View file

@ -0,0 +1,158 @@
module tally_filter
use, intrinsic :: ISO_C_BINDING
use hdf5, only: HID_T
use error
use string, only: to_f_string
use tally_filter_header
! Inherit other filters
use tally_filter_azimuthal
use tally_filter_cell
use tally_filter_cellborn
use tally_filter_cellfrom
use tally_filter_delayedgroup
use tally_filter_distribcell
use tally_filter_energy
use tally_filter_energyfunc
use tally_filter_material
use tally_filter_mesh
use tally_filter_mu
use tally_filter_polar
use tally_filter_surface
use tally_filter_universe
implicit none
contains
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_filter_get_type(index, type) result(err) bind(C)
! Get the type of a filter
integer(C_INT32_T), value, intent(in) :: index
character(kind=C_CHAR), intent(out) :: type(*)
integer(C_INT) :: err
integer :: i
character(20) :: type_
if (index >= 1 .and. index <= n_filters) then
if (allocated(filters(index) % obj)) then
! Get type as a Fortran string
select type (f => filters(index) % obj)
type is (AzimuthalFilter)
type_ = 'azimuthal'
type is (CellFilter)
type_ = 'cell'
type is (CellbornFilter)
type_ = 'cellborn'
type is (CellfromFilter)
type_ = 'cellfrom'
type is (DelayedGroupFilter)
type_ = 'delayedgroup'
type is (DistribcellFilter)
type_ = 'distribcell'
type is (EnergyFilter)
type_ = 'energy'
type is (EnergyoutFilter)
type_ = 'energyout'
type is (EnergyFunctionFilter)
type_ = 'energyfunction'
type is (MaterialFilter)
type_ = 'material'
type is (MeshFilter)
type_ = 'mesh'
type is (MuFilter)
type_ = 'mu'
type is (PolarFilter)
type_ = 'polar'
type is (SurfaceFilter)
type_ = 'surface'
type is (UniverseFilter)
type_ = 'universe'
end select
! Convert Fortran string to null-terminated C string. We assume the
! caller has allocated a char array buffer
do i = 1, len_trim(type_)
type(i) = type_(i:i)
end do
type(len_trim(type_) + 1) = C_NULL_CHAR
err = 0
else
err = E_ALLOCATE
call set_errmsg("Filter type has not been set yet.")
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in filters array is out of bounds.")
end if
end function openmc_filter_get_type
function openmc_filter_set_type(index, type) result(err) bind(C)
! Set the type of a filter
integer(C_INT32_T), value, intent(in) :: index
character(kind=C_CHAR), intent(in) :: type(*)
integer(C_INT) :: err
character(:), allocatable :: type_
! Convert C string to Fortran string
type_ = to_f_string(type)
err = 0
if (index >= 1 .and. index <= n_filters) then
if (allocated(filters(index) % obj)) then
err = E_ALLOCATE
call set_errmsg("Filter type has already been set.")
else
select case (type_)
case ('azimuthal')
allocate(AzimuthalFilter :: filters(index) % obj)
case ('cell')
allocate(CellFilter :: filters(index) % obj)
case ('cellborn')
allocate(CellbornFilter :: filters(index) % obj)
case ('cellfrom')
allocate(CellfromFilter :: filters(index) % obj)
case ('delayedgroup')
allocate(DelayedGroupFilter :: filters(index) % obj)
case ('distribcell')
allocate(DistribcellFilter :: filters(index) % obj)
case ('energy')
allocate(EnergyFilter :: filters(index) % obj)
case ('energyout')
allocate(EnergyoutFilter :: filters(index) % obj)
case ('energyfunction')
allocate(EnergyFunctionFilter :: filters(index) % obj)
case ('material')
allocate(MaterialFilter :: filters(index) % obj)
case ('mesh')
allocate(MeshFilter :: filters(index) % obj)
case ('mu')
allocate(MuFilter :: filters(index) % obj)
case ('polar')
allocate(PolarFilter :: filters(index) % obj)
case ('surface')
allocate(SurfaceFilter :: filters(index) % obj)
case ('universe')
allocate(UniverseFilter :: filters(index) % obj)
case default
err = E_UNASSIGNED
call set_errmsg("Unknown filter type: " // trim(type_))
end select
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in filters array is out of bounds.")
end if
end function openmc_filter_set_type
end module tally_filter

122
src/tallies/tally_filter_azimuthal.F90 Normal file
View file

@ -0,0 +1,122 @@
module tally_filter_azimuthal
use, intrinsic :: ISO_C_BINDING
use hdf5
use algorithm, only: binary_search
use constants
use error, only: fatal_error
use hdf5_interface
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
!===============================================================================
! AZIMUTHALFILTER bins the incident neutron azimuthal angle (relative to the
! global xy-plane).
!===============================================================================
type, public, extends(TallyFilter) :: AzimuthalFilter
real(8), allocatable :: bins(:)
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_azimuthal
procedure :: to_statepoint => to_statepoint_azimuthal
procedure :: text_label => text_label_azimuthal
end type AzimuthalFilter
contains
subroutine from_xml(this, node)
class(AzimuthalFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: i
integer :: n
integer :: n_angle
real(8) :: d_angle
n = node_word_count(node, "bins")
! Allocate and store bins
this % n_bins = n - 1
allocate(this % bins(n))
call get_node_array(node, "bins", this % bins)
! Allow a user to input a lone number which will mean that you
! subdivide [-pi,pi) evenly with the input being the number of
! bins
if (n == 1) then
n_angle = int(this % bins(1))
if (n_angle > 1) then
this % n_bins = n_angle
d_angle = TWO * PI / n_angle
deallocate(this % bins)
allocate(this % bins(n_angle + 1))
do i = 1, n_angle
this % bins(i) = -PI + (i - 1) * d_angle
end do
this % bins(n_angle + 1) = PI
else
call fatal_error("Number of bins for azimuthal filter must be&
& greater than 1.")
end if
end if
end subroutine from_xml
subroutine get_all_bins_azimuthal(this, p, estimator, match)
class(AzimuthalFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer :: n
integer :: bin
real(8) :: phi
n = this % n_bins
! Make sure the correct direction vector is used.
if (estimator == ESTIMATOR_TRACKLENGTH) then
phi = atan2(p % coord(1) % uvw(2), p % coord(1) % uvw(1))
else
phi = atan2(p % last_uvw(2), p % last_uvw(1))
end if
! Search to find azimuthal angle bin.
bin = binary_search(this % bins, n + 1, phi)
if (bin /= NO_BIN_FOUND) then
call match % bins % push_back(bin)
call match % weights % push_back(ONE)
end if
end subroutine get_all_bins_azimuthal
subroutine to_statepoint_azimuthal(this, filter_group)
class(AzimuthalFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
call write_dataset(filter_group, "type", "azimuthal")
call write_dataset(filter_group, "n_bins", this % n_bins)
call write_dataset(filter_group, "bins", this % bins)
end subroutine to_statepoint_azimuthal
function text_label_azimuthal(this, bin) result(label)
class(AzimuthalFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
real(8) :: E0, E1
E0 = this % bins(bin)
E1 = this % bins(bin + 1)
label = "Azimuthal Angle [" // trim(to_str(E0)) // ", " &
// trim(to_str(E1)) // ")"
end function text_label_azimuthal
end module tally_filter_azimuthal

116
src/tallies/tally_filter_cell.F90 Normal file
View file

@ -0,0 +1,116 @@
module tally_filter_cell
use, intrinsic :: ISO_C_BINDING
use hdf5
use constants, only: ONE, MAX_LINE_LEN
use error, only: fatal_error
use hdf5_interface
use geometry_header
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
!===============================================================================
! CELLFILTER specifies which geometric cells tally events reside in.
!===============================================================================
type, public, extends(TallyFilter) :: CellFilter
integer, allocatable :: cells(:)
type(DictIntInt) :: map
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_cell
procedure :: to_statepoint => to_statepoint_cell
procedure :: text_label => text_label_cell
procedure :: initialize => initialize_cell
end type CellFilter
contains
subroutine from_xml(this, node)
class(CellFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: n
! Determine how many bins were given
n = node_word_count(node, "bins")
! Allocate and store bins
this % n_bins = n
allocate(this % cells(n))
call get_node_array(node, "bins", this % cells)
end subroutine from_xml
subroutine get_all_bins_cell(this, p, estimator, match)
class(CellFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer :: i
! Iterate over coordinate levels to see with cells match
do i = 1, p % n_coord
if (this % map % has_key(p % coord(i) % cell)) then
call match % bins % push_back(this % map % get_key(p % coord(i) % cell))
call match % weights % push_back(ONE)
end if
end do
end subroutine get_all_bins_cell
subroutine to_statepoint_cell(this, filter_group)
class(CellFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
integer :: i
integer, allocatable :: cell_ids(:)
call write_dataset(filter_group, "type", "cell")
call write_dataset(filter_group, "n_bins", this % n_bins)
allocate(cell_ids(size(this % cells)))
do i = 1, size(this % cells)
cell_ids(i) = cells(this % cells(i)) % id
end do
call write_dataset(filter_group, "bins", cell_ids)
end subroutine to_statepoint_cell
subroutine initialize_cell(this)
class(CellFilter), intent(inout) :: this
integer :: i, id
! Convert ids to indices.
do i = 1, this % n_bins
id = this % cells(i)
if (cell_dict % has_key(id)) then
this % cells(i) = cell_dict % get_key(id)
else
call fatal_error("Could not find cell " // trim(to_str(id)) &
&// " specified on tally filter.")
end if
end do
! Generate mapping from cell indices to filter bins.
do i = 1, this % n_bins
call this % map % add_key(this % cells(i), i)
end do
end subroutine initialize_cell
function text_label_cell(this, bin) result(label)
class(CellFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
label = "Cell " // to_str(cells(this % cells(bin)) % id)
end function text_label_cell
end module tally_filter_cell

110
src/tallies/tally_filter_cellborn.F90 Normal file
View file

@ -0,0 +1,110 @@
module tally_filter_cellborn
use, intrinsic :: ISO_C_BINDING
use hdf5
use constants, only: ONE, MAX_LINE_LEN
use error, only: fatal_error
use hdf5_interface
use geometry_header
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
!===============================================================================
! CELLBORNFILTER specifies which cell the particle was born in.
!===============================================================================
type, public, extends(TallyFilter) :: CellbornFilter
integer, allocatable :: cells(:)
type(DictIntInt) :: map
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_cellborn
procedure :: to_statepoint => to_statepoint_cellborn
procedure :: text_label => text_label_cellborn
procedure :: initialize => initialize_cellborn
end type CellbornFilter
contains
subroutine from_xml(this, node)
class(CellbornFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: n
! Determine number of bins
n = node_word_count(node, "bins")
! Allocate and store bins
this % n_bins = n
allocate(this % cells(n))
call get_node_array(node, "bins", this % cells)
end subroutine from_xml
subroutine get_all_bins_cellborn(this, p, estimator, match)
class(CellbornFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
if (this % map % has_key(p % cell_born)) then
call match % bins % push_back(this % map % get_key(p % cell_born))
call match % weights % push_back(ONE)
end if
end subroutine get_all_bins_cellborn
subroutine to_statepoint_cellborn(this, filter_group)
class(CellbornFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
integer :: i
integer, allocatable :: cell_ids(:)
call write_dataset(filter_group, "type", "cellborn")
call write_dataset(filter_group, "n_bins", this % n_bins)
allocate(cell_ids(size(this % cells)))
do i = 1, size(this % cells)
cell_ids(i) = cells(this % cells(i)) % id
end do
call write_dataset(filter_group, "bins", cell_ids)
end subroutine to_statepoint_cellborn
subroutine initialize_cellborn(this)
class(CellbornFilter), intent(inout) :: this
integer :: i, id
! Convert ids to indices.
do i = 1, this % n_bins
id = this % cells(i)
if (cell_dict % has_key(id)) then
this % cells(i) = cell_dict % get_key(id)
else
call fatal_error("Could not find cell " // trim(to_str(id)) &
&// " specified on tally filter.")
end if
end do
! Generate mapping from cell indices to filter bins.
do i = 1, this % n_bins
call this % map % add_key(this % cells(i), i)
end do
end subroutine initialize_cellborn
function text_label_cellborn(this, bin) result(label)
class(CellbornFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
label = "Birth Cell " // to_str(cells(this % cells(bin)) % id)
end function text_label_cellborn
end module tally_filter_cellborn

79
src/tallies/tally_filter_cellfrom.F90 Normal file
View file

@ -0,0 +1,79 @@
module tally_filter_cellfrom
use, intrinsic :: ISO_C_BINDING
use hdf5
use constants, only: ONE, MAX_LINE_LEN
use error, only: fatal_error
use hdf5_interface
use geometry_header
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use tally_filter_cell
use xml_interface
implicit none
private
!===============================================================================
! CELLFROMFILTER specifies which geometric cells particles exit when crossing a
! surface.
!===============================================================================
type, public, extends(CellFilter) :: CellFromFilter
contains
! Inherit from_xml from CellFilter
procedure :: get_all_bins => get_all_bins_cell_from
procedure :: to_statepoint => to_statepoint_cell_from
procedure :: text_label => text_label_cell_from
end type CellFromFilter
contains
subroutine get_all_bins_cell_from(this, p, estimator, match)
class(CellFromFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer :: i
! Starting one coordinate level deeper, find the next bin.
do i = 1, p % last_n_coord
if (this % map % has_key(p % last_cell(i))) then
call match % bins % push_back(this % map % get_key(p % last_cell(i)))
call match % weights % push_back(ONE)
exit
end if
end do
end subroutine get_all_bins_cell_from
subroutine to_statepoint_cell_from(this, filter_group)
class(CellFromFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
integer :: i
integer, allocatable :: cell_ids(:)
call write_dataset(filter_group, "type", "cellfrom")
call write_dataset(filter_group, "n_bins", this % n_bins)
allocate(cell_ids(size(this % cells)))
do i = 1, size(this % cells)
cell_ids(i) = cells(this % cells(i)) % id
end do
call write_dataset(filter_group, "bins", cell_ids)
end subroutine to_statepoint_cell_from
function text_label_cell_from(this, bin) result(label)
class(CellFromFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
label = "Cell from " // to_str(cells(this % cells(bin)) % id)
end function text_label_cell_from
end module tally_filter_cellfrom

88
src/tallies/tally_filter_delayedgroup.F90 Normal file
View file

@ -0,0 +1,88 @@
module tally_filter_delayedgroup
use, intrinsic :: ISO_C_BINDING
use hdf5
use constants, only: ONE, MAX_LINE_LEN, MAX_DELAYED_GROUPS
use error, only: fatal_error
use hdf5_interface
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
!===============================================================================
! DELAYEDGROUPFILTER bins outgoing fission neutrons in their delayed groups.
! The get_all_bins functionality is not actually used. The bins are manually
! iterated over in the scoring subroutines.
!===============================================================================
type, public, extends(TallyFilter) :: DelayedGroupFilter
integer, allocatable :: groups(:)
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_dg
procedure :: to_statepoint => to_statepoint_dg
procedure :: text_label => text_label_dg
end type DelayedGroupFilter
contains
subroutine from_xml(this, node)
class(DelayedGroupFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: i
integer :: n
n = node_word_count(node, "bins")
! Allocate and store bins
this % n_bins = n
allocate(this % groups(n))
call get_node_array(node, "bins", this % groups)
! Check that bins are all are between 1 and MAX_DELAYED_GROUPS
do i = 1, n
if (this % groups(i) < 1 .or. &
this % groups(i) > MAX_DELAYED_GROUPS) then
call fatal_error("Encountered delayedgroup bin with index " &
// trim(to_str(this % groups(i))) // " that is outside &
&the range of 1 to MAX_DELAYED_GROUPS ( " &
// trim(to_str(MAX_DELAYED_GROUPS)) // ")")
end if
end do
end subroutine from_xml
subroutine get_all_bins_dg(this, p, estimator, match)
class(DelayedGroupFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
call match % bins % push_back(1)
call match % weights % push_back(ONE)
end subroutine get_all_bins_dg
subroutine to_statepoint_dg(this, filter_group)
class(DelayedGroupFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
call write_dataset(filter_group, "type", "delayedgroup")
call write_dataset(filter_group, "n_bins", this % n_bins)
call write_dataset(filter_group, "bins", this % groups)
end subroutine to_statepoint_dg
function text_label_dg(this, bin) result(label)
class(DelayedGroupFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
label = "Delayed Group " // to_str(this % groups(bin))
end function text_label_dg
end module tally_filter_delayedgroup

408
src/tallies/tally_filter_distribcell.F90 Normal file
View file

@ -0,0 +1,408 @@
module tally_filter_distribcell
use, intrinsic :: ISO_C_BINDING
use hdf5, only: HID_T
use constants
use error
use geometry_header
use hdf5_interface
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
public :: find_offset
!===============================================================================
! DISTRIBCELLFILTER specifies which distributed geometric cells tally events
! reside in.
!===============================================================================
type, public, extends(TallyFilter) :: DistribcellFilter
integer :: cell
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_distribcell
procedure :: to_statepoint => to_statepoint_distribcell
procedure :: text_label => text_label_distribcell
procedure :: initialize => initialize_distribcell
end type DistribcellFilter
contains
subroutine from_xml(this, node)
class(DistribcellFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: n
n = node_word_count(node, "bins")
if (n /= 1) call fatal_error("Only one cell can be &
&specified per distribcell filter.")
! Store bins
call get_node_value(node, "bins", this % cell)
end subroutine from_xml
subroutine get_all_bins_distribcell(this, p, estimator, match)
class(DistribcellFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer :: distribcell_index, offset, i
distribcell_index = cells(this % cell) % distribcell_index
offset = 0
do i = 1, p % n_coord
if (cells(p % coord(i) % cell) % type == FILL_UNIVERSE) then
offset = offset + cells(p % coord(i) % cell) % &
offset(distribcell_index)
elseif (cells(p % coord(i) % cell) % type == FILL_LATTICE) then
if (lattices(p % coord(i + 1) % lattice) % obj &
% are_valid_indices([&
p % coord(i + 1) % lattice_x, &
p % coord(i + 1) % lattice_y, &
p % coord(i + 1) % lattice_z])) then
offset = offset + lattices(p % coord(i + 1) % lattice) % obj % &
offset(distribcell_index, &
p % coord(i + 1) % lattice_x, &
p % coord(i + 1) % lattice_y, &
p % coord(i + 1) % lattice_z)
end if
end if
if (this % cell == p % coord(i) % cell) then
call match % bins % push_back(offset + 1)
call match % weights % push_back(ONE)
return
end if
end do
end subroutine get_all_bins_distribcell
subroutine to_statepoint_distribcell(this, filter_group)
class(DistribcellFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
call write_dataset(filter_group, "type", "distribcell")
call write_dataset(filter_group, "n_bins", this % n_bins)
call write_dataset(filter_group, "bins", cells(this % cell) % id)
end subroutine to_statepoint_distribcell
subroutine initialize_distribcell(this)
class(DistribcellFilter), intent(inout) :: this
integer :: id
! Convert id to index.
id = this % cell
if (cell_dict % has_key(id)) then
this % cell = cell_dict % get_key(id)
this % n_bins = cells(this % cell) % instances
else
call fatal_error("Could not find cell " // trim(to_str(id)) &
&// " specified on tally filter.")
end if
end subroutine initialize_distribcell
function text_label_distribcell(this, bin) result(label)
class(DistribcellFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
integer :: offset
type(Universe), pointer :: univ
univ => universes(root_universe)
offset = 0
label = ''
call find_offset(this % cell, univ, bin-1, offset, label)
label = "Distributed Cell " // label
end function text_label_distribcell
!===============================================================================
! FIND_OFFSET (for distribcell) uses a given map number, a target cell ID, and
! a target offset to build a string which is the path from the base universe to
! the target cell with the given offset
!===============================================================================
recursive subroutine find_offset(i_cell, univ, target_offset, offset, path)
integer, intent(in) :: i_cell ! The target cell index
type(Universe), intent(in) :: univ ! Universe to begin search
integer, intent(in) :: target_offset ! Target offset
integer, intent(inout) :: offset ! Current offset
character(*), intent(inout) :: path ! Path to offset
integer :: map ! Index in maps vector
integer :: i, j ! Index over cells
integer :: k, l, m ! Indices in lattice
integer :: old_k, old_l, old_m ! Previous indices in lattice
integer :: n_x, n_y, n_z ! Lattice cell array dimensions
integer :: n ! Number of cells to search
integer :: cell_index ! Index in cells array
integer :: lat_offset ! Offset from lattice
integer :: temp_offset ! Looped sum of offsets
integer :: i_univ ! index in universes array
logical :: this_cell = .false. ! Advance in this cell?
logical :: later_cell = .false. ! Fill cells after this one?
type(Cell), pointer :: c ! Pointer to current cell
type(Universe), pointer :: next_univ ! Next universe to loop through
class(Lattice), pointer :: lat ! Pointer to current lattice
! Get the distribcell index for this cell
map = cells(i_cell) % distribcell_index
n = size(univ % cells)
! Write to the geometry stack
i_univ = universe_dict % get_key(univ % id)
if (i_univ == root_universe) then
path = trim(path) // "u" // to_str(univ%id)
else
path = trim(path) // "->u" // to_str(univ%id)
end if
! Look through all cells in this universe
do i = 1, n
! If the cell matches the goal and the offset matches final, write to the
! geometry stack
if (univ % cells(i) == i_cell .and. offset == target_offset) then
c => cells(univ % cells(i))
path = trim(path) // "->c" // to_str(c % id)
return
end if
end do
! Find the fill cell or lattice cell that we need to enter
do i = 1, n
later_cell = .false.
c => cells(univ % cells(i))
this_cell = .false.
! If we got here, we still think the target is in this universe
! or further down, but it's not this exact cell.
! Compare offset to next cell to see if we should enter this cell
if (i /= n) then
do j = i+1, n
c => cells(univ % cells(j))
! Skip normal cells which do not have offsets
if (c % type == FILL_MATERIAL) cycle
! Break loop once we've found the next cell with an offset
exit
end do
! Ensure we didn't just end the loop by iteration
if (c % type /= FILL_MATERIAL) then
! There are more cells in this universe that it could be in
later_cell = .true.
! Two cases, lattice or fill cell
if (c % type == FILL_UNIVERSE) then
temp_offset = c % offset(map)
! Get the offset of the first lattice location
else
lat => lattices(c % fill) % obj
temp_offset = lat % offset(map, 1, 1, 1)
end if
! If the final offset is in the range of offset - temp_offset+offset
! then the goal is in this cell
if (target_offset < temp_offset + offset) then
this_cell = .true.
end if
end if
end if
if (n == 1 .and. c % type /= FILL_MATERIAL) then
this_cell = .true.
end if
if (.not. later_cell) then
this_cell = .true.
end if
! Get pointer to THIS cell because target must be in this cell
if (this_cell) then
cell_index = univ % cells(i)
c => cells(cell_index)
path = trim(path) // "->c" // to_str(c%id)
! ====================================================================
! CELL CONTAINS LOWER UNIVERSE, RECURSIVELY FIND CELL
if (c % type == FILL_UNIVERSE) then
! Enter this cell to update the current offset
offset = c % offset(map) + offset
next_univ => universes(c % fill)
call find_offset(i_cell, next_univ, target_offset, offset, path)
return
! ====================================================================
! CELL CONTAINS LATTICE, RECURSIVELY FIND CELL
elseif (c % type == FILL_LATTICE) then
! Set current lattice
lat => lattices(c % fill) % obj
select type (lat)
! ==================================================================
! RECTANGULAR LATTICES
type is (RectLattice)
! Write to the geometry stack
path = trim(path) // "->l" // to_str(lat%id)
n_x = lat % n_cells(1)
n_y = lat % n_cells(2)
n_z = lat % n_cells(3)
old_m = 1
old_l = 1
old_k = 1
! Loop over lattice coordinates
do k = 1, n_x
do l = 1, n_y
do m = 1, n_z
if (target_offset >= lat % offset(map, k, l, m) + offset) then
if (k == n_x .and. l == n_y .and. m == n_z) then
! This is last lattice cell, so target must be here
lat_offset = lat % offset(map, k, l, m)
offset = offset + lat_offset
next_univ => universes(lat % universes(k, l, m))
if (lat % is_3d) then
path = trim(path) // "(" // trim(to_str(k-1)) // &
"," // trim(to_str(l-1)) // "," // &
trim(to_str(m-1)) // ")"
else
path = trim(path) // "(" // trim(to_str(k-1)) // &
"," // trim(to_str(l-1)) // ")"
end if
call find_offset(i_cell, next_univ, target_offset, offset, path)
return
else
old_m = m
old_l = l
old_k = k
cycle
end if
else
! Target is at this lattice position
lat_offset = lat % offset(map, old_k, old_l, old_m)
offset = offset + lat_offset
next_univ => universes(lat % universes(old_k, old_l, old_m))
if (lat % is_3d) then
path = trim(path) // "(" // trim(to_str(old_k-1)) // &
"," // trim(to_str(old_l-1)) // "," // &
trim(to_str(old_m-1)) // ")"
else
path = trim(path) // "(" // trim(to_str(old_k-1)) // &
"," // trim(to_str(old_l-1)) // ")"
end if
call find_offset(i_cell, next_univ, target_offset, offset, path)
return
end if
end do
end do
end do
! ==================================================================
! HEXAGONAL LATTICES
type is (HexLattice)
! Write to the geometry stack
path = trim(path) // "->l" // to_str(lat%id)
n_z = lat % n_axial
n_y = 2 * lat % n_rings - 1
n_x = 2 * lat % n_rings - 1
old_m = 1
old_l = 1
old_k = 1
! Loop over lattice coordinates
do m = 1, n_z
do l = 1, n_y
do k = 1, n_x
! This array position is never used
if (k + l < lat % n_rings + 1) then
cycle
! This array position is never used
else if (k + l > 3*lat % n_rings - 1) then
cycle
end if
if (target_offset >= lat % offset(map, k, l, m) + offset) then
if (k == lat % n_rings .and. l == n_y .and. m == n_z) then
! This is last lattice cell, so target must be here
lat_offset = lat % offset(map, k, l, m)
offset = offset + lat_offset
next_univ => universes(lat % universes(k, l, m))
if (lat % is_3d) then
path = trim(path) // "(" // &
trim(to_str(k - lat % n_rings)) // "," // &
trim(to_str(l - lat % n_rings)) // "," // &
trim(to_str(m - 1)) // ")"
else
path = trim(path) // "(" // &
trim(to_str(k - lat % n_rings)) // "," // &
trim(to_str(l - lat % n_rings)) // ")"
end if
call find_offset(i_cell, next_univ, target_offset, offset, path)
return
else
old_m = m
old_l = l
old_k = k
cycle
end if
else
! Target is at this lattice position
lat_offset = lat % offset(map, old_k, old_l, old_m)
offset = offset + lat_offset
next_univ => universes(lat % universes(old_k, old_l, old_m))
if (lat % is_3d) then
path = trim(path) // "(" // &
trim(to_str(old_k - lat % n_rings)) // "," // &
trim(to_str(old_l - lat % n_rings)) // "," // &
trim(to_str(old_m - 1)) // ")"
else
path = trim(path) // "(" // &
trim(to_str(old_k - lat % n_rings)) // "," // &
trim(to_str(old_l - lat % n_rings)) // ")"
end if
call find_offset(i_cell, next_univ, target_offset, offset, path)
return
end if
end do
end do
end do
end select
end if
end if
end do
end subroutine find_offset
end module tally_filter_distribcell

259
src/tallies/tally_filter_energy.F90 Normal file
View file

@ -0,0 +1,259 @@
module tally_filter_energy
use, intrinsic :: ISO_C_BINDING
use hdf5, only: HID_T
use algorithm, only: binary_search
use constants
use error
use hdf5_interface
use mgxs_header, only: num_energy_groups, energy_bins
use particle_header, only: Particle
use settings, only: run_CE
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
public :: openmc_energy_filter_get_bins
public :: openmc_energy_filter_set_bins
!===============================================================================
! ENERGYFILTER bins the incident neutron energy.
!===============================================================================
type, public, extends(TallyFilter) :: EnergyFilter
real(8), allocatable :: bins(:)
! True if transport group number can be used directly to get bin number
logical :: matches_transport_groups = .false.
contains
procedure :: from_xml => from_xml_energy
procedure :: get_all_bins => get_all_bins_energy
procedure :: to_statepoint => to_statepoint_energy
procedure :: text_label => text_label_energy
end type EnergyFilter
!===============================================================================
! ENERGYOUTFILTER bins the outgoing neutron energy. Only scattering events use
! the get_all_bins functionality. Nu-fission tallies manually iterate over the
! filter bins.
!===============================================================================
type, public, extends(EnergyFilter) :: EnergyoutFilter
contains
! Inherit from_xml from EnergyFilter
procedure :: get_all_bins => get_all_bins_energyout
procedure :: to_statepoint => to_statepoint_energyout
procedure :: text_label => text_label_energyout
end type EnergyoutFilter
contains
!===============================================================================
! EnergyFilter methods
!===============================================================================
subroutine from_xml_energy(this, node)
class(EnergyFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: n
n = node_word_count(node, "bins")
! Allocate and store bins
this % n_bins = n - 1
allocate(this % bins(n))
call get_node_array(node, "bins", this % bins)
! We can save tallying time if we know that the tally bins match
! the energy group structure. In that case, the matching bin
! index is simply the group (after flipping for the different
! ordering of the library and tallying systems).
if (.not. run_CE) then
if (n == num_energy_groups + 1) then
if (all(this % bins == energy_bins(num_energy_groups + 1:1:-1))) &
then
this % matches_transport_groups = .true.
end if
end if
end if
end subroutine from_xml_energy
subroutine get_all_bins_energy(this, p, estimator, match)
class(EnergyFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer :: n
integer :: bin
real(8) :: E
n = this % n_bins
if (p % g /= NONE .and. this % matches_transport_groups) then
if (estimator == ESTIMATOR_TRACKLENGTH) then
call match % bins % push_back(num_energy_groups - p % g + 1)
call match % weights % push_back(ONE)
else
call match % bins % push_back(num_energy_groups - p % last_g + 1)
call match % weights % push_back(ONE)
end if
else
! Pre-collision energy of particle
E = p % last_E
! Search to find incoming energy bin.
bin = binary_search(this % bins, n + 1, E)
if (bin /= NO_BIN_FOUND) then
call match % bins % push_back(bin)
call match % weights % push_back(ONE)
end if
end if
end subroutine get_all_bins_energy
subroutine to_statepoint_energy(this, filter_group)
class(EnergyFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
call write_dataset(filter_group, "type", "energy")
call write_dataset(filter_group, "n_bins", this % n_bins)
call write_dataset(filter_group, "bins", this % bins)
end subroutine to_statepoint_energy
function text_label_energy(this, bin) result(label)
class(EnergyFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
real(8) :: E0, E1
E0 = this % bins(bin)
E1 = this % bins(bin + 1)
label = "Incoming Energy [" // trim(to_str(E0)) // ", " &
// trim(to_str(E1)) // ")"
end function text_label_energy
!===============================================================================
! EnergyoutFilter methods
!===============================================================================
subroutine get_all_bins_energyout(this, p, estimator, match)
class(EnergyoutFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer :: n
integer :: bin
n = this % n_bins
if (p % g /= NONE .and. this % matches_transport_groups) then
! Tallies are ordered in increasing groups, group indices
! however are the opposite, so switch
call match % bins % push_back(num_energy_groups - p % g + 1)
call match % weights % push_back(ONE)
else
! Search to find incoming energy bin.
bin = binary_search(this % bins, n + 1, p % E)
if (bin /= NO_BIN_FOUND) then
call match % bins % push_back(bin)
call match % weights % push_back(ONE)
end if
end if
end subroutine get_all_bins_energyout
subroutine to_statepoint_energyout(this, filter_group)
class(EnergyoutFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
call write_dataset(filter_group, "type", "energyout")
call write_dataset(filter_group, "n_bins", this % n_bins)
call write_dataset(filter_group, "bins", this % bins)
end subroutine to_statepoint_energyout
function text_label_energyout(this, bin) result(label)
class(EnergyoutFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
real(8) :: E0, E1
E0 = this % bins(bin)
E1 = this % bins(bin + 1)
label = "Outgoing Energy [" // trim(to_str(E0)) // ", " &
// trim(to_str(E1)) // ")"
end function text_label_energyout
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_energy_filter_get_bins(index, energies, n) result(err) bind(C)
! Return the bounding energies for an energy filter
integer(C_INT32_T), value :: index
type(C_PTR), intent(out) :: energies
integer(C_INT32_T), intent(out) :: n
integer(C_INT) :: err
if (index >= 1 .and. index <= n_filters) then
if (allocated(filters(index) % obj)) then
select type (f => filters(index) % obj)
type is (EnergyFilter)
energies = C_LOC(f % bins)
n = size(f % bins)
err = 0
class default
err = E_INVALID_TYPE
call set_errmsg("Tried to get energy bins on a non-energy filter.")
end select
else
err = E_ALLOCATE
call set_errmsg("Filter type has not been set yet.")
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in filters array out of bounds.")
end if
end function openmc_energy_filter_get_bins
function openmc_energy_filter_set_bins(index, n, energies) result(err) bind(C)
! Set the bounding energies for an energy filter
integer(C_INT32_T), value, intent(in) :: index
integer(C_INT32_T), value, intent(in) :: n
real(C_DOUBLE), intent(in) :: energies(n)
integer(C_INT) :: err
err = 0
if (index >= 1 .and. index <= n_filters) then
if (allocated(filters(index) % obj)) then
select type (f => filters(index) % obj)
type is (EnergyFilter)
f % n_bins = n - 1
if (allocated(f % bins)) deallocate(f % bins)
allocate(f % bins(n))
f % bins(:) = energies
class default
err = E_INVALID_TYPE
call set_errmsg("Tried to get energy bins on a non-energy filter.")
end select
else
err = E_ALLOCATE
call set_errmsg("Filter type has not been set yet.")
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in filters array out of bounds.")
end if
end function openmc_energy_filter_set_bins
end module tally_filter_energy

126
src/tallies/tally_filter_energyfunc.F90 Normal file
View file

@ -0,0 +1,126 @@
module tally_filter_energyfunc
use, intrinsic :: ISO_C_BINDING
use hdf5
use algorithm, only: binary_search
use constants
use error, only: fatal_error
use hdf5_interface
use particle_header, only: Particle
use settings, only: run_CE
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
!===============================================================================
! EnergyFunctionFilter multiplies tally scores by an arbitrary function of
! incident energy described by a piecewise linear-linear interpolation.
!===============================================================================
type, public, extends(TallyFilter) :: EnergyFunctionFilter
real(8), allocatable :: energy(:)
real(8), allocatable :: y(:)
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_energyfunction
procedure :: to_statepoint => to_statepoint_energyfunction
procedure :: text_label => text_label_energyfunction
end type EnergyFunctionFilter
contains
subroutine from_xml(this, node)
class(EnergyFunctionFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: n
this % n_bins = 1
! Make sure this is continuous-energy mode.
if (.not. run_CE) then
call fatal_error("EnergyFunction filters are only supported for &
&continuous-energy transport calculations")
end if
! Allocate and store energy grid.
if (.not. check_for_node(node, "energy")) then
call fatal_error("Energy grid not specified for EnergyFunction &
&filter.")
end if
n = node_word_count(node, "energy")
allocate(this % energy(n))
call get_node_array(node, "energy", this % energy)
! Allocate and store interpolant values.
if (.not. check_for_node(node, "y")) then
call fatal_error("y values not specified for EnergyFunction &
&filter.")
end if
n = node_word_count(node, "y")
allocate(this % y(n))
call get_node_array(node, "y", this % y)
end subroutine from_xml
subroutine get_all_bins_energyfunction(this, p, estimator, match)
class(EnergyFunctionFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer :: n, indx
real(8) :: E, f, weight
select type(this)
type is (EnergyFunctionFilter)
n = size(this % energy)
! Get pre-collision energy of particle
E = p % last_E
! Search to find incoming energy bin.
indx = binary_search(this % energy, n, E)
! Compute an interpolation factor between nearest bins.
f = (E - this % energy(indx)) &
/ (this % energy(indx+1) - this % energy(indx))
! Interpolate on the lin-lin grid.
call match % bins % push_back(1)
weight = (ONE - f) * this % y(indx) + f * this % y(indx+1)
call match % weights % push_back(weight)
end select
end subroutine get_all_bins_energyfunction
subroutine to_statepoint_energyfunction(this, filter_group)
class(EnergyFunctionFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
select type(this)
type is (EnergyFunctionFilter)
call write_dataset(filter_group, "type", "energyfunction")
call write_dataset(filter_group, "energy", this % energy)
call write_dataset(filter_group, "y", this % y)
end select
end subroutine to_statepoint_energyfunction
function text_label_energyfunction(this, bin) result(label)
class(EnergyFunctionFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
select type(this)
type is (EnergyFunctionFilter)
write(label, FMT="(A, ES8.1, A, ES8.1, A, ES8.1, A, ES8.1, A)") &
"Energy Function f([", this % energy(1), ", ..., ", &
this % energy(size(this % energy)), "]) = [", this % y(1), &
", ..., ", this % y(size(this % y)), "]"
end select
end function text_label_energyfunction
end module tally_filter_energyfunc

241
src/tallies/tally_filter_header.F90 Normal file
View file

@ -0,0 +1,241 @@
module tally_filter_header
use, intrinsic :: ISO_C_BINDING
use constants, only: MAX_LINE_LEN
use dict_header, only: DictIntInt
use error
use particle_header, only: Particle
use stl_vector, only: VectorInt, VectorReal
use string, only: to_str
use xml_interface, only: XMLNode
use hdf5
implicit none
private
public :: free_memory_tally_filter
public :: openmc_extend_filters
public :: openmc_filter_get_id
public :: openmc_filter_set_id
public :: openmc_get_filter_index
!===============================================================================
! TALLYFILTERMATCH stores every valid bin and weight for a filter
!===============================================================================
type, public :: TallyFilterMatch
! Index of the bin and weight being used in the current filter combination
integer :: i_bin
type(VectorInt) :: bins
type(VectorReal) :: weights
! Indicates whether all valid bins for this filter have been found
logical :: bins_present = .false.
end type TallyFilterMatch
!===============================================================================
! TALLYFILTER describes a filter that limits what events score to a tally. For
! example, a cell filter indicates that only particles in a specified cell
! should score to the tally.
!===============================================================================
type, public, abstract :: TallyFilter
integer :: id
integer :: n_bins = 0
contains
procedure(from_xml_), deferred :: from_xml
procedure(get_all_bins_), deferred :: get_all_bins
procedure(to_statepoint_), deferred :: to_statepoint
procedure(text_label_), deferred :: text_label
procedure :: initialize => filter_initialize
end type TallyFilter
abstract interface
subroutine from_xml_(this, node)
import TallyFilter, XMLNode
class(TallyFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
end subroutine from_xml_
!===============================================================================
! GET_NEXT_BIN gives the index for the next valid filter bin and a weight that
! will be applied to the flux.
!
! In principle, a filter can have multiple valid bins. If current_bin =
! NO_BIN_FOUND, then this method should give the first valid bin. Providing the
! first valid bin should then give the second valid bin, and so on. When there
! are no valid bins left, the next_bin should be NO_VALID_BIN.
subroutine get_all_bins_(this, p, estimator, match)
import TallyFilter
import Particle
import TallyFilterMatch
class(TallyFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
end subroutine get_all_bins_
!===============================================================================
! TO_STATEPOINT writes all the information needed to reconstruct the filter to
! the given filter_group.
subroutine to_statepoint_(this, filter_group)
import TallyFilter
import HID_T
class(TallyFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
end subroutine to_statepoint_
!===============================================================================
! TEXT_LABEL returns a string describing the given filter bin. For example, an
! energy filter might return the string "Incoming Energy [0.625E-6, 20.0)".
! This is used to write the tallies.out file.
function text_label_(this, bin) result(label)
import TallyFilter
import MAX_LINE_LEN
class(TallyFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
end function text_label_
end interface
!===============================================================================
! TALLYFILTERCONTAINER contains an allocatable TallyFilter object for arrays of
! TallyFilters
!===============================================================================
type, public :: TallyFilterContainer
class(TallyFilter), allocatable :: obj
end type TallyFilterContainer
integer(C_INT32_T), public, bind(C) :: n_filters = 0 ! # of filters
type(TallyFilterContainer), public, allocatable, target :: filters(:)
type(TallyFilterMatch), public, allocatable :: filter_matches(:)
!$omp threadprivate(filter_matches)
! Dictionary that maps user IDs to indices in 'filters'
type(DictIntInt), public :: filter_dict
contains
!===============================================================================
! INITIALIZE sets up any internal data, as necessary. If this procedure is not
! overriden by the derived class, then it will do nothing by default.
subroutine filter_initialize(this)
class(TallyFilter), intent(inout) :: this
end subroutine filter_initialize
!===============================================================================
! FREE_MEMORY_TALLY_FILTER deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_tally_filter()
n_filters = 0
if (allocated(filters)) deallocate(filters)
call filter_dict % clear()
end subroutine free_memory_tally_filter
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_extend_filters(n, index_start, index_end) result(err) bind(C)
! Creates or extends the filters array
integer(C_INT32_T), value, intent(in) :: n
integer(C_INT32_T), optional, intent(out) :: index_start
integer(C_INT32_T), optional, intent(out) :: index_end
integer(C_INT) :: err
integer :: i ! loop counter
type(TallyFilterContainer), allocatable :: temp(:) ! temporary filters
if (n_filters == 0) then
! Allocate filters array
allocate(filters(n))
else
! Move filters to temporary array
allocate(temp(n_filters + n))
do i = 1, n_filters
call move_alloc(filters(i) % obj, temp(i) % obj)
end do
! Move filters back from temporary array to filters array
call move_alloc(temp, filters)
end if
! Return indices in filters array
if (present(index_start)) index_start = n_filters + 1
if (present(index_end)) index_end = n_filters + n
n_filters = n_filters + n
err = 0
end function openmc_extend_filters
function openmc_filter_get_id(index, id) result(err) bind(C)
! Return the ID of a filter
integer(C_INT32_T), value :: index
integer(C_INT32_T), intent(out) :: id
integer(C_INT) :: err
if (index >= 1 .and. index <= n_filters) then
id = filters(index) % obj % id
err = 0
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in filters array out of bounds.")
end if
end function openmc_filter_get_id
function openmc_filter_set_id(index, id) result(err) bind(C)
! Set the ID of a filter
integer(C_INT32_T), value, intent(in) :: index
integer(C_INT32_T), value, intent(in) :: id
integer(C_INT) :: err
if (index >= 1 .and. index <= n_filters) then
if (allocated(filters(index) % obj)) then
filters(index) % obj % id = id
call filter_dict % add_key(id, index)
err = 0
else
err = E_ALLOCATE
call set_errmsg("Filter type has not been set yet.")
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in filters array out of bounds.")
end if
end function openmc_filter_set_id
function openmc_get_filter_index(id, index) result(err) bind(C)
! Returns the index in the filters array of a filter with a given ID
integer(C_INT32_T), value :: id
integer(C_INT32_T), intent(out) :: index
integer(C_INT) :: err
if (allocated(filters)) then
if (filter_dict % has_key(id)) then
index = filter_dict % get_key(id)
err = 0
else
err = E_INVALID_ID
call set_errmsg("No filter exists with ID=" // trim(to_str(id)) // ".")
end if
else
err = E_ALLOCATE
call set_errmsg("Memory has not been allocated for filters.")
end if
end function openmc_get_filter_index
end module tally_filter_header

187
src/tallies/tally_filter_material.F90 Normal file
View file

@ -0,0 +1,187 @@
module tally_filter_material
use, intrinsic :: ISO_C_BINDING
use hdf5, only: HID_T
use constants
use dict_header, only: DictIntInt
use error
use hdf5_interface
use material_header, only: materials, material_dict
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
public :: openmc_material_filter_get_bins
public :: openmc_material_filter_set_bins
!===============================================================================
! MATERIAL specifies which material tally events reside in.
!===============================================================================
type, public, extends(TallyFilter) :: MaterialFilter
integer, allocatable :: materials(:)
type(DictIntInt) :: map
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_material
procedure :: to_statepoint => to_statepoint_material
procedure :: text_label => text_label_material
procedure :: initialize => initialize_material
end type MaterialFilter
contains
subroutine from_xml(this, node)
class(MaterialFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: n
n = node_word_count(node, "bins")
! Allocate and store bins
this % n_bins = n
allocate(this % materials(n))
call get_node_array(node, "bins", this % materials)
end subroutine from_xml
subroutine get_all_bins_material(this, p, estimator, match)
class(MaterialFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
if (this % map % has_key(p % material)) then
call match % bins % push_back(this % map % get_key(p % material))
call match % weights % push_back(ONE)
end if
end subroutine get_all_bins_material
subroutine to_statepoint_material(this, filter_group)
class(MaterialFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
integer :: i
integer, allocatable :: material_ids(:)
call write_dataset(filter_group, "type", "material")
call write_dataset(filter_group, "n_bins", this % n_bins)
allocate(material_ids(size(this % materials)))
do i = 1, size(this % materials)
material_ids(i) = materials(this % materials(i)) % id
end do
call write_dataset(filter_group, "bins", material_ids)
end subroutine to_statepoint_material
subroutine initialize_material(this)
class(MaterialFilter), intent(inout) :: this
integer :: i, id
! Convert ids to indices.
do i = 1, this % n_bins
id = this % materials(i)
if (material_dict % has_key(id)) then
this % materials(i) = material_dict % get_key(id)
else
call fatal_error("Could not find material " // trim(to_str(id)) &
&// " specified on a tally filter.")
end if
end do
! Generate mapping from material indices to filter bins.
do i = 1, this % n_bins
call this % map % add_key(this % materials(i), i)
end do
end subroutine initialize_material
function text_label_material(this, bin) result(label)
class(MaterialFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
label = "Material " // to_str(materials(this % materials(bin)) % id)
end function text_label_material
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_material_filter_get_bins(index, bins, n) result(err) bind(C)
! Return the bins for a material filter
integer(C_INT32_T), value :: index
type(C_PTR), intent(out) :: bins
integer(C_INT32_T), intent(out) :: n
integer(C_INT) :: err
if (index >= 1 .and. index <= n_filters) then
if (allocated(filters(index) % obj)) then
select type (f => filters(index) % obj)
type is (MaterialFilter)
bins = C_LOC(f % materials)
n = size(f % materials)
err = 0
class default
err = E_INVALID_TYPE
call set_errmsg("Tried to get material filter bins on a &
&non-material filter.")
end select
else
err = E_ALLOCATE
call set_errmsg("Filter type has not been set yet.")
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in filters array out of bounds.")
end if
end function openmc_material_filter_get_bins
function openmc_material_filter_set_bins(index, n, bins) result(err) bind(C)
! Set the materials for the filter
integer(C_INT32_T), value, intent(in) :: index
integer(C_INT32_T), value, intent(in) :: n
integer(C_INT32_T), intent(in) :: bins(n)
integer(C_INT) :: err
integer :: i
err = 0
if (index >= 1 .and. index <= n_filters) then
if (allocated(filters(index) % obj)) then
select type (f => filters(index) % obj)
type is (MaterialFilter)
f % n_bins = n
if (allocated(f % materials)) deallocate(f % materials)
allocate(f % materials(n))
f % materials(:) = bins
! Generate mapping from material indices to filter bins.
call f % map % clear()
do i = 1, n
call f % map % add_key(f % materials(i), i)
end do
class default
err = E_INVALID_TYPE
call set_errmsg("Tried to set material filter bins on a &
&non-material filter.")
end select
else
err = E_ALLOCATE
call set_errmsg("Filter type has not been set yet.")
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in filters array out of bounds.")
end if
end function openmc_material_filter_set_bins
end module tally_filter_material

315
src/tallies/tally_filter_mesh.F90 Normal file
View file

@ -0,0 +1,315 @@
module tally_filter_mesh
use, intrinsic :: ISO_C_BINDING
use hdf5
use constants
use error
use mesh_header, only: RegularMesh, meshes, n_meshes, mesh_dict
use hdf5_interface
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
public :: openmc_mesh_filter_set_mesh
!===============================================================================
! MESHFILTER indexes the location of particle events to a regular mesh. For
! tracklength tallies, it will produce multiple valid bins and the bin weight
! will correspond to the fraction of the track length that lies in that bin.
!===============================================================================
type, public, extends(TallyFilter) :: MeshFilter
integer :: mesh
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_mesh
procedure :: to_statepoint => to_statepoint_mesh
procedure :: text_label => text_label_mesh
end type MeshFilter
contains
subroutine from_xml(this, node)
class(MeshFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: i_mesh
integer :: id
integer :: n
n = node_word_count(node, "bins")
if (n /= 1) call fatal_error("Only one mesh can be &
&specified per mesh filter.")
! Determine id of mesh
call get_node_value(node, "bins", id)
! Get pointer to mesh
if (mesh_dict % has_key(id)) then
i_mesh = mesh_dict % get_key(id)
else
call fatal_error("Could not find mesh " // trim(to_str(id)) &
// " specified on filter.")
end if
! Determine number of bins
this % n_bins = product(meshes(i_mesh) % dimension)
! Store the index of the mesh
this % mesh = i_mesh
end subroutine from_xml
subroutine get_all_bins_mesh(this, p, estimator, match)
class(MeshFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer, parameter :: MAX_SEARCH_ITER = 100 ! Maximum number of times we can
! can loop while trying to find
! the first intersection.
integer :: j ! loop index for direction
integer :: n
integer :: ijk0(3) ! indices of starting coordinates
integer :: ijk1(3) ! indices of ending coordinates
integer :: search_iter ! loop count for intersection search
integer :: bin
real(8) :: weight ! weight to be pushed back
real(8) :: uvw(3) ! cosine of angle of particle
real(8) :: xyz0(3) ! starting/intermediate coordinates
real(8) :: xyz1(3) ! ending coordinates of particle
real(8) :: xyz_cross ! coordinates of next boundary
real(8) :: d(3) ! distance to each bounding surface
real(8) :: total_distance ! distance of entire particle track
real(8) :: distance ! distance traveled in mesh cell
logical :: start_in_mesh ! starting coordinates inside mesh?
logical :: end_in_mesh ! ending coordinates inside mesh?
type(RegularMesh), pointer :: m
weight = ERROR_REAL
! Get a pointer to the mesh.
m => meshes(this % mesh)
n = m % n_dimension
if (estimator /= ESTIMATOR_TRACKLENGTH) then
! If this is an analog or collision tally, then there can only be one
! valid mesh bin.
call m % get_bin(p % coord(1) % xyz, bin)
if (bin /= NO_BIN_FOUND) then
call match % bins % push_back(bin)
call match % weights % push_back(ONE)
end if
return
end if
! A track can span multiple mesh bins so we need to handle a lot of
! intersection logic for tracklength tallies.
! ========================================================================
! Determine if the track intersects the tally mesh.
! Copy the starting and ending coordinates of the particle. Offset these
! just a bit for the purposes of determining if there was an intersection
! in case the mesh surfaces coincide with lattice/geometric surfaces which
! might produce finite-precision errors.
xyz0 = p % last_xyz + TINY_BIT * p % coord(1) % uvw
xyz1 = p % coord(1) % xyz - TINY_BIT * p % coord(1) % uvw
! Determine indices for starting and ending location.
call m % get_indices(xyz0, ijk0(:n), start_in_mesh)
call m % get_indices(xyz1, ijk1(:n), end_in_mesh)
! If this is the first iteration of the filter loop, check if the track
! intersects any part of the mesh.
if ((.not. start_in_mesh) .and. (.not. end_in_mesh)) then
if (.not. m % intersects(xyz0, xyz1)) return
end if
! ========================================================================
! Figure out which mesh cell to tally.
! Copy the un-modified coordinates the particle direction.
xyz0 = p % last_xyz
xyz1 = p % coord(1) % xyz
uvw = p % coord(1) % uvw
! Compute the length of the entire track.
total_distance = sqrt(sum((xyz1 - xyz0)**2))
! We are looking for the first valid mesh bin. Check to see if the
! particle starts inside the mesh.
if (any(ijk0(:n) < 1) .or. any(ijk0(:n) > m % dimension)) then
! The particle does not start in the mesh. Note that we nudged the
! start and end coordinates by a TINY_BIT each so we will have
! difficulty resolving tracks that are less than 2*TINY_BIT in length.
! If the track is that short, it is also insignificant so we can
! safely ignore it in the tallies.
if (total_distance < 2*TINY_BIT) return
! The particle does not start in the mesh so keep iterating the ijk0
! indices to cross the nearest mesh surface until we've found a valid
! bin. MAX_SEARCH_ITER prevents an infinite loop.
search_iter = 0
do while (any(ijk0(:n) < 1) .or. any(ijk0(:n) > m % dimension))
if (search_iter == MAX_SEARCH_ITER) then
call warning("Failed to find a mesh intersection on a tally mesh &
&filter.")
return
end if
do j = 1, n
if (abs(uvw(j)) < FP_PRECISION) then
d(j) = INFINITY
else if (uvw(j) > 0) then
xyz_cross = m % lower_left(j) + ijk0(j) * m % width(j)
d(j) = (xyz_cross - xyz0(j)) / uvw(j)
else
xyz_cross = m % lower_left(j) + (ijk0(j) - 1) * m % width(j)
d(j) = (xyz_cross - xyz0(j)) / uvw(j)
end if
end do
j = minloc(d(:n), 1)
if (uvw(j) > ZERO) then
ijk0(j) = ijk0(j) + 1
else
ijk0(j) = ijk0(j) - 1
end if
search_iter = search_iter + 1
end do
distance = d(j)
xyz0 = xyz0 + distance * uvw
end if
do
! ========================================================================
! Compute the length of the track segment in the appropiate mesh cell and
! return.
if (all(ijk0(:n) == ijk1(:n))) then
! The track ends in this cell. Use the particle end location rather
! than the mesh surface.
distance = sqrt(sum((xyz1 - xyz0)**2))
else
! The track exits this cell. Determine the distance to the closest mesh
! surface.
do j = 1, n
if (abs(uvw(j)) < FP_PRECISION) then
d(j) = INFINITY
else if (uvw(j) > 0) then
xyz_cross = m % lower_left(j) + ijk0(j) * m % width(j)
d(j) = (xyz_cross - xyz0(j)) / uvw(j)
else
xyz_cross = m % lower_left(j) + (ijk0(j) - 1) * m % width(j)
d(j) = (xyz_cross - xyz0(j)) / uvw(j)
end if
end do
j = minloc(d(:n), 1)
distance = d(j)
end if
! Assign the next tally bin and the score.
bin = m % get_bin_from_indices(ijk0(:n))
call match % bins % push_back(bin)
call match % weights % push_back(distance / total_distance)
! Find the next mesh cell that the particle enters.
! If the particle track ends in that bin, then we are done.
if (all(ijk0(:n) == ijk1(:n))) exit
! Translate the starting coordintes by the distance to that face. This
! should be the xyz that we computed the distance to in the last
! iteration of the filter loop.
xyz0 = xyz0 + distance * uvw
! Increment the indices into the next mesh cell.
if (uvw(j) > ZERO) then
ijk0(j) = ijk0(j) + 1
else
ijk0(j) = ijk0(j) - 1
end if
! If the next indices are invalid, then the track has left the mesh and
! we are done.
if (any(ijk0(:n) < 1) .or. any(ijk0(:n) > m % dimension)) exit
end do
end subroutine get_all_bins_mesh
subroutine to_statepoint_mesh(this, filter_group)
class(MeshFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
call write_dataset(filter_group, "type", "mesh")
call write_dataset(filter_group, "n_bins", this % n_bins)
call write_dataset(filter_group, "bins", meshes(this % mesh) % id)
end subroutine to_statepoint_mesh
function text_label_mesh(this, bin) result(label)
class(MeshFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
integer, allocatable :: ijk(:)
associate (m => meshes(this % mesh))
allocate(ijk(m % n_dimension))
call m % get_indices_from_bin(bin, ijk)
if (m % n_dimension == 1) then
label = "Mesh Index (" // trim(to_str(ijk(1))) // ")"
elseif (m % n_dimension == 2) then
label = "Mesh Index (" // trim(to_str(ijk(1))) // ", " // &
trim(to_str(ijk(2))) // ")"
elseif (m % n_dimension == 3) then
label = "Mesh Index (" // trim(to_str(ijk(1))) // ", " // &
trim(to_str(ijk(2))) // ", " // trim(to_str(ijk(3))) // ")"
end if
end associate
end function text_label_mesh
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_mesh_filter_set_mesh(index, index_mesh) result(err) bind(C)
! Set the mesh for a mesh filter
integer(C_INT32_T), value, intent(in) :: index
integer(C_INT32_T), value, intent(in) :: index_mesh
integer(C_INT) :: err
err = 0
if (index >= 1 .and. index <= n_filters) then
if (allocated(filters(index) % obj)) then
select type (f => filters(index) % obj)
type is (MeshFilter)
if (index_mesh >= 1 .and. index_mesh <= n_meshes) then
f % mesh = index_mesh
f % n_bins = product(meshes(index_mesh) % dimension)
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in 'meshes' array is out of bounds.")
end if
class default
err = E_INVALID_TYPE
call set_errmsg("Tried to set mesh on a non-mesh filter.")
end select
else
err = E_ALLOCATE
call set_errmsg("Filter type has not been set yet.")
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in filters array out of bounds.")
end if
end function openmc_mesh_filter_set_mesh
end module tally_filter_mesh

112
src/tallies/tally_filter_mu.F90 Normal file
View file

@ -0,0 +1,112 @@
module tally_filter_mu
use, intrinsic :: ISO_C_BINDING
use hdf5
use algorithm, only: binary_search
use constants, only: ONE, TWO, MAX_LINE_LEN, NO_BIN_FOUND
use error, only: fatal_error
use hdf5_interface
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
!===============================================================================
! MUFILTER bins the incoming-outgoing direction cosine. This is only used for
! scatter reactions.
!===============================================================================
type, public, extends(TallyFilter) :: MuFilter
real(8), allocatable :: bins(:)
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_mu
procedure :: to_statepoint => to_statepoint_mu
procedure :: text_label => text_label_mu
end type MuFilter
contains
subroutine from_xml(this, node)
class(MuFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: i
integer :: n_angle
integer :: n
real(8) :: d_angle
n = node_word_count(node, "bins")
! Allocate and store bins
this % n_bins = n - 1
allocate(this % bins(n))
call get_node_array(node, "bins", this % bins)
! Allow a user to input a lone number which will mean that you
! subdivide [-1,1] evenly with the input being the number of bins
if (n == 1) then
n_angle = int(this % bins(1))
if (n_angle > 1) then
this % n_bins = n_angle
d_angle = TWO / n_angle
deallocate(this % bins)
allocate(this % bins(n_angle + 1))
do i = 1, n_angle
this % bins(i) = -ONE + (i - 1) * d_angle
end do
this % bins(n_angle + 1) = ONE
else
call fatal_error("Number of bins for mu filter must be&
& greater than 1.")
end if
end if
end subroutine from_xml
subroutine get_all_bins_mu(this, p, estimator, match)
class(MuFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer :: n
integer :: bin
n = this % n_bins
! Search to find incoming energy bin.
bin = binary_search(this % bins, n + 1, p % mu)
if (bin /= NO_BIN_FOUND) then
call match % bins % push_back(bin)
call match % weights % push_back(ONE)
end if
end subroutine get_all_bins_mu
subroutine to_statepoint_mu(this, filter_group)
class(MuFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
call write_dataset(filter_group, "type", "mu")
call write_dataset(filter_group, "n_bins", this % n_bins)
call write_dataset(filter_group, "bins", this % bins)
end subroutine to_statepoint_mu
function text_label_mu(this, bin) result(label)
class(MuFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
real(8) :: E0, E1
E0 = this % bins(bin)
E1 = this % bins(bin + 1)
label = "Change-in-Angle [" // trim(to_str(E0)) // ", " &
// trim(to_str(E1)) // ")"
end function text_label_mu
end module tally_filter_mu

120
src/tallies/tally_filter_polar.F90 Normal file
View file

@ -0,0 +1,120 @@
module tally_filter_polar
use, intrinsic :: ISO_C_BINDING
use hdf5
use algorithm, only: binary_search
use constants
use error, only: fatal_error
use hdf5_interface
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
!===============================================================================
! POLARFILTER bins the incident neutron polar angle (relative to the global
! z-axis).
!===============================================================================
type, public, extends(TallyFilter) :: PolarFilter
real(8), allocatable :: bins(:)
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_polar
procedure :: to_statepoint => to_statepoint_polar
procedure :: text_label => text_label_polar
end type PolarFilter
contains
subroutine from_xml(this, node)
class(PolarFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: i
integer :: n_angle
integer :: n
real(8) :: d_angle
n = node_word_count(node, "bins")
! Allocate and store bins
this % n_bins = n - 1
allocate(this % bins(n))
call get_node_array(node, "bins", this % bins)
! Allow a user to input a lone number which will mean that you
! subdivide [0,pi] evenly with the input being the number of bins
if (n == 1) then
n_angle = int(this % bins(1))
if (n_angle > 1) then
this % n_bins = n_angle
d_angle = PI / real(n_angle,8)
deallocate(this % bins)
allocate(this % bins(n_angle + 1))
do i = 1, n_angle
this % bins(i) = (i - 1) * d_angle
end do
this % bins(n_angle + 1) = PI
else
call fatal_error("Number of bins for polar filter must be&
& greater than 1.")
end if
end if
end subroutine from_xml
subroutine get_all_bins_polar(this, p, estimator, match)
class(PolarFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer :: n
integer :: bin
real(8) :: theta
n = this % n_bins
! Make sure the correct direction vector is used.
if (estimator == ESTIMATOR_TRACKLENGTH) then
theta = acos(p % coord(1) % uvw(3))
else
theta = acos(p % last_uvw(3))
end if
! Search to find polar angle bin.
bin = binary_search(this % bins, n + 1, theta)
if (bin /= NO_BIN_FOUND) then
call match % bins % push_back(bin)
call match % weights % push_back(ONE)
end if
end subroutine get_all_bins_polar
subroutine to_statepoint_polar(this, filter_group)
class(PolarFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
call write_dataset(filter_group, "type", "polar")
call write_dataset(filter_group, "n_bins", this % n_bins)
call write_dataset(filter_group, "bins", this % bins)
end subroutine to_statepoint_polar
function text_label_polar(this, bin) result(label)
class(PolarFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
real(8) :: E0, E1
E0 = this % bins(bin)
E1 = this % bins(bin + 1)
label = "Polar Angle [" // trim(to_str(E0)) // ", " // trim(to_str(E1)) &
// ")"
end function text_label_polar
end module tally_filter_polar

108
src/tallies/tally_filter_surface.F90 Normal file
View file

@ -0,0 +1,108 @@
module tally_filter_surface
use, intrinsic :: ISO_C_BINDING
use hdf5
use constants, only: ONE, MAX_LINE_LEN
use error, only: fatal_error
use hdf5_interface
use surface_header
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
!===============================================================================
! SURFACEFILTER specifies which surface particles are crossing
!===============================================================================
type, public, extends(TallyFilter) :: SurfaceFilter
integer, allocatable :: surfaces(:)
! True if this filter is used for surface currents
logical :: current = .false.
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_surface
procedure :: to_statepoint => to_statepoint_surface
procedure :: text_label => text_label_surface
procedure :: initialize => initialize_surface
end type SurfaceFilter
contains
subroutine from_xml(this, node)
class(SurfaceFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: n
n = node_word_count(node, "bins")
! Allocate and store bins
this % n_bins = n
allocate(this % surfaces(n))
call get_node_array(node, "bins", this % surfaces)
end subroutine from_xml
subroutine get_all_bins_surface(this, p, estimator, match)
class(SurfaceFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer :: i
do i = 1, this % n_bins
if (abs(p % surface) == this % surfaces(i)) then
call match % bins % push_back(i)
if (p % surface < 0) then
call match % weights % push_back(-ONE)
else
call match % weights % push_back(ONE)
end if
exit
end if
end do
end subroutine get_all_bins_surface
subroutine to_statepoint_surface(this, filter_group)
class(SurfaceFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
call write_dataset(filter_group, "type", "surface")
call write_dataset(filter_group, "n_bins", this % n_bins)
call write_dataset(filter_group, "bins", this % surfaces)
end subroutine to_statepoint_surface
subroutine initialize_surface(this)
class(SurfaceFilter), intent(inout) :: this
integer :: i, id
! Convert ids to indices.
do i = 1, this % n_bins
id = this % surfaces(i)
if (surface_dict % has_key(id)) then
this % surfaces(i) = surface_dict % get_key(id)
else
call fatal_error("Could not find surface " // trim(to_str(id)) &
&// " specified on tally filter.")
end if
end do
end subroutine initialize_surface
function text_label_surface(this, bin) result(label)
class(SurfaceFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
label = "Surface " // to_str(surfaces(this % surfaces(bin)) % obj % id)
end function text_label_surface
end module tally_filter_surface

116
src/tallies/tally_filter_universe.F90 Normal file
View file

@ -0,0 +1,116 @@
module tally_filter_universe
use, intrinsic :: ISO_C_BINDING
use hdf5
use constants, only: ONE, MAX_LINE_LEN
use error, only: fatal_error
use hdf5_interface
use geometry_header
use particle_header, only: Particle
use string, only: to_str
use tally_filter_header
use xml_interface
implicit none
private
!===============================================================================
! UNIVERSEFILTER specifies which geometric universes tally events reside in.
!===============================================================================
type, public, extends(TallyFilter) :: UniverseFilter
integer, allocatable :: universes(:)
type(DictIntInt) :: map
contains
procedure :: from_xml
procedure :: get_all_bins => get_all_bins_universe
procedure :: to_statepoint => to_statepoint_universe
procedure :: text_label => text_label_universe
procedure :: initialize => initialize_universe
end type UniverseFilter
contains
subroutine from_xml(this, node)
class(UniverseFilter), intent(inout) :: this
type(XMLNode), intent(in) :: node
integer :: n
n = node_word_count(node, "bins")
! Allocate and store bins
this % n_bins = n
allocate(this % universes(n))
call get_node_array(node, "bins", this % universes)
end subroutine from_xml
subroutine get_all_bins_universe(this, p, estimator, match)
class(UniverseFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
integer :: i
! Iterate over coordinate levels to see which universes match
do i = 1, p % n_coord
if (this % map % has_key(p % coord(i) % universe)) then
call match % bins % push_back(this % map % get_key(p % coord(i) &
% universe))
call match % weights % push_back(ONE)
end if
end do
end subroutine get_all_bins_universe
subroutine to_statepoint_universe(this, filter_group)
class(UniverseFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
integer :: i
integer, allocatable :: universe_ids(:)
call write_dataset(filter_group, "type", "universe")
call write_dataset(filter_group, "n_bins", this % n_bins)
allocate(universe_ids(size(this % universes)))
do i = 1, size(this % universes)
universe_ids(i) = universes(this % universes(i)) % id
end do
call write_dataset(filter_group, "bins", universe_ids)
end subroutine to_statepoint_universe
subroutine initialize_universe(this)
class(UniverseFilter), intent(inout) :: this
integer :: i, id
! Convert ids to indices.
do i = 1, this % n_bins
id = this % universes(i)
if (universe_dict % has_key(id)) then
this % universes(i) = universe_dict % get_key(id)
else
call fatal_error("Could not find universe " // trim(to_str(id)) &
&// " specified on a tally filter.")
end if
end do
! Generate mapping from universe indices to filter bins.
do i = 1, this % n_bins
call this % map % add_key(this % universes(i), i)
end do
end subroutine initialize_universe
function text_label_universe(this, bin) result(label)
class(UniverseFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
label = "Universe " // to_str(universes(this % universes(bin)) % id)
end function text_label_universe
end module tally_filter_universe

821
src/tallies/tally_header.F90 Normal file
View file

@ -0,0 +1,821 @@
module tally_header
use, intrinsic :: ISO_C_BINDING
use hdf5
use constants
use error
use dict_header, only: DictIntInt
use message_passing, only: n_procs
use nuclide_header, only: nuclide_dict
use settings, only: reduce_tallies
use stl_vector, only: VectorInt
use string, only: to_lower, to_f_string, str_to_int, to_str
use tally_filter_header, only: TallyFilterContainer, filters, n_filters
use tally_filter
use trigger_header, only: TriggerObject
implicit none
private
public :: configure_tallies
public :: free_memory_tally
public :: openmc_extend_tallies
public :: openmc_get_tally_index
public :: openmc_tally_get_id
public :: openmc_tally_get_filters
public :: openmc_tally_get_nuclides
public :: openmc_tally_results
public :: openmc_tally_set_filters
public :: openmc_tally_set_id
public :: openmc_tally_set_nuclides
public :: openmc_tally_set_scores
!===============================================================================
! TALLYOBJECT describes a user-specified tally. The region of phase space to
! tally in is given by the TallyFilters and the results are stored in a
! TallyResult array.
!===============================================================================
type, public :: TallyObject
! Basic data
integer :: id ! user-defined identifier
character(len=104) :: name = "" ! user-defined name
integer :: type = TALLY_VOLUME ! volume, surface current
integer :: estimator = ESTIMATOR_TRACKLENGTH ! collision, track-length
real(8) :: volume ! volume of region
logical :: active = .false.
integer, allocatable :: filter(:) ! index in filters array
! The stride attribute is used for determining the index in the results
! array for a matching_bin combination. Since multiple dimensions are
! mapped onto one dimension in the results array, the stride attribute gives
! the stride for a given filter type within the results array
integer, allocatable :: stride(:)
! This array provides a way to lookup what index in the filters array a
! certain filter is. For example, if find_filter(FILTER_CELL) > 0, then the
! value is the index in filters(:).
integer :: find_filter(N_FILTER_TYPES) = 0
! Individual nuclides to tally
integer :: n_nuclide_bins = 0
integer, allocatable :: nuclide_bins(:)
logical :: all_nuclides = .false.
! Values to score, e.g. flux, absorption, etc.
! scat_order is the scattering order for each score.
! It is to be 0 if the scattering order is 0, or if the score is not a
! scattering response.
integer :: n_score_bins = 0
integer, allocatable :: score_bins(:)
integer, allocatable :: moment_order(:)
integer :: n_user_score_bins = 0
! Results for each bin -- the first dimension of the array is for scores
! (e.g. flux, total reaction rate, fission reaction rate, etc.) and the
! second dimension of the array is for the combination of filters
! (e.g. specific cell, specific energy group, etc.)
integer :: n_filter_bins = 1
integer :: total_score_bins
real(C_DOUBLE), allocatable :: results(:,:,:)
! reset property - allows a tally to be reset after every batch
logical :: reset = .false.
! Number of realizations of tally random variables
integer :: n_realizations = 0
! Tally precision triggers
integer :: n_triggers = 0 ! # of triggers
type(TriggerObject), allocatable :: triggers(:) ! Array of triggers
! Index for the TallyDerivative for differential tallies.
integer :: deriv = NONE
contains
procedure :: accumulate => tally_accumulate
procedure :: allocate_results => tally_allocate_results
procedure :: read_results_hdf5 => tally_read_results_hdf5
procedure :: write_results_hdf5 => tally_write_results_hdf5
procedure :: set_filters => tally_set_filters
end type TallyObject
type, public :: TallyContainer
class(TallyObject), allocatable :: obj
end type TallyContainer
integer(C_INT32_T), public, bind(C) :: n_tallies = 0 ! # of tallies
type(TallyContainer), public, allocatable, target :: tallies(:)
! Dictionary that maps user IDs to indices in 'tallies'
type(DictIntInt), public :: tally_dict
! Global tallies
! 1) collision estimate of k-eff
! 2) absorption estimate of k-eff
! 3) track-length estimate of k-eff
! 4) leakage fraction
real(C_DOUBLE), public, allocatable, target :: global_tallies(:,:)
! It is possible to protect accumulate operations on global tallies by using
! an atomic update. However, when multiple threads accumulate to the same
! global tally, it can cause a higher cache miss rate due to
! invalidation. Thus, we use threadprivate variables to accumulate global
! tallies and then reduce at the end of a generation.
real(C_DOUBLE), public :: global_tally_collision = ZERO
real(C_DOUBLE), public :: global_tally_absorption = ZERO
real(C_DOUBLE), public :: global_tally_tracklength = ZERO
real(C_DOUBLE), public :: global_tally_leakage = ZERO
!$omp threadprivate(global_tally_collision, global_tally_absorption, &
!$omp& global_tally_tracklength, global_tally_leakage)
! Active tally lists
type(VectorInt), public :: active_analog_tallies
type(VectorInt), public :: active_tracklength_tallies
type(VectorInt), public :: active_current_tallies
type(VectorInt), public :: active_collision_tallies
type(VectorInt), public :: active_tallies
type(VectorInt), public :: active_surface_tallies
! Normalization for statistics
integer, public :: n_realizations = 0 ! # of independent realizations
real(8), public :: total_weight ! total starting particle weight in realization
contains
!===============================================================================
! ACCUMULATE_TALLY
!===============================================================================
subroutine tally_accumulate(this)
class(TallyObject), intent(inout) :: this
integer :: i, j
real(C_DOUBLE) :: val
! Increment number of realizations
if (reduce_tallies) then
this % n_realizations = this % n_realizations + 1
else
this % n_realizations = this % n_realizations + n_procs
end if
! Accumulate each result
do j = 1, size(this % results, 3)
do i = 1, size(this % results, 2)
val = this % results(RESULT_VALUE, i, j)/total_weight
this % results(RESULT_VALUE, i, j) = ZERO
this % results(RESULT_SUM, i, j) = &
this % results(RESULT_SUM, i, j) + val
this % results(RESULT_SUM_SQ, i, j) = &
this % results(RESULT_SUM_SQ, i, j) + val*val
end do
end do
end subroutine tally_accumulate
subroutine tally_write_results_hdf5(this, group_id)
class(TallyObject), intent(in) :: this
integer(HID_T), intent(in) :: group_id
integer :: hdf5_err
integer(HID_T) :: dset, dspace
integer(HID_T) :: memspace
integer(HSIZE_T) :: dims(3)
integer(HSIZE_T) :: dims_slab(3)
integer(HSIZE_T) :: offset(3) = [1,0,0]
! Create file dataspace
dims_slab(:) = shape(this % results)
dims_slab(1) = 2
call h5screate_simple_f(3, dims_slab, dspace, hdf5_err)
! Create memory dataspace that contains only SUM and SUM_SQ values
dims(:) = shape(this % results)
call h5screate_simple_f(3, dims, memspace, hdf5_err)
call h5sselect_hyperslab_f(memspace, H5S_SELECT_SET_F, offset, dims_slab, &
hdf5_err)
! Create and write to dataset
call h5dcreate_f(group_id, "results", H5T_NATIVE_DOUBLE, dspace, dset, &
hdf5_err)
call h5dwrite_f(dset, H5T_NATIVE_DOUBLE, this % results, dims_slab, &
hdf5_err, mem_space_id=memspace)
! Close identifiers
call h5dclose_f(dset, hdf5_err)
call h5sclose_f(memspace, hdf5_err)
call h5sclose_f(dspace, hdf5_err)
end subroutine tally_write_results_hdf5
subroutine tally_read_results_hdf5(this, group_id)
class(TallyObject), intent(inout) :: this
integer(HID_T), intent(in) :: group_id
integer :: hdf5_err
integer(HID_T) :: dset, dspace
integer(HID_T) :: memspace
integer(HSIZE_T) :: dims(3)
integer(HSIZE_T) :: dims_slab(3)
integer(HSIZE_T) :: offset(3) = [1,0,0]
! Create file dataspace
dims_slab(:) = shape(this % results)
dims_slab(1) = 2
call h5screate_simple_f(3, dims_slab, dspace, hdf5_err)
! Create memory dataspace that contains only SUM and SUM_SQ values
dims(:) = shape(this % results)
call h5screate_simple_f(3, dims, memspace, hdf5_err)
call h5sselect_hyperslab_f(memspace, H5S_SELECT_SET_F, offset, dims_slab, &
hdf5_err)
! Create and write to dataset
call h5dopen_f(group_id, "results", dset, hdf5_err)
call h5dread_f(dset, H5T_NATIVE_DOUBLE, this % results, dims_slab, &
hdf5_err, mem_space_id=memspace)
! Close identifiers
call h5dclose_f(dset, hdf5_err)
call h5sclose_f(memspace, hdf5_err)
call h5sclose_f(dspace, hdf5_err)
end subroutine tally_read_results_hdf5
!===============================================================================
! ALLOCATE_RESULTS allocates and initializes the results component of the
! TallyObject derived type
!===============================================================================
subroutine tally_allocate_results(this)
class(TallyObject), intent(inout) :: this
! If no nuclides were specified, add a single bin for total material
if (.not. allocated(this % nuclide_bins)) then
allocate(this % nuclide_bins(1))
this % nuclide_bins(1) = -1
this % n_nuclide_bins = 1
end if
! Set total number of filter and scoring bins
this % total_score_bins = this % n_score_bins * this % n_nuclide_bins
if (allocated(this % results)) then
! If results was already allocated but shape is wrong, then reallocate it
! to the correct shape
if (this % total_score_bins /= size(this % results, 2) .or. &
this % n_filter_bins /= size(this % results, 3)) then
deallocate(this % results)
allocate(this % results(3, this % total_score_bins, this % n_filter_bins))
end if
else
allocate(this % results(3, this % total_score_bins, this % n_filter_bins))
end if
! Initialize results array to zero
this % results(:,:,:) = ZERO
end subroutine tally_allocate_results
function tally_set_filters(this, filter_indices) result(err)
class(TallyObject), intent(inout) :: this
integer(C_INT32_T), intent(in) :: filter_indices(:)
integer(C_INT) :: err
integer :: i ! index in this % filter/stride
integer :: j ! index in this % find_filter
integer :: k ! index in global filters array
integer :: n ! number of filters
integer :: stride ! filter stride
err = 0
this % find_filter(:) = 0
n = size(filter_indices)
do i = 1, n
k = filter_indices(i)
if (k < 1 .or. k > n_filters) then
err = E_OUT_OF_BOUNDS
call set_errmsg("Index in tally filter array out of bounds.")
exit
end if
! Set the filter index in the tally find_filter array
select type (filt => filters(k) % obj)
type is (DistribcellFilter)
j = FILTER_DISTRIBCELL
type is (CellFilter)
j = FILTER_CELL
type is (CellFromFilter)
j = FILTER_CELLFROM
type is (CellbornFilter)
j = FILTER_CELLBORN
type is (MaterialFilter)
j = FILTER_MATERIAL
type is (UniverseFilter)
j = FILTER_UNIVERSE
type is (SurfaceFilter)
j = FILTER_SURFACE
type is (MeshFilter)
j = FILTER_MESH
type is (EnergyFilter)
j = FILTER_ENERGYIN
type is (EnergyoutFilter)
j = FILTER_ENERGYOUT
this % estimator = ESTIMATOR_ANALOG
type is (DelayedGroupFilter)
j = FILTER_DELAYEDGROUP
type is (MuFilter)
j = FILTER_MU
this % estimator = ESTIMATOR_ANALOG
type is (PolarFilter)
j = FILTER_POLAR
type is (AzimuthalFilter)
j = FILTER_AZIMUTHAL
type is (EnergyFunctionFilter)
j = FILTER_ENERGYFUNCTION
end select
this % find_filter(j) = i
end do
if (err == 0) then
if (allocated(this % filter)) deallocate(this % filter)
if (allocated(this % stride)) deallocate(this % stride)
allocate(this % filter(n), this % stride(n))
! Filters are traversed in reverse so that the last filter has the
! shortest stride in memory and the first filter has the largest stride
stride = 1
do i = n, 1, -1
! Set filter and stride
k = filter_indices(i)
this % filter(i) = k
this % stride(i) = stride
! Multiply stride by number of bins in this filter
stride = stride * filters(k) % obj % n_bins
end do
! Set total number of filter bins
this % n_filter_bins = stride
end if
end function tally_set_filters
!===============================================================================
! CONFIGURE_TALLIES initializes several data structures related to tallies. This
! is called after the basic tally data has already been read from the
! tallies.xml file.
!===============================================================================
subroutine configure_tallies()
integer :: i
! Allocate and initialize global tallies
if (.not. allocated(global_tallies)) then
allocate(global_tallies(3, N_GLOBAL_TALLIES))
end if
global_tallies(:,:) = ZERO
do i = 1, n_tallies
call tallies(i) % obj % allocate_results()
end do
end subroutine configure_tallies
!===============================================================================
! FREE_MEMORY_TALLY deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_tally()
n_tallies = 0
if (allocated(tallies)) deallocate(tallies)
call tally_dict % clear()
if (allocated(global_tallies)) deallocate(global_tallies)
! Deallocate tally node lists
call active_analog_tallies % clear()
call active_tracklength_tallies % clear()
call active_current_tallies % clear()
call active_collision_tallies % clear()
call active_surface_tallies % clear()
call active_tallies % clear()
end subroutine free_memory_tally
!===============================================================================
! C API FUNCTIONS
!===============================================================================
function openmc_extend_tallies(n, index_start, index_end) result(err) bind(C)
! Extend the tallies array by n elements
integer(C_INT32_T), value, intent(in) :: n
integer(C_INT32_T), optional, intent(out) :: index_start
integer(C_INT32_T), optional, intent(out) :: index_end
integer(C_INT) :: err
integer :: i
type(TallyContainer), allocatable :: temp(:) ! temporary tallies array
if (n_tallies == 0) then
! Allocate tallies array
allocate(tallies(n))
else
! Allocate tallies array with increased size
allocate(temp(n_tallies + n))
! Move original tallies to temporary array
do i = 1, n_tallies
call move_alloc(tallies(i) % obj, temp(i) % obj)
end do
! Move allocation from temporary array
call move_alloc(FROM=temp, TO=tallies)
end if
! Return indices in tallies array
if (present(index_start)) index_start = n_tallies + 1
if (present(index_end)) index_end = n_tallies + n
n_tallies = n_tallies + n
err = 0
end function openmc_extend_tallies
function openmc_get_tally_index(id, index) result(err) bind(C)
! Returns the index in the tallies array of a tally with a given ID
integer(C_INT32_T), value :: id
integer(C_INT32_T), intent(out) :: index
integer(C_INT) :: err
if (allocated(tallies)) then
if (tally_dict % has_key(id)) then
index = tally_dict % get_key(id)
err = 0
else
err = E_INVALID_ID
call set_errmsg("No tally exists with ID=" // trim(to_str(id)) // ".")
end if
else
err = E_ALLOCATE
call set_errmsg("Memory has not been allocated for tallies.")
end if
end function openmc_get_tally_index
function openmc_tally_get_id(index, id) result(err) bind(C)
! Return the ID of a tally
integer(C_INT32_T), value :: index
integer(C_INT32_T), intent(out) :: id
integer(C_INT) :: err
if (index >= 1 .and. index <= size(tallies)) then
id = tallies(index) % obj % id
err = 0
else
err = E_OUT_OF_BOUNDS
call set_errmsg('Index in tallies array is out of bounds.')
end if
end function openmc_tally_get_id
function openmc_tally_get_filters(index, filter_indices, n) result(err) bind(C)
! Return the list of filters assigned to a tally
integer(C_INT32_T), value :: index
type(C_PTR), intent(out) :: filter_indices
integer(C_INT), intent(out) :: n
integer(C_INT) :: err
if (index >= 1 .and. index <= size(tallies)) then
associate (t => tallies(index) % obj)
if (allocated(t % filter)) then
filter_indices = C_LOC(t % filter(1))
n = size(t % filter)
err = 0
else
err = E_ALLOCATE
call set_errmsg("Tally filters have not been allocated yet.")
end if
end associate
else
err = E_OUT_OF_BOUNDS
call set_errmsg('Index in tallies array is out of bounds.')
end if
end function openmc_tally_get_filters
function openmc_tally_get_nuclides(index, nuclides, n) result(err) bind(C)
! Return the list of nuclides assigned to a tally
integer(C_INT32_T), value :: index
type(C_PTR), intent(out) :: nuclides
integer(C_INT), intent(out) :: n
integer(C_INT) :: err
if (index >= 1 .and. index <= size(tallies)) then
associate (t => tallies(index) % obj)
if (allocated(t % nuclide_bins)) then
nuclides = C_LOC(t % nuclide_bins(1))
n = size(t % nuclide_bins)
err = 0
else
err = E_ALLOCATE
call set_errmsg("Tally nuclides have not been allocated yet.")
end if
end associate
else
err = E_OUT_OF_BOUNDS
call set_errmsg('Index in tallies array is out of bounds.')
end if
end function openmc_tally_get_nuclides
function openmc_tally_results(index, ptr, shape_) result(err) bind(C)
! Returns a pointer to a tally results array along with its shape. This
! allows a user to obtain in-memory tally results from Python directly.
integer(C_INT32_T), intent(in), value :: index
type(C_PTR), intent(out) :: ptr
integer(C_INT), intent(out) :: shape_(3)
integer(C_INT) :: err
if (index >= 1 .and. index <= size(tallies)) then
associate (t => tallies(index) % obj)
if (allocated(t % results)) then
ptr = C_LOC(t % results(1,1,1))
shape_(:) = shape(t % results)
err = 0
else
err = E_ALLOCATE
call set_errmsg("Tally results have not been allocated yet.")
end if
end associate
else
err = E_OUT_OF_BOUNDS
call set_errmsg('Index in tallies array is out of bounds.')
end if
end function openmc_tally_results
function openmc_tally_set_filters(index, n, filter_indices) result(err) bind(C)
! Set the list of filters for a tally
integer(C_INT32_T), value, intent(in) :: index
integer(C_INT), value, intent(in) :: n
integer(C_INT32_T), intent(in) :: filter_indices(n)
integer(C_INT) :: err
err = 0
if (index >= 1 .and. index <= n_tallies) then
if (allocated(tallies(index) % obj)) then
err = tallies(index) % obj % set_filters(filter_indices)
else
err = E_ALLOCATE
call set_errmsg("Tally type has not been set yet.")
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg('Index in tallies array is out of bounds.')
end if
end function openmc_tally_set_filters
function openmc_tally_set_id(index, id) result(err) bind(C)
! Set the ID of a tally
integer(C_INT32_T), value, intent(in) :: index
integer(C_INT32_T), value, intent(in) :: id
integer(C_INT) :: err
if (index >= 1 .and. index <= n_tallies) then
if (allocated(tallies(index) % obj)) then
tallies(index) % obj % id = id
call tally_dict % add_key(id, index)
err = 0
else
err = E_ALLOCATE
call set_errmsg("Tally type has not been set yet.")
end if
else
err = E_OUT_OF_BOUNDS
call set_errmsg('Index in tallies array is out of bounds.')
end if
end function openmc_tally_set_id
function openmc_tally_set_nuclides(index, n, nuclides) result(err) bind(C)
! Sets the nuclides in the tally which results should be scored for
integer(C_INT32_T), value :: index
integer(C_INT), value :: n
type(C_PTR), intent(in) :: nuclides(n)
integer(C_INT) :: err
integer :: i
character(C_CHAR), pointer :: string(:)
character(len=:, kind=C_CHAR), allocatable :: nuclide_
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(tallies)) then
associate (t => tallies(index) % obj)
if (allocated(t % nuclide_bins)) deallocate(t % nuclide_bins)
allocate(t % nuclide_bins(n))
t % n_nuclide_bins = n
do i = 1, n
! Convert C string to Fortran string
call c_f_pointer(nuclides(i), string, [10])
nuclide_ = to_lower(to_f_string(string))
select case (nuclide_)
case ('total')
t % nuclide_bins(i) = -1
case default
if (nuclide_dict % has_key(nuclide_)) then
t % nuclide_bins(i) = nuclide_dict % get_key(nuclide_)
else
err = E_DATA
call set_errmsg("Nuclide '" // trim(to_f_string(string)) // &
"' has not been loaded yet.")
return
end if
end select
end do
err = 0
end associate
else
err = E_OUT_OF_BOUNDS
call set_errmsg('Index in tallies array is out of bounds.')
end if
end function openmc_tally_set_nuclides
function openmc_tally_set_scores(index, n, scores) result(err) bind(C)
! Sets the scores in the tally
integer(C_INT32_T), value :: index
integer(C_INT), value :: n
type(C_PTR), intent(in) :: scores(n)
integer(C_INT) :: err
integer :: i
integer :: MT
character(C_CHAR), pointer :: string(:)
character(len=:, kind=C_CHAR), allocatable :: score_
err = E_UNASSIGNED
if (index >= 1 .and. index <= size(tallies)) then
associate (t => tallies(index) % obj)
if (allocated(t % score_bins)) deallocate(t % score_bins)
allocate(t % score_bins(n))
t % n_user_score_bins = n
t % n_score_bins = n
do i = 1, n
! Convert C string to Fortran string
call c_f_pointer(scores(i), string, [20])
score_ = to_lower(to_f_string(string))
select case (score_)
case ('flux')
t % score_bins(i) = SCORE_FLUX
case ('total', '(n,total)')
t % score_bins(i) = SCORE_TOTAL
case ('scatter')
t % score_bins(i) = SCORE_SCATTER
case ('nu-scatter')
t % score_bins(i) = SCORE_NU_SCATTER
case ('(n,2n)')
t % score_bins(i) = N_2N
case ('(n,3n)')
t % score_bins(i) = N_3N
case ('(n,4n)')
t % score_bins(i) = N_4N
case ('absorption')
t % score_bins(i) = SCORE_ABSORPTION
case ('fission', '18')
t % score_bins(i) = SCORE_FISSION
case ('nu-fission')
t % score_bins(i) = SCORE_NU_FISSION
case ('decay-rate')
t % score_bins(i) = SCORE_DECAY_RATE
case ('delayed-nu-fission')
t % score_bins(i) = SCORE_DELAYED_NU_FISSION
case ('prompt-nu-fission')
t % score_bins(i) = SCORE_PROMPT_NU_FISSION
case ('kappa-fission')
t % score_bins(i) = SCORE_KAPPA_FISSION
case ('inverse-velocity')
t % score_bins(i) = SCORE_INVERSE_VELOCITY
case ('fission-q-prompt')
t % score_bins(i) = SCORE_FISS_Q_PROMPT
case ('fission-q-recoverable')
t % score_bins(i) = SCORE_FISS_Q_RECOV
case ('current')
t % score_bins(i) = SCORE_CURRENT
case ('events')
t % score_bins(i) = SCORE_EVENTS
case ('elastic', '(n,elastic)')
t % score_bins(i) = ELASTIC
case ('(n,2nd)')
t % score_bins(i) = N_2ND
case ('(n,na)')
t % score_bins(i) = N_2NA
case ('(n,n3a)')
t % score_bins(i) = N_N3A
case ('(n,2na)')
t % score_bins(i) = N_2NA
case ('(n,3na)')
t % score_bins(i) = N_3NA
case ('(n,np)')
t % score_bins(i) = N_NP
case ('(n,n2a)')
t % score_bins(i) = N_N2A
case ('(n,2n2a)')
t % score_bins(i) = N_2N2A
case ('(n,nd)')
t % score_bins(i) = N_ND
case ('(n,nt)')
t % score_bins(i) = N_NT
case ('(n,nHe-3)')
t % score_bins(i) = N_N3HE
case ('(n,nd2a)')
t % score_bins(i) = N_ND2A
case ('(n,nt2a)')
t % score_bins(i) = N_NT2A
case ('(n,3nf)')
t % score_bins(i) = N_3NF
case ('(n,2np)')
t % score_bins(i) = N_2NP
case ('(n,3np)')
t % score_bins(i) = N_3NP
case ('(n,n2p)')
t % score_bins(i) = N_N2P
case ('(n,npa)')
t % score_bins(i) = N_NPA
case ('(n,n1)')
t % score_bins(i) = N_N1
case ('(n,nc)')
t % score_bins(i) = N_NC
case ('(n,gamma)')
t % score_bins(i) = N_GAMMA
case ('(n,p)')
t % score_bins(i) = N_P
case ('(n,d)')
t % score_bins(i) = N_D
case ('(n,t)')
t % score_bins(i) = N_T
case ('(n,3He)')
t % score_bins(i) = N_3HE
case ('(n,a)')
t % score_bins(i) = N_A
case ('(n,2a)')
t % score_bins(i) = N_2A
case ('(n,3a)')
t % score_bins(i) = N_3A
case ('(n,2p)')
t % score_bins(i) = N_2P
case ('(n,pa)')
t % score_bins(i) = N_PA
case ('(n,t2a)')
t % score_bins(i) = N_T2A
case ('(n,d2a)')
t % score_bins(i) = N_D2A
case ('(n,pd)')
t % score_bins(i) = N_PD
case ('(n,pt)')
t % score_bins(i) = N_PT
case ('(n,da)')
t % score_bins(i) = N_DA
case default
! Assume that user has specified an MT number
MT = int(str_to_int(score_))
if (MT /= ERROR_INT) then
! Specified score was an integer
if (MT > 1) then
t % score_bins(i) = MT
else
err = E_INVALID_ARGUMENT
call set_errmsg("Negative MT number cannot be used as a score.")
end if
else
err = E_INVALID_ARGUMENT
call set_errmsg("Unknown score: " // trim(score_) // ".")
end if
end select
end do
err = 0
end associate
else
err = E_OUT_OF_BOUNDS
call set_errmsg('Index in tallies array is out of bounds.')
end if
end function openmc_tally_set_scores
end module tally_header

28
src/trigger.F90 → src/tallies/trigger.F90
View file

@ -8,15 +8,17 @@ module trigger
use constants
use eigenvalue, only: openmc_get_keff
use global
use string, only: to_str
use output, only: warning, write_message
use mesh, only: bin_to_mesh_indices
use mesh_header, only: RegularMesh
use mesh_header, only: RegularMesh, meshes
use message_passing, only: master
use trigger_header, only: TriggerObject
use settings
use simulation_header
use trigger_header
use tally, only: TallyObject
use tally_filter, only: MeshFilter
use tally_filter_mesh, only: MeshFilter
use tally_filter_header, only: filter_matches, filters
use tally_header, only: tallies, n_tallies
implicit none
@ -110,8 +112,6 @@ contains
real(8) :: rel_err = ZERO ! trigger relative error
real(8) :: ratio ! ratio of the uncertainty/trigger threshold
real(C_DOUBLE) :: k_combined(2)
type(TallyObject), pointer :: t ! tally pointer
type(TriggerObject), pointer :: trigger ! tally trigger
! Initialize tally trigger maximum uncertainty ratio to zero
max_ratio = 0
@ -152,7 +152,7 @@ contains
! Compute uncertainties for all tallies, scores with triggers
TALLY_LOOP: do i = 1, n_tallies
t => tallies(i)
associate (t => tallies(i) % obj)
! Cycle through if only one batch has been simumlate
if (t % n_realizations == 1) then
@ -160,7 +160,7 @@ contains
end if
TRIGGER_LOOP: do s = 1, t % n_triggers
trigger => t % triggers(s)
associate (trigger => t % triggers(s))
! Initialize trigger uncertainties to zero
trigger % std_dev = ZERO
@ -179,7 +179,7 @@ contains
call filter_matches(t % filter(j)) % bins % push_back(0)
end do
FILTER_LOOP: do filter_index = 1, t % total_filter_bins
FILTER_LOOP: do filter_index = 1, t % n_filter_bins
! Initialize score index
score_index = trigger % score_index
@ -280,7 +280,9 @@ contains
if (size(t % filter) == 0) exit FILTER_LOOP
end do FILTER_LOOP
end if
end associate
end do TRIGGER_LOOP
end associate
end do TALLY_LOOP
end if
end subroutine check_tally_triggers
@ -292,6 +294,8 @@ contains
!===============================================================================
subroutine compute_tally_current(t, trigger)
type(TallyObject), intent(in) :: t ! mesh current tally
type(TriggerObject), intent(inout) :: trigger ! mesh current tally trigger
integer :: i ! mesh index
integer :: j ! loop index for tally filters
@ -307,8 +311,6 @@ contains
logical :: print_ebin ! should incoming energy bin be displayed?
real(8) :: rel_err = ZERO ! temporary relative error of result
real(8) :: std_dev = ZERO ! temporary standard deviration of result
type(TallyObject), pointer :: t ! mesh current tally
type(TriggerObject) :: trigger ! mesh current tally trigger
type(RegularMesh), pointer :: m ! surface current mesh
! Get pointer to mesh
@ -344,7 +346,7 @@ contains
do i = 1, n_cells
! Get the indices for this cell
call bin_to_mesh_indices(m, i, ijk)
call m % get_indices_from_bin(i, ijk)
filter_matches(i_filter_mesh) % bins % data(1) = i
do l = 1, n

7
src/trigger_header.F90 → src/tallies/trigger_header.F90
View file

@ -3,12 +3,13 @@ module trigger_header
use constants, only: NONE, N_FILTER_TYPES, ZERO
implicit none
private
!===============================================================================
! TRIGGEROBJECT stores the variance, relative error and standard deviation
! for some user-specified trigger.
!===============================================================================
type TriggerObject
type, public :: TriggerObject
integer :: type ! "variance", "std_dev" or "rel_err"
real(8) :: threshold ! a convergence threshold
character(len=52) :: score_name ! the name of the score
@ -21,9 +22,11 @@ module trigger_header
!===============================================================================
! KTRIGGER describes a user-specified precision trigger for k-effective
!===============================================================================
type KTrigger
type, public :: KTrigger
integer :: trigger_type = 0
real(8) :: threshold = ZERO
end type KTrigger
type(KTrigger), public :: keff_trigger ! trigger for k-effective
end module trigger_header

1567
src/tally_filter.F90
View file

File diff suppressed because it is too large Load diff

107
src/tally_filter_header.F90
View file

@ -1,107 +0,0 @@
module tally_filter_header
use constants, only: MAX_LINE_LEN
use particle_header, only: Particle
use stl_vector, only: VectorInt, VectorReal
use hdf5
implicit none
!===============================================================================
! TALLYFILTERMATCH stores every valid bin and weight for a filter
!===============================================================================
type TallyFilterMatch
! Index of the bin and weight being used in the current filter combination
integer :: i_bin
type(VectorInt) :: bins
type(VectorReal) :: weights
! Indicates whether all valid bins for this filter have been found
logical :: bins_present = .false.
end type TallyFilterMatch
!===============================================================================
! TALLYFILTER describes a filter that limits what events score to a tally. For
! example, a cell filter indicates that only particles in a specified cell
! should score to the tally.
!===============================================================================
type, abstract :: TallyFilter
integer :: id
integer :: n_bins = 0
contains
procedure(get_all_bins_), deferred :: get_all_bins
procedure(to_statepoint_), deferred :: to_statepoint
procedure(text_label_), deferred :: text_label
procedure :: initialize => filter_initialize
end type TallyFilter
abstract interface
!===============================================================================
! GET_NEXT_BIN gives the index for the next valid filter bin and a weight that
! will be applied to the flux.
!
! In principle, a filter can have multiple valid bins. If current_bin =
! NO_BIN_FOUND, then this method should give the first valid bin. Providing the
! first valid bin should then give the second valid bin, and so on. When there
! are no valid bins left, the next_bin should be NO_VALID_BIN.
subroutine get_all_bins_(this, p, estimator, match)
import TallyFilter
import Particle
import TallyFilterMatch
class(TallyFilter), intent(in) :: this
type(Particle), intent(in) :: p
integer, intent(in) :: estimator
type(TallyFilterMatch), intent(inout) :: match
end subroutine get_all_bins_
!===============================================================================
! TO_STATEPOINT writes all the information needed to reconstruct the filter to
! the given filter_group.
subroutine to_statepoint_(this, filter_group)
import TallyFilter
import HID_T
class(TallyFilter), intent(in) :: this
integer(HID_T), intent(in) :: filter_group
end subroutine to_statepoint_
!===============================================================================
! TEXT_LABEL returns a string describing the given filter bin. For example, an
! energy filter might return the string "Incoming Energy [0.625E-6, 20.0)".
! This is used to write the tallies.out file.
function text_label_(this, bin) result(label)
import TallyFilter
import MAX_LINE_LEN
class(TallyFilter), intent(in) :: this
integer, intent(in) :: bin
character(MAX_LINE_LEN) :: label
end function text_label_
end interface
!===============================================================================
! TALLYFILTERCONTAINER contains an allocatable TallyFilter object for arrays of
! TallyFilters
!===============================================================================
type TallyFilterContainer
class(TallyFilter), allocatable :: obj
end type TallyFilterContainer
contains
!===============================================================================
! INITIALIZE sets up any internal data, as necessary. If this procedure is not
! overriden by the derived class, then it will do nothing by default.
subroutine filter_initialize(this)
class(TallyFilter), intent(inout) :: this
end subroutine filter_initialize
end module tally_filter_header

165
src/tally_header.F90
View file

@ -1,165 +0,0 @@
module tally_header
use, intrinsic :: ISO_C_BINDING
use hdf5
use constants, only: NONE, N_FILTER_TYPES
use tally_filter_header, only: TallyFilterContainer
use trigger_header, only: TriggerObject
implicit none
!===============================================================================
! TALLYDERIVATIVE describes a first-order derivative that can be applied to
! tallies.
!===============================================================================
type TallyDerivative
integer :: id
integer :: variable
integer :: diff_material
integer :: diff_nuclide
real(8) :: flux_deriv
end type TallyDerivative
!===============================================================================
! TALLYOBJECT describes a user-specified tally. The region of phase space to
! tally in is given by the TallyFilters and the results are stored in a
! TallyResult array.
!===============================================================================
type TallyObject
! Basic data
integer :: id ! user-defined identifier
character(len=104) :: name = "" ! user-defined name
integer :: type ! volume, surface current
integer :: estimator ! collision, track-length
real(8) :: volume ! volume of region
integer, allocatable :: filter(:) ! index in filters array
! The stride attribute is used for determining the index in the results
! array for a matching_bin combination. Since multiple dimensions are
! mapped onto one dimension in the results array, the stride attribute gives
! the stride for a given filter type within the results array
integer, allocatable :: stride(:)
! This array provides a way to lookup what index in the filters array a
! certain filter is. For example, if find_filter(FILTER_CELL) > 0, then the
! value is the index in filters(:).
integer :: find_filter(N_FILTER_TYPES) = 0
! Individual nuclides to tally
integer :: n_nuclide_bins = 0
integer, allocatable :: nuclide_bins(:)
logical :: all_nuclides = .false.
! Values to score, e.g. flux, absorption, etc.
! scat_order is the scattering order for each score.
! It is to be 0 if the scattering order is 0, or if the score is not a
! scattering response.
integer :: n_score_bins = 0
integer, allocatable :: score_bins(:)
integer, allocatable :: moment_order(:)
integer :: n_user_score_bins = 0
! Results for each bin -- the first dimension of the array is for scores
! (e.g. flux, total reaction rate, fission reaction rate, etc.) and the
! second dimension of the array is for the combination of filters
! (e.g. specific cell, specific energy group, etc.)
integer :: total_filter_bins
integer :: total_score_bins
real(C_DOUBLE), allocatable :: results(:,:,:)
! reset property - allows a tally to be reset after every batch
logical :: reset = .false.
! Number of realizations of tally random variables
integer :: n_realizations = 0
! Tally precision triggers
integer :: n_triggers = 0 ! # of triggers
type(TriggerObject), allocatable :: triggers(:) ! Array of triggers
! Index for the TallyDerivative for differential tallies.
integer :: deriv = NONE
contains
procedure :: write_results_hdf5
procedure :: read_results_hdf5
end type TallyObject
contains
subroutine write_results_hdf5(this, group_id)
class(TallyObject), intent(in) :: this
integer(HID_T), intent(in) :: group_id
integer :: hdf5_err
integer(HID_T) :: dset, dspace
integer(HID_T) :: memspace
integer(HSIZE_T) :: dims(3)
integer(HSIZE_T) :: dims_slab(3)
integer(HSIZE_T) :: offset(3) = [1,0,0]
! Create file dataspace
dims_slab(:) = shape(this % results)
dims_slab(1) = 2
call h5screate_simple_f(3, dims_slab, dspace, hdf5_err)
! Create memory dataspace that contains only SUM and SUM_SQ values
dims(:) = shape(this % results)
call h5screate_simple_f(3, dims, memspace, hdf5_err)
call h5sselect_hyperslab_f(memspace, H5S_SELECT_SET_F, offset, dims_slab, &
hdf5_err)
! Create and write to dataset
call h5dcreate_f(group_id, "results", H5T_NATIVE_DOUBLE, dspace, dset, &
hdf5_err)
call h5dwrite_f(dset, H5T_NATIVE_DOUBLE, this % results, dims_slab, &
hdf5_err, mem_space_id=memspace)
! Close identifiers
call h5dclose_f(dset, hdf5_err)
call h5sclose_f(memspace, hdf5_err)
call h5sclose_f(dspace, hdf5_err)
end subroutine write_results_hdf5
subroutine read_results_hdf5(this, group_id)
class(TallyObject), intent(inout) :: this
integer(HID_T), intent(in) :: group_id
integer :: hdf5_err
integer(HID_T) :: dset, dspace
integer(HID_T) :: memspace
integer(HSIZE_T) :: dims(3)
integer(HSIZE_T) :: dims_slab(3)
integer(HSIZE_T) :: offset(3) = [1,0,0]
! Create file dataspace
dims_slab(:) = shape(this % results)
dims_slab(1) = 2
call h5screate_simple_f(3, dims_slab, dspace, hdf5_err)
! Create memory dataspace that contains only SUM and SUM_SQ values
dims(:) = shape(this % results)
call h5screate_simple_f(3, dims, memspace, hdf5_err)
call h5sselect_hyperslab_f(memspace, H5S_SELECT_SET_F, offset, dims_slab, &
hdf5_err)
! Create and write to dataset
call h5dopen_f(group_id, "results", dset, hdf5_err)
call h5dread_f(dset, H5T_NATIVE_DOUBLE, this % results, dims_slab, &
hdf5_err, mem_space_id=memspace)
! Close identifiers
call h5dclose_f(dset, hdf5_err)
call h5sclose_f(memspace, hdf5_err)
call h5sclose_f(dspace, hdf5_err)
end subroutine read_results_hdf5
end module tally_header

127
src/tally_initialize.F90
View file

@ -1,127 +0,0 @@
module tally_initialize
use constants
use global
use tally_header, only: TallyObject
implicit none
private
public :: configure_tallies
public :: add_tallies
contains
!===============================================================================
! CONFIGURE_TALLIES initializes several data structures related to tallies. This
! is called after the basic tally data has already been read from the
! tallies.xml file.
!===============================================================================
subroutine configure_tallies()
! Allocate global tallies
allocate(global_tallies(3, N_GLOBAL_TALLIES))
global_tallies(:,:) = ZERO
call setup_tally_arrays()
end subroutine configure_tallies
!===============================================================================
! SETUP_TALLY_ARRAYS allocates and populates several member arrays of the
! TallyObject derived type, including stride, filter_matches, and results.
!===============================================================================
subroutine setup_tally_arrays()
integer :: i ! loop index for tallies
integer :: j ! loop index for filters
integer :: n ! temporary stride
integer :: i_filt ! filter index
type(TallyObject), pointer :: t
TALLY_LOOP: do i = 1, n_tallies
! Get pointer to tally
t => tallies(i)
! Allocate stride
allocate(t % stride(size(t % filter)))
! The filters are traversed in opposite order so that the last filter has
! the shortest stride in memory and the first filter has the largest
! stride
n = 1
STRIDE: do j = size(t % filter), 1, -1
i_filt = t % filter(j)
t % stride(j) = n
n = n * filters(i_filt) % obj % n_bins
end do STRIDE
! Set total number of filter and scoring bins
t % total_filter_bins = n
t % total_score_bins = t % n_score_bins * t % n_nuclide_bins
! Allocate results array
allocate(t % results(3, t % total_score_bins, t % total_filter_bins))
t % results(:,:,:) = ZERO
end do TALLY_LOOP
! Allocate array for matching filter bins
!$omp parallel
allocate(filter_matches(n_filters))
!$omp end parallel
end subroutine setup_tally_arrays
!===============================================================================
! ADD_TALLIES extends the tallies array with a new group of tallies and assigns
! pointers to each group. This is called once for user tallies, once for CMFD
! tallies, etc.
!===============================================================================
subroutine add_tallies(tally_group, n)
character(*), intent(in) :: tally_group ! name of tally group
integer, intent(in) :: n ! number of tallies to add
type(TallyObject), allocatable :: temp(:) ! temporary tallies array
if (n_tallies == 0) then
! Allocate tallies array
allocate(tallies(n))
else
! Allocate tallies array with increased size
allocate(temp(n_tallies + n))
! Copy original tallies to temporary array
temp(1:n_tallies) = tallies
! Move allocation from temporary array
call move_alloc(FROM=temp, TO=tallies)
end if
! Set index for ths tally group
select case(tally_group)
case ("user")
i_user_tallies = n_tallies
case ("cmfd")
i_cmfd_tallies = n_tallies
end select
! Set n_tallies
n_tallies = size(tallies)
! Reassign pointers for each group -- after the call to move_alloc, any
! pointers that were associated with tallies before become unassociated
if (i_user_tallies >= 0) then
user_tallies => tallies(i_user_tallies+1 : i_user_tallies+n_user_tallies)
end if
if (i_cmfd_tallies >= 0) then
cmfd_tallies => tallies(i_cmfd_tallies+1 : i_cmfd_tallies+n_cmfd_tallies)
end if
end subroutine add_tallies
end module tally_initialize

16
src/timer_header.F90
View file

@ -22,6 +22,22 @@ module timer_header
procedure :: reset => timer_reset
end type Timer
! ============================================================================
! TIMING VARIABLES
type(Timer) :: time_total ! timer for total run
type(Timer) :: time_initialize ! timer for initialization
type(Timer) :: time_read_xs ! timer for reading cross sections
type(Timer) :: time_unionize ! timer for material xs-energy grid union
type(Timer) :: time_bank ! timer for fission bank synchronization
type(Timer) :: time_bank_sample ! timer for fission bank sampling
type(Timer) :: time_bank_sendrecv ! timer for fission bank SEND/RECV
type(Timer) :: time_tallies ! timer for accumulate tallies
type(Timer) :: time_inactive ! timer for inactive batches
type(Timer) :: time_active ! timer for active batches
type(Timer) :: time_transport ! timer for transport only
type(Timer) :: time_finalize ! timer for finalization
contains
!===============================================================================

8
src/track_output.F90
View file

@ -5,13 +5,15 @@
module track_output
use global
use hdf5
use constants
use hdf5_interface
use particle_header, only: Particle
use settings, only: path_output
use simulation_header
use string, only: to_str
use hdf5
implicit none
private

9
src/tracking.F90
View file

@ -1,18 +1,23 @@
module tracking
use constants, only: MODE_EIGENVALUE
use constants
use cross_section, only: calculate_xs
use error, only: fatal_error, warning
use geometry_header, only: cells
use geometry, only: find_cell, distance_to_boundary, cross_surface, &
cross_lattice, check_cell_overlap
use global
use output, only: write_message
use message_passing
use mgxs_header
use nuclide_header
use particle_header, only: LocalCoord, Particle
use physics, only: collision
use physics_mg, only: collision_mg
use random_lcg, only: prn
use settings
use simulation_header
use string, only: to_str
use tally_header
use tally, only: score_analog_tally, score_tracklength_tally, &
score_collision_tally, score_surface_current, &
score_track_derivative, score_surface_tally, &

6
src/volume_calc.F90
View file

@ -9,14 +9,18 @@ module volume_calc
use constants
use geometry, only: find_cell
use global
use geometry_header, only: universes, cells
use hdf5_interface, only: file_create, file_close, write_attribute, &
create_group, close_group, write_dataset
use output, only: write_message, header, time_stamp
use material_header, only: materials
use message_passing
use nuclide_header, only: nuclides
use particle_header, only: Particle
use random_lcg, only: prn, prn_set_stream, set_particle_seed
use settings, only: path_output
use stl_vector, only: VectorInt, VectorReal
use string, only: to_str
use timer_header, only: Timer
use volume_header

10
src/volume_header.F90
View file

@ -16,6 +16,8 @@ module volume_header
procedure :: from_xml => volume_from_xml
end type VolumeCalculation
type(VolumeCalculation), allocatable :: volume_calcs(:)
contains
subroutine volume_from_xml(this, node_vol)
@ -56,4 +58,12 @@ contains
call get_node_value(node_vol, "samples", this % samples)
end subroutine volume_from_xml
!===============================================================================
! FREE_MEMORY_VOLUME deallocates global arrays defined in this module
!===============================================================================
subroutine free_memory_volume()
if (allocated(volume_calcs)) deallocate(volume_calcs)
end subroutine free_memory_volume
end module volume_header

9
tests/test_cmfd_feed/settings.xml
View file

@ -16,13 +16,14 @@
</source>
<!-- Shannon Entropy -->
<entropy>
<mesh id="10">
<dimension> 10 1 1 </dimension>
<lower_left> -10.0 -1.0 -1.0 </lower_left>
<upper_right> 10.0 1.0 1.0 </upper_right>
</entropy>
</mesh>
<entropy_mesh>10</entropy_mesh>
<!-- Run CMFD -->
<run_cmfd>true</run_cmfd>
<!-- Run CMFD -->
<run_cmfd>true</run_cmfd>
</settings>

5
tests/test_cmfd_nofeed/settings.xml
View file

@ -16,11 +16,12 @@
</source>
<!-- Shannon Entropy -->
<entropy>
<mesh id="10">
<dimension> 10 1 1 </dimension>
<lower_left> -10.0 -1.0 -1.0 </lower_left>
<upper_right> 10.0 1.0 1.0 </upper_right>
</entropy>
</mesh>
<entropy_mesh>10</entropy_mesh>
<!-- Run CMFD -->
<run_cmfd>true</run_cmfd>

6
tests/test_entropy/settings.xml
View file

@ -12,10 +12,12 @@
</space>
</source>
<entropy>
<mesh id="1">
<dimension>10 10 10</dimension>
<lower_left>-10. -10. -10.</lower_left>
<upper_right>10. 10. 10.</upper_right>
</entropy>
</mesh>
<entropy_mesh>1</entropy_mesh>
</settings>

5
tests/test_plot/settings.xml
View file

@ -3,10 +3,11 @@
<run_mode>plot</run_mode>
<entropy>
<mesh id="1">
<dimension>5 4 3</dimension>
<lower_left>-10 -10 -10</lower_left>
<upper_right>10 10 10</upper_right>
</entropy>
</mesh>
<entropy_mesh>1</entropy_mesh>
</settings>