diff --git a/CMakeLists.txt b/CMakeLists.txt index c21b44cc16..905555a050 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -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 $ - ${CMAKE_CURRENT_SOURCE_DIR}/openmc/capi/_$ + ${CMAKE_CURRENT_SOURCE_DIR}/openmc/capi/$ COMMENT "Copying libopenmc to Python module directory") #=============================================================================== diff --git a/docs/source/capi/index.rst b/docs/source/capi/index.rst index 1e30eacf18..581f358d4f 100644 --- a/docs/source/capi/index.rst +++ b/docs/source/capi/index.rst @@ -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 diff --git a/openmc/capi/__init__.py b/openmc/capi/__init__.py index 355304a310..88a69df341 100644 --- a/openmc/capi/__init__.py +++ b/openmc/capi/__init__.py @@ -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 diff --git a/openmc/capi/cell.py b/openmc/capi/cell.py index f519d2f6dc..11b0e2199d 100644 --- a/openmc/capi/cell.py +++ b/openmc/capi/cell.py @@ -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() diff --git a/openmc/capi/core.py b/openmc/capi/core.py index fe5416dd61..2234fac640 100644 --- a/openmc/capi/core.py +++ b/openmc/capi/core.py @@ -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) diff --git a/openmc/capi/error.py b/openmc/capi/error.py index 2058ceb204..7ebf2cb64c 100644 --- a/openmc/capi/error.py +++ b/openmc/capi/error.py @@ -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)) diff --git a/openmc/capi/filter.py b/openmc/capi/filter.py new file mode 100644 index 0000000000..e171e05bde --- /dev/null +++ b/openmc/capi/filter.py @@ -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() diff --git a/openmc/capi/material.py b/openmc/capi/material.py index d07d7aa8a9..ba4b650899 100644 --- a/openmc/capi/material.py +++ b/openmc/capi/material.py @@ -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() diff --git a/openmc/capi/nuclide.py b/openmc/capi/nuclide.py index 4c6248d6be..16bb71accd 100644 --- a/openmc/capi/nuclide.py +++ b/openmc/capi/nuclide.py @@ -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() diff --git a/openmc/capi/settings.py b/openmc/capi/settings.py new file mode 100644 index 0000000000..11b0eacef5 --- /dev/null +++ b/openmc/capi/settings.py @@ -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() diff --git a/openmc/capi/tally.py b/openmc/capi/tally.py index 611f1ce879..335cbb8e77 100644 --- a/openmc/capi/tally.py +++ b/openmc/capi/tally.py @@ -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() diff --git a/openmc/settings.py b/openmc/settings.py index 3efdf1ab7a..c608994fa7 100644 --- a/openmc/settings.py +++ b/openmc/settings.py @@ -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 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 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) diff --git a/openmc/statepoint.py b/openmc/statepoint.py index 474b03033a..16d5b5d848 100644 --- a/openmc/statepoint.py +++ b/openmc/statepoint.py @@ -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 diff --git a/setup.py b/setup.py index 67bc734035..7ca824ab01 100755 --- a/setup.py +++ b/setup.py @@ -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'] }, diff --git a/src/api.F90 b/src/api.F90 index 23aa405873..3b2fdacad8 100644 --- a/src/api.F90 +++ b/src/api.F90 @@ -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 diff --git a/src/bank_header.F90 b/src/bank_header.F90 index 97fb1f11fa..961824a406 100644 --- a/src/bank_header.F90 +++ b/src/bank_header.F90 @@ -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 diff --git a/src/cmfd_data.F90 b/src/cmfd_data.F90 index 177f140b63..5eb2158e91 100644 --- a/src/cmfd_data.F90 +++ b/src/cmfd_data.F90 @@ -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 diff --git a/src/cmfd_execute.F90 b/src/cmfd_execute.F90 index e87bff930c..140166e0a4 100644 --- a/src/cmfd_execute.F90 +++ b/src/cmfd_execute.F90 @@ -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 diff --git a/src/cmfd_header.F90 b/src/cmfd_header.F90 index e743cc928e..2e6162b49e 100644 --- a/src/cmfd_header.F90 +++ b/src/cmfd_header.F90 @@ -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 diff --git a/src/cmfd_input.F90 b/src/cmfd_input.F90 index 68cd94aa6b..fe94fac33e 100644 --- a/src/cmfd_input.F90 +++ b/src/cmfd_input.F90 @@ -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 diff --git a/src/cmfd_loss_operator.F90 b/src/cmfd_loss_operator.F90 index 7dfeed1dbd..50a75e52d5 100644 --- a/src/cmfd_loss_operator.F90 +++ b/src/cmfd_loss_operator.F90 @@ -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 diff --git a/src/cmfd_prod_operator.F90 b/src/cmfd_prod_operator.F90 index 7779c24551..91ce43b359 100644 --- a/src/cmfd_prod_operator.F90 +++ b/src/cmfd_prod_operator.F90 @@ -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 diff --git a/src/cmfd_solver.F90 b/src/cmfd_solver.F90 index fb687d10b4..99d482480a 100644 --- a/src/cmfd_solver.F90 +++ b/src/cmfd_solver.F90 @@ -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 diff --git a/src/cross_section.F90 b/src/cross_section.F90 index 83cb4ea257..0bdadd87ee 100644 --- a/src/cross_section.F90 +++ b/src/cross_section.F90 @@ -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 diff --git a/src/distribution_multivariate.F90 b/src/distribution_multivariate.F90 index 68b246df84..650ab26fa2 100644 --- a/src/distribution_multivariate.F90 +++ b/src/distribution_multivariate.F90 @@ -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) diff --git a/src/eigenvalue.F90 b/src/eigenvalue.F90 index accf80b310..5f99d1580a 100644 --- a/src/eigenvalue.F90 +++ b/src/eigenvalue.F90 @@ -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 diff --git a/src/error.F90 b/src/error.F90 index 1bb6b5257b..92902a04cb 100644 --- a/src/error.F90 +++ b/src/error.F90 @@ -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. diff --git a/src/geometry.F90 b/src/geometry.F90 index 7f75a817f6..3a325dfd92 100644 --- a/src/geometry.F90 +++ b/src/geometry.F90 @@ -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 diff --git a/src/geometry_header.F90 b/src/geometry_header.F90 index 0d3ae26401..b6499f8221 100644 --- a/src/geometry_header.F90 +++ b/src/geometry_header.F90 @@ -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 diff --git a/src/global.F90 b/src/global.F90 deleted file mode 100644 index 8343b49ac4..0000000000 --- a/src/global.F90 +++ /dev/null @@ -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 diff --git a/src/initialize.F90 b/src/initialize.F90 index 1e29c638c8..1720f2adf9 100644 --- a/src/initialize.F90 +++ b/src/initialize.F90 @@ -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 diff --git a/src/input_xml.F90 b/src/input_xml.F90 index efdc3e5230..545c7e3510 100644 --- a/src/input_xml.F90 +++ b/src/input_xml.F90 @@ -1,35 +1,48 @@ module input_xml + use, intrinsic :: ISO_C_BINDING + use algorithm, only: find use cmfd_input, only: configure_cmfd + use cmfd_header, only: cmfd_mesh use constants use dict_header, only: DictIntInt, DictCharInt, ElemKeyValueCI use distribution_multivariate use distribution_univariate use endf, only: reaction_name use error, only: fatal_error, warning - use geometry_header, only: Cell, Lattice, RectLattice, HexLattice, & - get_temperatures, root_universe - use global + use geometry, only: calc_offsets, maximum_levels, count_instance, & + neighbor_lists + use geometry_header use hdf5_interface use list_header, only: ListChar, ListInt, ListReal - use mesh_header, only: RegularMesh + use material_header + use mesh_header use message_passing use mgxs_data, only: create_macro_xs, read_mgxs + use mgxs_header use multipole, only: multipole_read - use output, only: write_message, title, header + use nuclide_header + use output, only: write_message, title, header, print_plot use plot_header - use random_lcg, only: prn, seed + use random_lcg, only: prn, seed, initialize_prng use surface_header use set_header, only: SetChar + use settings + use source_header use stl_vector, only: VectorInt, VectorReal, VectorChar use string, only: to_lower, to_str, str_to_int, str_to_real, & starts_with, ends_with, tokenize, split_string, & - zero_padded - use tally_header, only: TallyObject - use tally_filter_header, only: TallyFilterContainer + zero_padded, to_c_string + use summary, only: write_summary + use tally + use tally_header, only: openmc_extend_tallies + use tally_derivative_header + use tally_filter_header use tally_filter - use tally_initialize, only: add_tallies + use timer_header, only: time_read_xs + use trigger_header + use volume_header use xml_interface implicit none @@ -44,25 +57,87 @@ contains subroutine read_input_xml() - call read_settings_xml() - call read_geometry_xml() - call read_materials() - call read_tallies_xml() - if (cmfd_run) call configure_cmfd() + type(VectorReal), allocatable :: nuc_temps(:) ! List of T to read for each nuclide + type(VectorReal), allocatable :: sab_temps(:) ! List of T to read for each S(a,b) + real(8), allocatable :: material_temps(:) - if (.not. run_CE) then - ! Create material macroscopic data for MGXS + call read_settings_xml() + call read_cross_sections_xml() + call read_materials_xml(material_temps) + call read_geometry_xml() + + ! Set up neighbor lists, convert user IDs -> indices, assign temperatures + call finalize_geometry(material_temps, nuc_temps, sab_temps) + + if (run_mode /= MODE_PLOTTING) then call time_read_xs % start() - call read_mgxs() - call create_macro_xs() + if (run_CE) then + ! Read continuous-energy cross sections + call read_ce_cross_sections(nuc_temps, sab_temps) + else + ! Create material macroscopic data for MGXS + call read_mgxs() + call create_macro_xs() + end if call time_read_xs % stop() end if - ! Normalize atom/weight percents - if (run_mode /= MODE_PLOTTING) call normalize_ao() + call read_tallies_xml() + + ! Initialize distribcell_filters + call prepare_distribcell() + + if (cmfd_run) call configure_cmfd() + + if (run_mode == MODE_PLOTTING) then + ! Read plots.xml if it exists + call read_plots_xml() + if (master .and. verbosity >= 5) call print_plot() + + else + ! Normalize atom/weight percents + call normalize_ao() + + ! Write summary information + if (master .and. output_summary) call write_summary() + + ! Warn if overlap checking is on + if (master .and. check_overlaps) & + call warning("Cell overlap checking is ON.") + end if end subroutine read_input_xml + subroutine finalize_geometry(material_temps, nuc_temps, sab_temps) + real(8), intent(in) :: material_temps(:) + type(VectorReal), allocatable, intent(out) :: nuc_temps(:) + type(VectorReal), optional, allocatable, intent(out) :: sab_temps(:) + + ! Perform some final operations to set up the geometry + call adjust_indices() + call count_instance(universes(root_universe)) + + ! After reading input and basic geometry setup is complete, build lists of + ! neighboring cells for efficient tracking + call neighbor_lists() + + ! Assign temperatures to cells that don't have temperatures already assigned + call assign_temperatures(material_temps) + + ! Determine desired txemperatures for each nuclide and S(a,b) table + call get_temperatures(nuc_temps, sab_temps) + + ! 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 + + end subroutine finalize_geometry + !=============================================================================== ! READ_SETTINGS_XML reads data from a settings.xml file and parses it, checking ! for errors and placing properly-formatted data in the right data structures @@ -75,8 +150,9 @@ contains integer :: n integer :: temp_int integer :: temp_int_array3(3) + integer(C_INT32_T) :: i_start, i_end + integer(C_INT) :: err integer, allocatable :: temp_int_array(:) - real(8), allocatable :: temp_real(:) integer :: n_tracks logical :: file_exists character(MAX_WORD_LEN) :: type @@ -84,10 +160,6 @@ contains type(XMLDocument) :: doc type(XMLNode) :: root type(XMLNode) :: node_mode - type(XMLNode) :: node_source - type(XMLNode) :: node_space - type(XMLNode) :: node_angle - type(XMLNode) :: node_dist type(XMLNode) :: node_cutoff type(XMLNode) :: node_entropy type(XMLNode) :: node_ufs @@ -97,6 +169,7 @@ contains type(XMLNode) :: node_trigger type(XMLNode) :: node_vol type(XMLNode) :: node_tab_leg + type(XMLNode), allocatable :: node_mesh_list(:) type(XMLNode), allocatable :: node_source_list(:) type(XMLNode), allocatable :: node_vol_list(:) @@ -255,7 +328,7 @@ contains call get_run_parameters(node_mode) ! Check number of active batches, inactive batches, and particles - if (n_active <= 0) then + if (n_batches <= n_inactive) then call fatal_error("Number of active batches must be greater than zero.") elseif (n_inactive < 0) then call fatal_error("Number of inactive batches must be non-negative.") @@ -265,7 +338,10 @@ contains end if ! Copy random number seed if specified - if (check_for_node(root, "seed")) call get_node_value(root, "seed", seed) + if (check_for_node(root, "seed")) then + call get_node_value(root, "seed", seed) + call initialize_prng() + end if ! Number of bins for logarithmic grid if (check_for_node(root, "log_grid_bins")) then @@ -325,241 +401,14 @@ contains allocate(external_source(n)) end if + ! Check if we want to write out source + if (check_for_node(root, "write_initial_source")) then + call get_node_value(root, "write_initial_source", write_initial_source) + end if + ! Read each source do i = 1, n - ! Get pointer to source - node_source = node_source_list(i) - - ! Check if we want to write out source - if (check_for_node(node_source, "write_initial")) then - call get_node_value(node_source, "write_initial", write_initial_source) - end if - - ! Check for source strength - if (check_for_node(node_source, "strength")) then - call get_node_value(node_source, "strength", external_source(i)%strength) - else - external_source(i)%strength = ONE - end if - - ! Check for external source file - if (check_for_node(node_source, "file")) then - ! Copy path of source file - call get_node_value(node_source, "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_source, "space")) then - - ! Get pointer to spatial distribution - node_space = node_source % 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 :: external_source(i)%space) - - case ('box') - allocate(SpatialBox :: external_source(i)%space) - - case ('fission') - allocate(SpatialBox :: external_source(i)%space) - select type(space => external_source(i)%space) - type is (SpatialBox) - space%only_fissionable = .true. - end select - - case ('point') - allocate(SpatialPoint :: external_source(i)%space) - - case default - call fatal_error("Invalid spatial distribution for external source: "& - // trim(type)) - end select - - select type (space => external_source(i)%space) - type is (CartesianIndependent) - ! Read distribution for x coordinate - if (check_for_node(node_space, "x")) then - node_dist = node_space % child("x") - call distribution_from_xml(space%x, node_dist) - else - allocate(Discrete :: space%x) - select type (dist => space%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_space, "y")) then - node_dist = node_space % child("y") - call distribution_from_xml(space%y, node_dist) - else - allocate(Discrete :: space%y) - select type (dist => space%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_space, "z")) then - node_dist = node_space % child("z") - call distribution_from_xml(space%z, node_dist) - else - allocate(Discrete :: space%z) - select type (dist => space%z) - type is (Discrete) - allocate(dist%x(1), dist%p(1)) - dist%x(1) = ZERO - dist%p(1) = ONE - end select - end if - - type is (SpatialBox) - ! Make sure correct number of parameters are given - if (node_word_count(node_space, "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_space, "parameters", temp_real) - space%lower_left(:) = temp_real(1:3) - space%upper_right(:) = temp_real(4:6) - deallocate(temp_real) - - type is (SpatialPoint) - ! Make sure correct number of parameters are given - if (node_word_count(node_space, "parameters") /= 3) then - call fatal_error('Point spatial source must have & - &three parameters specified.') - end if - - ! Read location of point source - allocate(temp_real(3)) - call get_node_array(node_space, "parameters", temp_real) - space%xyz(:) = temp_real - deallocate(temp_real) - - end select - - else - ! If no spatial distribution specified, make it a point source - allocate(SpatialPoint :: external_source(i) % space) - select type (space => external_source(i) % space) - type is (SpatialPoint) - space % xyz(:) = [ZERO, ZERO, ZERO] - end select - end if - - ! Determine external source angular distribution - if (check_for_node(node_source, "angle")) then - - ! Get pointer to angular distribution - node_angle = node_source % 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 :: external_source(i)%angle) - - case ('monodirectional') - allocate(Monodirectional :: external_source(i)%angle) - - case ('mu-phi') - allocate(PolarAzimuthal :: external_source(i)%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", & - external_source(i)%angle%reference_uvw) - else - ! By default, set reference unit vector to be positive z-direction - external_source(i)%angle%reference_uvw(:) = [ZERO, ZERO, ONE] - end if - - ! Read parameters for angle distribution - select type (angle => external_source(i)%angle) - type is (Monodirectional) - call get_node_array(node_angle, "reference_uvw", & - external_source(i)%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 :: external_source(i)%angle) - external_source(i)%angle%reference_uvw(:) = [ZERO, ZERO, ONE] - end if - - ! Determine external source energy distribution - if (check_for_node(node_source, "energy")) then - node_dist = node_source % child("energy") - call distribution_from_xml(external_source(i)%energy, node_dist) - else - ! Default to a Watt spectrum with parameters 0.988 MeV and 2.249 MeV^-1 - allocate(Watt :: external_source(i)%energy) - select type(energy => external_source(i)%energy) - type is (Watt) - energy%a = 0.988e6_8 - energy%b = 2.249e-6_8 - end select - end if - end if + call external_source(i) % from_xml(node_source_list(i), path_source) end do ! Survival biasing @@ -613,121 +462,108 @@ contains track_identifiers = reshape(temp_int_array, [3, n_tracks/3]) end if + ! Read meshes + call get_node_list(root, "mesh", node_mesh_list) + + ! Check for user meshes and allocate + n = size(node_mesh_list) + if (n > 0) then + err = openmc_extend_meshes(n, i_start, i_end) + end if + + do i = 1, n + associate (m => meshes(i_start + i - 1)) + ! Instantiate mesh from XML node + call m % from_xml(node_mesh_list(i)) + + ! Add mesh to dictionary + call mesh_dict % add_key(m % id, i_start + i - 1) + end associate + end do + ! Shannon Entropy mesh - if (check_for_node(root, "entropy")) then + if (check_for_node(root, "entropy_mesh")) then + call get_node_value(root, "entropy_mesh", temp_int) + if (mesh_dict % has_key(temp_int)) then + index_entropy_mesh = mesh_dict % get_key(temp_int) + else + call fatal_error("Mesh " // to_str(temp_int) // " specified for & + &Shannon entropy does not exist.") + end if + elseif (check_for_node(root, "entropy")) then + call warning("Specifying a Shannon entropy mesh via the element & + &is deprecated. Please create a mesh using and then reference & + &it by specifying its ID in an element.") ! Get pointer to entropy node node_entropy = root % child("entropy") - ! Check to make sure enough values were supplied - if (node_word_count(node_entropy, "lower_left") /= 3) then - call fatal_error("Need to specify (x,y,z) coordinates of lower-left & - &corner of Shannon entropy mesh.") - elseif (node_word_count(node_entropy, "upper_right") /= 3) then - call fatal_error("Need to specify (x,y,z) coordinates of upper-right & - &corner of Shannon entropy mesh.") - end if + err = openmc_extend_meshes(1, index_entropy_mesh) - ! Allocate mesh object and coordinates on mesh - allocate(entropy_mesh) - allocate(entropy_mesh % lower_left(3)) - allocate(entropy_mesh % upper_right(3)) - allocate(entropy_mesh % width(3)) + associate (m => meshes(index_entropy_mesh)) + ! Assign ID + m % id = 10000 - ! Copy values - call get_node_array(node_entropy, "lower_left", & - entropy_mesh % lower_left) - call get_node_array(node_entropy, "upper_right", & - entropy_mesh % upper_right) + call m % from_xml(node_entropy) + end associate + end if - ! Check on values provided - if (.not. all(entropy_mesh % upper_right > entropy_mesh % lower_left)) & - &then - call fatal_error("Upper-right coordinate must be greater than & - &lower-left coordinate for Shannon entropy mesh.") - end if + if (index_entropy_mesh > 0) then + associate(m => meshes(index_entropy_mesh)) + 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 + m % n_dimension = 3 + allocate(m % dimension(3)) + m % dimension = ceiling((n_particles/20)**(ONE/THREE)) - ! Check if dimensions were specified -- if not, they will be calculated - ! automatically upon first entry into shannon_entropy - if (check_for_node(node_entropy, "dimension")) then - - ! If so, make sure proper number of values were given - if (node_word_count(node_entropy, "dimension") /= 3) then - call fatal_error("Dimension of entropy mesh must be given as three & - &integers.") + ! Calculate width + m % width = (m % upper_right - m % lower_left) / m % dimension end if - ! Allocate dimensions - entropy_mesh % n_dimension = 3 - allocate(entropy_mesh % dimension(3)) - - ! Copy dimensions - call get_node_array(node_entropy, "dimension", entropy_mesh % dimension) - - ! Calculate width - entropy_mesh % width = (entropy_mesh % upper_right - & - entropy_mesh % lower_left) / entropy_mesh % dimension - - end if + ! Allocate space for storing number of fission sites in each mesh cell + allocate(entropy_p(1, product(m % dimension))) + end associate ! Turn on Shannon entropy calculation entropy_on = .true. end if ! Uniform fission source weighting mesh - if (check_for_node(root, "uniform_fs")) then + if (check_for_node(root, "ufs_mesh")) then + call get_node_value(root, "ufs_mesh", temp_int) + if (mesh_dict % has_key(temp_int)) then + index_ufs_mesh = mesh_dict % get_key(temp_int) + else + call fatal_error("Mesh " // to_str(temp_int) // " specified for & + &uniform fission site method does not exist.") + end if + elseif (check_for_node(root, "uniform_fs")) then + call warning("Specifying a UFS mesh via the element & + &is deprecated. Please create a mesh using and then reference & + &it by specifying its ID in a element.") ! Get pointer to ufs node node_ufs = root % child("uniform_fs") - ! Check to make sure enough values were supplied - if (node_word_count(node_ufs, "lower_left") /= 3) then - call fatal_error("Need to specify (x,y,z) coordinates of lower-left & - &corner of UFS mesh.") - elseif (node_word_count(node_ufs, "upper_right") /= 3) then - call fatal_error("Need to specify (x,y,z) coordinates of upper-right & - &corner of UFS mesh.") - elseif (node_word_count(node_ufs, "dimension") /= 3) then - call fatal_error("Dimension of UFS mesh must be given as three & - &integers.") - end if + err = openmc_extend_meshes(1, index_ufs_mesh) ! Allocate mesh object and coordinates on mesh - allocate(ufs_mesh) - allocate(ufs_mesh % lower_left(3)) - allocate(ufs_mesh % upper_right(3)) - allocate(ufs_mesh % width(3)) + associate (m => meshes(index_ufs_mesh)) + ! Assign ID + m % id = 10001 - ! Allocate dimensions - ufs_mesh % n_dimension = 3 - allocate(ufs_mesh % dimension(3)) + call m % from_xml(node_ufs) + end associate + end if - ! Copy dimensions - call get_node_array(node_ufs, "dimension", ufs_mesh % dimension) - - ! Copy values - call get_node_array(node_ufs, "lower_left", ufs_mesh % lower_left) - call get_node_array(node_ufs, "upper_right", ufs_mesh % upper_right) - - ! Check on values provided - if (.not. all(ufs_mesh % upper_right > ufs_mesh % lower_left)) then - call fatal_error("Upper-right coordinate must be greater than & - &lower-left coordinate for UFS mesh.") - end if - - ! Calculate width - ufs_mesh % width = (ufs_mesh % upper_right - & - ufs_mesh % lower_left) / ufs_mesh % dimension - - ! Calculate volume fraction of each cell - ufs_mesh % volume_frac = ONE/real(product(ufs_mesh % dimension),8) + if (index_ufs_mesh > 0) then + ! Allocate array to store source fraction for UFS + allocate(source_frac(1, product(meshes(index_ufs_mesh) % dimension))) ! Turn on uniform fission source weighting ufs = .true. - - ! Allocate source_frac - allocate(source_frac(1, ufs_mesh % dimension(1), & - ufs_mesh % dimension(2), ufs_mesh % dimension(3))) end if ! Check if the user has specified to write state points @@ -1061,9 +897,6 @@ contains end if end if - ! Determine number of active batches - n_active = n_batches - n_inactive - end subroutine get_run_parameters !=============================================================================== @@ -1075,6 +908,7 @@ contains integer :: i, j, k, m, i_x, i_a, input_index integer :: n, n_mats, n_x, n_y, n_z, n_rings, n_rlats, n_hlats + integer :: id integer :: univ_id integer :: n_cells_in_univ integer :: coeffs_reqd @@ -1108,13 +942,9 @@ contains type(DictIntInt) :: cells_in_univ_dict ! Used to count how many cells each ! universe contains - ! Display output message call write_message("Reading geometry XML file...", 5) - ! ========================================================================== - ! READ CELLS FROM GEOMETRY.XML - ! Check if geometry.xml exists filename = trim(path_input) // "geometry.xml" inquire(FILE=filename, EXIST=file_exists) @@ -1127,265 +957,6 @@ contains call doc % load_file(filename) root = doc % document_element() - ! Get pointer to list of XML - call get_node_list(root, "cell", node_cell_list) - - ! Get number of tags - n_cells = size(node_cell_list) - - ! Check for no cells - if (n_cells == 0) then - call fatal_error("No cells found in geometry.xml!") - end if - - ! Allocate cells array - allocate(cells(n_cells)) - - if (check_overlaps) then - allocate(overlap_check_cnt(n_cells)) - overlap_check_cnt = 0 - end if - - n_universes = 0 - do i = 1, n_cells - c => cells(i) - - ! Initialize distribcell instances and distribcell index - c % instances = 0 - c % distribcell_index = NONE - - ! Get pointer to i-th cell node - node_cell = node_cell_list(i) - - ! Copy data into cells - if (check_for_node(node_cell, "id")) then - call get_node_value(node_cell, "id", c % id) - else - call fatal_error("Must specify id of cell in geometry XML file.") - end if - - ! Copy cell name - if (check_for_node(node_cell, "name")) then - call get_node_value(node_cell, "name", c % name) - end if - - if (check_for_node(node_cell, "universe")) then - call get_node_value(node_cell, "universe", c % universe) - else - c % universe = 0 - end if - if (check_for_node(node_cell, "fill")) then - call get_node_value(node_cell, "fill", c % fill) - if (find(fill_univ_ids, c % fill) == -1) & - call fill_univ_ids % push_back(c % fill) - else - c % fill = NONE - end if - - ! Check to make sure 'id' hasn't been used - if (cell_dict % has_key(c % id)) then - call fatal_error("Two or more cells use the same unique ID: " & - // to_str(c % id)) - end if - - ! Read material - if (check_for_node(node_cell, "material")) then - n_mats = node_word_count(node_cell, "material") - - if (n_mats > 0) then - allocate(sarray(n_mats)) - call get_node_array(node_cell, "material", sarray) - - allocate(c % material(n_mats)) - do j = 1, n_mats - select case(trim(to_lower(sarray(j)))) - case ('void') - c % material(j) = MATERIAL_VOID - case default - c % material(j) = int(str_to_int(sarray(j)), 4) - - ! Check for error - if (c % material(j) == ERROR_INT) then - call fatal_error("Invalid material specified on cell " & - // to_str(c % id)) - end if - end select - end do - - deallocate(sarray) - - else - allocate(c % material(1)) - c % material(1) = NONE - end if - - else - allocate(c % material(1)) - c % material(1) = NONE - end if - - ! Check to make sure that either material or fill was specified - if (c % material(1) == NONE .and. c % fill == NONE) then - call fatal_error("Neither material nor fill was specified for cell " & - // trim(to_str(c % id))) - end if - - ! Check to make sure that both material and fill haven't been - ! specified simultaneously - if (c % material(1) /= NONE .and. c % fill /= NONE) then - call fatal_error("Cannot specify material and fill simultaneously") - end if - - ! Check for region specification (also under deprecated name surfaces) - if (check_for_node(node_cell, "surfaces")) then - call warning("The use of 'surfaces' is deprecated and will be & - &disallowed in a future release. Use 'region' instead. The & - &openmc-update-inputs utility can be used to automatically & - &update geometry.xml files.") - region_spec = node_value_string(node_cell, "surfaces") - call get_node_value(node_cell, "surfaces", region_spec) - elseif (check_for_node(node_cell, "region")) then - region_spec = node_value_string(node_cell, "region") - else - region_spec = '' - end if - - if (len_trim(region_spec) > 0) then - ! Create surfaces array from string - call tokenize(region_spec, tokens) - - ! Use shunting-yard algorithm to determine RPN for surface algorithm - call generate_rpn(c%id, tokens, rpn) - - ! Copy region spec and RPN form to cell arrays - allocate(c % region(tokens%size())) - allocate(c % rpn(rpn%size())) - c % region(:) = tokens%data(1:tokens%size()) - c % rpn(:) = rpn%data(1:rpn%size()) - - call tokens%clear() - call rpn%clear() - end if - if (.not. allocated(c%region)) allocate(c%region(0)) - if (.not. allocated(c%rpn)) allocate(c%rpn(0)) - - ! Check if this is a simple cell - if (any(c%rpn == OP_COMPLEMENT) .or. any(c%rpn == OP_UNION)) then - c%simple = .false. - else - c%simple = .true. - end if - - ! Rotation matrix - if (check_for_node(node_cell, "rotation")) then - ! Rotations can only be applied to cells that are being filled with - ! another universe - if (c % fill == NONE) then - call fatal_error("Cannot apply a rotation to cell " // trim(to_str(& - &c % id)) // " because it is not filled with another universe") - end if - - ! Read number of rotation parameters - n = node_word_count(node_cell, "rotation") - if (n /= 3) then - call fatal_error("Incorrect number of rotation parameters on cell " & - // to_str(c % id)) - end if - - ! Copy rotation angles in x,y,z directions - allocate(c % rotation(3)) - call get_node_array(node_cell, "rotation", c % rotation) - phi = -c % rotation(1) * PI/180.0_8 - theta = -c % rotation(2) * PI/180.0_8 - psi = -c % rotation(3) * PI/180.0_8 - - ! Calculate rotation matrix based on angles given - allocate(c % rotation_matrix(3,3)) - c % rotation_matrix = reshape((/ & - cos(theta)*cos(psi), cos(theta)*sin(psi), -sin(theta), & - -cos(phi)*sin(psi) + sin(phi)*sin(theta)*cos(psi), & - cos(phi)*cos(psi) + sin(phi)*sin(theta)*sin(psi), & - sin(phi)*cos(theta), & - sin(phi)*sin(psi) + cos(phi)*sin(theta)*cos(psi), & - -sin(phi)*cos(psi) + cos(phi)*sin(theta)*sin(psi), & - cos(phi)*cos(theta) /), (/ 3,3 /)) - end if - - ! Translation vector - if (check_for_node(node_cell, "translation")) then - ! Translations can only be applied to cells that are being filled with - ! another universe - if (c % fill == NONE) then - call fatal_error("Cannot apply a translation to cell " & - // trim(to_str(c % id)) // " because it is not filled with & - &another universe") - end if - - ! Read number of translation parameters - n = node_word_count(node_cell, "translation") - if (n /= 3) then - call fatal_error("Incorrect number of translation parameters on & - &cell " // to_str(c % id)) - end if - - ! Copy translation vector - allocate(c % translation(3)) - call get_node_array(node_cell, "translation", c % translation) - end if - - ! Read cell temperatures. If the temperature is not specified, set it to - ! ERROR_REAL for now. During initialization we'll replace ERROR_REAL with - ! the temperature from the material data. - if (check_for_node(node_cell, "temperature")) then - n = node_word_count(node_cell, "temperature") - if (n > 0) then - ! Make sure this is a "normal" cell. - if (c % material(1) == NONE) call fatal_error("Cell " & - // trim(to_str(c % id)) // " was specified with a temperature & - &but no material. Temperature specification is only valid for & - &cells filled with a material.") - - ! Copy in temperatures - allocate(c % sqrtkT(n)) - call get_node_array(node_cell, "temperature", c % sqrtkT) - - ! Make sure all temperatues are positive - do j = 1, size(c % sqrtkT) - if (c % sqrtkT(j) < ZERO) call fatal_error("Cell " & - // trim(to_str(c % id)) // " was specified with a negative & - &temperature. All cell temperatures must be non-negative.") - end do - - ! Convert to sqrt(kT) - c % sqrtkT(:) = sqrt(K_BOLTZMANN * c % sqrtkT(:)) - else - allocate(c % sqrtkT(1)) - c % sqrtkT(1) = ERROR_REAL - end if - else - allocate(c % sqrtkT(1)) - c % sqrtkT = ERROR_REAL - end if - - ! Add cell to dictionary - call cell_dict % add_key(c % id, i) - - ! For cells, we also need to check if there's a new universe -- - ! also for every cell add 1 to the count of cells for the - ! specified universe - univ_id = c % universe - if (.not. cells_in_univ_dict % has_key(univ_id)) then - n_universes = n_universes + 1 - n_cells_in_univ = 1 - call universe_dict % add_key(univ_id, n_universes) - call univ_ids % push_back(univ_id) - else - n_cells_in_univ = 1 + cells_in_univ_dict % get_key(univ_id) - end if - call cells_in_univ_dict % add_key(univ_id, n_cells_in_univ) - - end do - ! ========================================================================== ! READ SURFACES FROM GEOMETRY.XML @@ -1685,6 +1256,279 @@ contains end if end do + ! ========================================================================== + ! READ CELLS FROM GEOMETRY.XML + + ! Get pointer to list of XML + call get_node_list(root, "cell", node_cell_list) + + ! Get number of tags + n_cells = size(node_cell_list) + + ! Check for no cells + if (n_cells == 0) then + call fatal_error("No cells found in geometry.xml!") + end if + + ! Allocate cells array + allocate(cells(n_cells)) + + if (check_overlaps) then + allocate(overlap_check_cnt(n_cells)) + overlap_check_cnt = 0 + end if + + n_universes = 0 + do i = 1, n_cells + c => cells(i) + + ! Initialize distribcell instances and distribcell index + c % instances = 0 + c % distribcell_index = NONE + + ! Get pointer to i-th cell node + node_cell = node_cell_list(i) + + ! Copy data into cells + if (check_for_node(node_cell, "id")) then + call get_node_value(node_cell, "id", c % id) + else + call fatal_error("Must specify id of cell in geometry XML file.") + end if + + ! Copy cell name + if (check_for_node(node_cell, "name")) then + call get_node_value(node_cell, "name", c % name) + end if + + if (check_for_node(node_cell, "universe")) then + call get_node_value(node_cell, "universe", c % universe) + else + c % universe = 0 + end if + if (check_for_node(node_cell, "fill")) then + call get_node_value(node_cell, "fill", c % fill) + if (find(fill_univ_ids, c % fill) == -1) & + call fill_univ_ids % push_back(c % fill) + else + c % fill = NONE + end if + + ! Check to make sure 'id' hasn't been used + if (cell_dict % has_key(c % id)) then + call fatal_error("Two or more cells use the same unique ID: " & + // to_str(c % id)) + end if + + ! Read material + if (check_for_node(node_cell, "material")) then + n_mats = node_word_count(node_cell, "material") + + if (n_mats > 0) then + allocate(sarray(n_mats)) + call get_node_array(node_cell, "material", sarray) + + allocate(c % material(n_mats)) + do j = 1, n_mats + select case(trim(to_lower(sarray(j)))) + case ('void') + c % material(j) = MATERIAL_VOID + case default + c % material(j) = int(str_to_int(sarray(j)), 4) + + ! Check for error + if (c % material(j) == ERROR_INT) then + call fatal_error("Invalid material specified on cell " & + // to_str(c % id)) + end if + end select + end do + + deallocate(sarray) + + else + allocate(c % material(1)) + c % material(1) = NONE + end if + + else + allocate(c % material(1)) + c % material(1) = NONE + end if + + ! Check to make sure that either material or fill was specified + if (c % material(1) == NONE .and. c % fill == NONE) then + call fatal_error("Neither material nor fill was specified for cell " & + // trim(to_str(c % id))) + end if + + ! Check to make sure that both material and fill haven't been + ! specified simultaneously + if (c % material(1) /= NONE .and. c % fill /= NONE) then + call fatal_error("Cannot specify material and fill simultaneously") + end if + + ! Check for region specification (also under deprecated name surfaces) + if (check_for_node(node_cell, "surfaces")) then + call warning("The use of 'surfaces' is deprecated and will be & + &disallowed in a future release. Use 'region' instead. The & + &openmc-update-inputs utility can be used to automatically & + &update geometry.xml files.") + region_spec = node_value_string(node_cell, "surfaces") + call get_node_value(node_cell, "surfaces", region_spec) + elseif (check_for_node(node_cell, "region")) then + region_spec = node_value_string(node_cell, "region") + else + region_spec = '' + end if + + if (len_trim(region_spec) > 0) then + ! Create surfaces array from string + call tokenize(region_spec, tokens) + + ! Convert user IDs to surface indices + do j = 1, tokens % size() + id = tokens % data(j) + if (id < OP_UNION) then + if (surface_dict % has_key(abs(id))) then + k = surface_dict % get_key(abs(id)) + tokens % data(j) = sign(k, id) + end if + end if + end do + + ! Use shunting-yard algorithm to determine RPN for surface algorithm + call generate_rpn(c%id, tokens, rpn) + + ! Copy region spec and RPN form to cell arrays + allocate(c % region(tokens%size())) + allocate(c % rpn(rpn%size())) + c % region(:) = tokens%data(1:tokens%size()) + c % rpn(:) = rpn%data(1:rpn%size()) + + call tokens%clear() + call rpn%clear() + end if + if (.not. allocated(c%region)) allocate(c%region(0)) + if (.not. allocated(c%rpn)) allocate(c%rpn(0)) + + ! Check if this is a simple cell + if (any(c%rpn == OP_COMPLEMENT) .or. any(c%rpn == OP_UNION)) then + c%simple = .false. + else + c%simple = .true. + end if + + ! Rotation matrix + if (check_for_node(node_cell, "rotation")) then + ! Rotations can only be applied to cells that are being filled with + ! another universe + if (c % fill == NONE) then + call fatal_error("Cannot apply a rotation to cell " // trim(to_str(& + &c % id)) // " because it is not filled with another universe") + end if + + ! Read number of rotation parameters + n = node_word_count(node_cell, "rotation") + if (n /= 3) then + call fatal_error("Incorrect number of rotation parameters on cell " & + // to_str(c % id)) + end if + + ! Copy rotation angles in x,y,z directions + allocate(c % rotation(3)) + call get_node_array(node_cell, "rotation", c % rotation) + phi = -c % rotation(1) * PI/180.0_8 + theta = -c % rotation(2) * PI/180.0_8 + psi = -c % rotation(3) * PI/180.0_8 + + ! Calculate rotation matrix based on angles given + allocate(c % rotation_matrix(3,3)) + c % rotation_matrix = reshape((/ & + cos(theta)*cos(psi), cos(theta)*sin(psi), -sin(theta), & + -cos(phi)*sin(psi) + sin(phi)*sin(theta)*cos(psi), & + cos(phi)*cos(psi) + sin(phi)*sin(theta)*sin(psi), & + sin(phi)*cos(theta), & + sin(phi)*sin(psi) + cos(phi)*sin(theta)*cos(psi), & + -sin(phi)*cos(psi) + cos(phi)*sin(theta)*sin(psi), & + cos(phi)*cos(theta) /), (/ 3,3 /)) + end if + + ! Translation vector + if (check_for_node(node_cell, "translation")) then + ! Translations can only be applied to cells that are being filled with + ! another universe + if (c % fill == NONE) then + call fatal_error("Cannot apply a translation to cell " & + // trim(to_str(c % id)) // " because it is not filled with & + &another universe") + end if + + ! Read number of translation parameters + n = node_word_count(node_cell, "translation") + if (n /= 3) then + call fatal_error("Incorrect number of translation parameters on & + &cell " // to_str(c % id)) + end if + + ! Copy translation vector + allocate(c % translation(3)) + call get_node_array(node_cell, "translation", c % translation) + end if + + ! Read cell temperatures. If the temperature is not specified, set it to + ! ERROR_REAL for now. During initialization we'll replace ERROR_REAL with + ! the temperature from the material data. + if (check_for_node(node_cell, "temperature")) then + n = node_word_count(node_cell, "temperature") + if (n > 0) then + ! Make sure this is a "normal" cell. + if (c % material(1) == NONE) call fatal_error("Cell " & + // trim(to_str(c % id)) // " was specified with a temperature & + &but no material. Temperature specification is only valid for & + &cells filled with a material.") + + ! Copy in temperatures + allocate(c % sqrtkT(n)) + call get_node_array(node_cell, "temperature", c % sqrtkT) + + ! Make sure all temperatues are positive + do j = 1, size(c % sqrtkT) + if (c % sqrtkT(j) < ZERO) call fatal_error("Cell " & + // trim(to_str(c % id)) // " was specified with a negative & + &temperature. All cell temperatures must be non-negative.") + end do + + ! Convert to sqrt(kT) + c % sqrtkT(:) = sqrt(K_BOLTZMANN * c % sqrtkT(:)) + else + allocate(c % sqrtkT(1)) + c % sqrtkT(1) = ERROR_REAL + end if + else + allocate(c % sqrtkT(1)) + c % sqrtkT = ERROR_REAL + end if + + ! Add cell to dictionary + call cell_dict % add_key(c % id, i) + + ! For cells, we also need to check if there's a new universe -- + ! also for every cell add 1 to the count of cells for the + ! specified universe + univ_id = c % universe + if (.not. cells_in_univ_dict % has_key(univ_id)) then + n_universes = n_universes + 1 + n_cells_in_univ = 1 + call universe_dict % add_key(univ_id, n_universes) + call univ_ids % push_back(univ_id) + else + n_cells_in_univ = 1 + cells_in_univ_dict % get_key(univ_id) + end if + call cells_in_univ_dict % add_key(univ_id, n_cells_in_univ) + + end do + ! ========================================================================== ! READ LATTICES FROM GEOMETRY.XML @@ -2068,11 +1912,8 @@ contains ! for errors and placing properly-formatted data in the right data structures !=============================================================================== - subroutine read_materials() + subroutine read_cross_sections_xml() integer :: i, j - type(VectorReal), allocatable :: nuc_temps(:) ! List of T to read for each nuclide - type(VectorReal), allocatable :: sab_temps(:) ! List of T to read for each S(a,b) - real(8), allocatable :: material_temps(:) logical :: file_exists character(MAX_FILE_LEN) :: env_variable character(MAX_LINE_LEN) :: filename @@ -2180,24 +2021,7 @@ contains end do end if - ! Parse data from materials.xml - call read_materials_xml(material_temps) - - ! Assign temperatures to cells that don't have temperatures already assigned - call assign_temperatures(material_temps) - - ! Determine desired temperatures for each nuclide and S(a,b) table - call get_temperatures(cells, materials, material_dict, nuclide_dict, & - n_nuclides_total, nuc_temps, sab_dict, & - n_sab_tables, sab_temps) - - ! Read continuous-energy cross sections - if (run_CE .and. run_mode /= MODE_PLOTTING) then - call time_read_xs % start() - call read_ce_cross_sections(nuc_temps, sab_temps) - call time_read_xs % stop() - end if - end subroutine read_materials + end subroutine read_cross_sections_xml subroutine read_materials_xml(material_temps) real(8), allocatable, intent(out) :: material_temps(:) @@ -2617,8 +2441,8 @@ contains end do ! Set total number of nuclides and S(a,b) tables - n_nuclides_total = index_nuclide - n_sab_tables = index_sab + n_nuclides = index_nuclide + n_sab_tables = index_sab ! Close materials XML file call doc % clear() @@ -2632,14 +2456,11 @@ contains subroutine read_tallies_xml() - integer :: d ! delayed group index integer :: i ! loop over user-specified tallies integer :: j ! loop over words integer :: k ! another loop index integer :: l ! another loop index - integer :: id ! user-specified identifier integer :: filter_id ! user-specified identifier for filter - integer :: i_mesh ! index in meshes array integer :: i_filt ! index in filters array integer :: i_filter_mesh ! index of mesh filter integer :: n ! size of arrays in mesh specification @@ -2651,17 +2472,15 @@ contains integer :: n_user_trig ! number of user-specified tally triggers integer :: trig_ind ! index of triggers array for each tally integer :: user_trig_ind ! index of user-specified triggers for each tally + integer :: i_start, i_end + integer :: i_filt_start, i_filt_end + integer(C_INT) :: err real(8) :: threshold ! trigger convergence threshold integer :: n_order ! moment order requested integer :: n_order_pos ! oosition of Scattering order in score name string integer :: MT ! user-specified MT for score - integer :: iarray3(3) ! temporary integer array integer :: imomstr ! Index of MOMENT_STRS & MOMENT_N_STRS logical :: file_exists ! does tallies.xml file exist? - real(8) :: rarray3(3) ! temporary double prec. array - integer :: Nangle ! Number of angular bins - real(8) :: dangle ! Mu spacing if using automatic allocation - integer :: iangle ! Loop counter for building mu filter bins integer, allocatable :: temp_filter(:) ! temporary filter indices character(MAX_LINE_LEN) :: filename character(MAX_WORD_LEN) :: word @@ -2669,17 +2488,13 @@ contains character(MAX_WORD_LEN) :: temp_str character(MAX_WORD_LEN), allocatable :: sarray(:) type(DictCharInt) :: trigger_scores - type(ElemKeyValueCI), pointer :: pair_list - type(TallyObject), pointer :: t type(TallyFilterContainer), pointer :: f type(RegularMesh), pointer :: m type(XMLDocument) :: doc type(XMLNode) :: root - type(XMLNode) :: node_mesh type(XMLNode) :: node_tal type(XMLNode) :: node_filt type(XMLNode) :: node_trigger - type(XMLNode) :: node_deriv type(XMLNode), allocatable :: node_mesh_list(:) type(XMLNode), allocatable :: node_tal_list(:) type(XMLNode), allocatable :: node_filt_list(:) @@ -2721,34 +2536,6 @@ contains ! Get pointer list to XML call get_node_list(root, "tally", node_tal_list) - ! Check for user meshes - n_user_meshes = size(node_mesh_list) - if (cmfd_run) then - n_meshes = n_user_meshes + n_cmfd_meshes - else - n_meshes = n_user_meshes - end if - - ! Allocate mesh array - if (n_meshes > 0) allocate(meshes(n_meshes)) - - ! Check for user filters - n_user_filters = size(node_filt_list) - - ! Allocate filters array - if (n_user_filters > 0) call add_filters(n_user_filters) - - ! Check for user tallies - n_user_tallies = size(node_tal_list) - if (n_user_tallies == 0) then - if (master) call warning("No tallies present in tallies.xml file!") - end if - - ! Allocate tally array - if (n_user_tallies > 0 .and. run_mode /= MODE_PLOTTING) then - call add_tallies("user", n_user_tallies) - end if - ! Check for setting if (check_for_node(root, "assume_separate")) then call get_node_value(root, "assume_separate", assume_separate) @@ -2757,131 +2544,27 @@ contains ! ========================================================================== ! READ MESH DATA - do i = 1, n_user_meshes - m => meshes(i) + ! Check for user meshes and allocate + n = size(node_mesh_list) + if (n > 0) then + err = openmc_extend_meshes(n, i_start, i_end) + end if - ! Get pointer to mesh node - node_mesh = node_mesh_list(i) + do i = 1, n + m => meshes(i_start + i - 1) - ! Copy mesh id - if (check_for_node(node_mesh, "id")) then - call get_node_value(node_mesh, "id", m % id) - else - call fatal_error("Must specify id for mesh in tally XML file.") - end if - - ! Check to make sure 'id' hasn't been used - if (mesh_dict % has_key(m % id)) then - call fatal_error("Two or more meshes use the same unique ID: " & - // to_str(m % id)) - end if - - ! Read mesh type - temp_str = '' - if (check_for_node(node_mesh, "type")) & - call get_node_value(node_mesh, "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.") - m % type = MESH_REGULAR - case ('regular') - m % type = MESH_REGULAR - case default - call fatal_error("Invalid mesh type: " // trim(temp_str)) - end select - - ! Determine number of dimensions for mesh - n = node_word_count(node_mesh, "dimension") - if (n /= 1 .and. n /= 2 .and. n /= 3) then - call fatal_error("Mesh must be one, two, or three dimensions.") - end if - m % n_dimension = n - - ! Allocate attribute arrays - allocate(m % dimension(n)) - allocate(m % lower_left(n)) - allocate(m % width(n)) - allocate(m % upper_right(n)) - - ! Check that dimensions are all greater than zero - call get_node_array(node_mesh, "dimension", iarray3(1:n)) - if (any(iarray3(1:n) <= 0)) then - call fatal_error("All entries on the element for a tally & - &mesh must be positive.") - end if - - ! Read dimensions in each direction - m % dimension = iarray3(1:n) - - ! Read mesh lower-left corner location - if (m % n_dimension /= node_word_count(node_mesh, "lower_left")) then - call fatal_error("Number of entries on must be the same & - &as the number of entries on .") - end if - call get_node_array(node_mesh, "lower_left", m % lower_left) - - ! Make sure both upper-right or width were specified - if (check_for_node(node_mesh, "upper_right") .and. & - check_for_node(node_mesh, "width")) then - call fatal_error("Cannot specify both and on a & - &tally mesh.") - end if - - ! Make sure either upper-right or width was specified - if (.not. check_for_node(node_mesh, "upper_right") .and. & - .not. check_for_node(node_mesh, "width")) then - call fatal_error("Must specify either and on a & - &tally mesh.") - end if - - if (check_for_node(node_mesh, "width")) then - ! Check to ensure width has same dimensions - if (node_word_count(node_mesh, "width") /= & - node_word_count(node_mesh, "lower_left")) then - call fatal_error("Number of entries on must be the same as & - &the number of entries on .") - end if - - ! Check for negative widths - call get_node_array(node_mesh, "width", rarray3(1:n)) - if (any(rarray3(1:n) < ZERO)) then - call fatal_error("Cannot have a negative on a tally mesh.") - end if - - ! Set width and upper right coordinate - m % width = rarray3(1:n) - m % upper_right = m % lower_left + m % dimension * m % width - - elseif (check_for_node(node_mesh, "upper_right")) then - ! Check to ensure width has same dimensions - if (node_word_count(node_mesh, "upper_right") /= & - node_word_count(node_mesh, "lower_left")) then - call fatal_error("Number of entries on must be the & - &same as the number of entries on .") - end if - - ! Check that upper-right is above lower-left - call get_node_array(node_mesh, "upper_right", rarray3(1:n)) - if (any(rarray3(1:n) < m % lower_left)) then - call fatal_error("The coordinates must be greater than & - &the coordinates on a tally mesh.") - end if - - ! Set width and upper right coordinate - m % upper_right = rarray3(1:n) - m % width = (m % upper_right - m % lower_left) / m % dimension - end if - - ! Set volume fraction - m % volume_frac = ONE/real(product(m % dimension),8) + ! Instantiate mesh from XML node + call m % from_xml(node_mesh_list(i)) ! Add mesh to dictionary - call mesh_dict % add_key(m % id, i) + call mesh_dict % add_key(m % id, i_start + i - 1) end do ! We only need the mesh info for plotting - if (run_mode == MODE_PLOTTING) return + if (run_mode == MODE_PLOTTING) then + call doc % clear() + return + end if ! ========================================================================== ! READ DATA FOR DERIVATIVES @@ -2900,82 +2583,23 @@ contains ! Read derivative attributes. do i = 1, size(node_deriv_list) - associate(deriv => tally_derivs(i)) - ! Get pointer to derivative node. - node_deriv = node_deriv_list(i) + call tally_derivs(i) % from_xml(node_deriv_list(i)) - ! Copy the derivative id. - if (check_for_node(node_deriv, "id")) then - call get_node_value(node_deriv, "id", deriv % id) - else - call fatal_error("Must specify an ID for elements in the& - & tally XML file") - end if - - ! Make sure the id is > 0. - if (deriv % id <= 0) then - call fatal_error(" IDs must be an integer greater than & - &zero") - end if - - ! Make sure this id has not already been used. - do j = 1, i-1 - if (tally_derivs(j) % id == deriv % id) then - call fatal_error("Two or more 's use the same unique & - &ID: " // trim(to_str(deriv % id))) - end if - end do - - ! Read the independent variable name. - temp_str = "" - call get_node_value(node_deriv, "variable", temp_str) - temp_str = to_lower(temp_str) - - select case(temp_str) - - case("density") - deriv % variable = DIFF_DENSITY - call get_node_value(node_deriv, "material", deriv % diff_material) - - case("nuclide_density") - deriv % variable = DIFF_NUCLIDE_DENSITY - call get_node_value(node_deriv, "material", deriv % diff_material) - - call get_node_value(node_deriv, "nuclide", word) - word = trim(to_lower(word)) - pair_list => nuclide_dict % keys() - do while (associated(pair_list)) - if (starts_with(pair_list % key, word)) then - word = pair_list % key(1:150) - exit - end if - - ! Advance to next - pair_list => pair_list % next - end do - - ! Check if no nuclide was found - if (.not. associated(pair_list)) then - call fatal_error("Could not find the nuclide " & - // trim(word) // " specified in derivative " & - // trim(to_str(deriv % id)) // " in any material.") - end if - deallocate(pair_list) - - deriv % diff_nuclide = nuclide_dict % get_key(word) - - case("temperature") - deriv % variable = DIFF_TEMPERATURE - call get_node_value(node_deriv, "material", deriv % diff_material) - end select - end associate + ! Update tally derivative dictionary + call tally_deriv_dict % add_key(tally_derivs(i) % id, i) end do ! ========================================================================== ! READ FILTER DATA - READ_FILTERS: do i = 1, n_user_filters - f => filters(i) + ! Check for user filters and allocate + n = size(node_filt_list) + if (n > 0) then + err = openmc_extend_filters(n, i_start, i_end) + end if + + READ_FILTERS: do i = 1, n + f => filters(i_start + i - 1) ! Get pointer to filter xml node node_filt = node_filt_list(i) @@ -3005,356 +2629,51 @@ contains if (.not. check_for_node(node_filt, "bins")) then call fatal_error("Bins not set in filter " // trim(to_str(filter_id))) end if - n_words = node_word_count(node_filt, "bins") case ("mesh", "universe", "material", "cell", "distribcell", & "cellborn", "cellfrom", "surface", "delayedgroup") if (.not. check_for_node(node_filt, "bins")) then call fatal_error("Bins not set in filter " // trim(to_str(filter_id))) end if - n_words = node_word_count(node_filt, "bins") end select - ! Determine type of filter - select case (temp_str) + ! Allocate according to the filter type + err = openmc_filter_set_type(i_start + i - 1, to_c_string(temp_str)) - case ('distribcell') - ! Allocate and declare the filter type - allocate(DistribcellFilter :: f % obj) - select type (filt => f % obj) - type is (DistribcellFilter) - if (n_words /= 1) call fatal_error("Only one cell can be & - &specified per distribcell filter.") - ! Store bins - call get_node_value(node_filt, "bins", filt % cell) - end select - - case ('cell') - ! Allocate and declare the filter type - allocate(CellFilter :: f % obj) - select type (filt => f % obj) - type is (CellFilter) - ! Allocate and store bins - filt % n_bins = n_words - allocate(filt % cells(n_words)) - call get_node_array(node_filt, "bins", filt % cells) - end select - - case ('cellfrom') - ! Allocate and declare the filter type - allocate(CellFromFilter :: f % obj) - select type (filt => f % obj) - type is (CellFromFilter) - ! Allocate and store bins - filt % n_bins = n_words - allocate(filt % cells(n_words)) - call get_node_array(node_filt, "bins", filt % cells) - end select - - case ('cellborn') - ! Allocate and declare the filter type - allocate(CellbornFilter :: f % obj) - select type (filt => f % obj) - type is (CellbornFilter) - ! Allocate and store bins - filt % n_bins = n_words - allocate(filt % cells(n_words)) - call get_node_array(node_filt, "bins", filt % cells) - end select - - case ('material') - ! Allocate and declare the filter type - allocate(MaterialFilter :: f % obj) - select type (filt => f % obj) - type is (MaterialFilter) - ! Allocate and store bins - filt % n_bins = n_words - allocate(filt % materials(n_words)) - call get_node_array(node_filt, "bins", filt % materials) - end select - - case ('universe') - ! Allocate and declare the filter type - allocate(UniverseFilter :: f % obj) - select type (filt => f % obj) - type is (UniverseFilter) - ! Allocate and store bins - filt % n_bins = n_words - allocate(filt % universes(n_words)) - call get_node_array(node_filt, "bins", filt % universes) - end select - - case ('surface') - ! Allocate and declare the filter type - allocate(SurfaceFilter :: f % obj) - select type (filt => f % obj) - type is (SurfaceFilter) - ! Allocate and store bins - filt % n_bins = n_words - allocate(filt % surfaces(n_words)) - call get_node_array(node_filt, "bins", filt % surfaces) - end select - - case ('mesh') - ! Allocate and declare the filter type - allocate(MeshFilter :: f % obj) - select type (filt => f % obj) - type is (MeshFilter) - if (n_words /= 1) call fatal_error("Only one mesh can be & - &specified per mesh filter.") - - ! Determine id of mesh - call get_node_value(node_filt, "bins", id) - - ! Get pointer to mesh - if (mesh_dict % has_key(id)) then - i_mesh = mesh_dict % get_key(id) - m => meshes(i_mesh) - else - call fatal_error("Could not find mesh " // trim(to_str(id)) & - // " specified on filter " // trim(to_str(filter_id))) - end if - - ! Determine number of bins - filt % n_bins = product(m % dimension) - - ! Store the index of the mesh - filt % mesh = i_mesh - end select - - case ('energy') - - ! Allocate and declare the filter type - allocate(EnergyFilter :: f % obj) - select type (filt => f % obj) - type is (EnergyFilter) - ! Allocate and store bins - filt % n_bins = n_words - 1 - allocate(filt % bins(n_words)) - call get_node_array(node_filt, "bins", filt % 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_words == num_energy_groups + 1) then - if (all(filt % bins == energy_bins(num_energy_groups + 1:1:-1))) & - then - filt % matches_transport_groups = .true. - end if - end if - end if - end select - - case ('energyout') - ! Allocate and declare the filter type - allocate(EnergyoutFilter :: f % obj) - select type (filt => f % obj) - type is (EnergyoutFilter) - ! Allocate and store bins - filt % n_bins = n_words - 1 - allocate(filt % bins(n_words)) - call get_node_array(node_filt, "bins", filt % 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_words == num_energy_groups + 1) then - if (all(filt % bins == energy_bins(num_energy_groups + 1:1:-1))) & - then - filt % matches_transport_groups = .true. - end if - end if - end if - end select - - case ('delayedgroup') - - ! Allocate and declare the filter type - allocate(DelayedGroupFilter :: f % obj) - select type (filt => f % obj) - type is (DelayedGroupFilter) - ! Allocate and store bins - filt % n_bins = n_words - allocate(filt % groups(n_words)) - call get_node_array(node_filt, "bins", filt % groups) - - ! Check that bins are all are between 1 and MAX_DELAYED_GROUPS - do d = 1, n_words - if (filt % groups(d) < 1 .or. & - filt % groups(d) > MAX_DELAYED_GROUPS) then - call fatal_error("Encountered delayedgroup bin with index " & - // trim(to_str(filt % groups(d))) // " that is outside & - &the range of 1 to MAX_DELAYED_GROUPS ( " & - // trim(to_str(MAX_DELAYED_GROUPS)) // ")") - end if - end do - end select - - case ('mu') - ! Allocate and declare the filter type - allocate(MuFilter :: f % obj) - select type (filt => f % obj) - type is (MuFilter) - ! Allocate and store bins - filt % n_bins = n_words - 1 - allocate(filt % bins(n_words)) - call get_node_array(node_filt, "bins", filt % 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_words == 1) then - Nangle = int(filt % bins(1)) - if (Nangle > 1) then - filt % n_bins = Nangle - dangle = TWO / real(Nangle,8) - deallocate(filt % bins) - allocate(filt % bins(Nangle + 1)) - do iangle = 1, Nangle - filt % bins(iangle) = -ONE + (iangle - 1) * dangle - end do - filt % bins(Nangle + 1) = ONE - else - call fatal_error("Number of bins for mu filter must be& - & greater than 1 on filter " & - // trim(to_str(filter_id)) // ".") - end if - end if - end select - - case ('polar') - ! Allocate and declare the filter type - allocate(PolarFilter :: f % obj) - select type (filt => f % obj) - type is (PolarFilter) - ! Allocate and store bins - filt % n_bins = n_words - 1 - allocate(filt % bins(n_words)) - call get_node_array(node_filt, "bins", filt % 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_words == 1) then - Nangle = int(filt % bins(1)) - if (Nangle > 1) then - filt % n_bins = Nangle - dangle = PI / real(Nangle,8) - deallocate(filt % bins) - allocate(filt % bins(Nangle + 1)) - do iangle = 1, Nangle - filt % bins(iangle) = (iangle - 1) * dangle - end do - filt % bins(Nangle + 1) = PI - else - call fatal_error("Number of bins for polar filter must be& - & greater than 1 on filter " & - // trim(to_str(filter_id)) // ".") - end if - end if - end select - - case ('azimuthal') - ! Allocate and declare the filter type - allocate(AzimuthalFilter :: f % obj) - select type (filt => f % obj) - type is (AzimuthalFilter) - ! Allocate and store bins - filt % n_bins = n_words - 1 - allocate(filt % bins(n_words)) - call get_node_array(node_filt, "bins", filt % 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_words == 1) then - Nangle = int(filt % bins(1)) - if (Nangle > 1) then - filt % n_bins = Nangle - dangle = TWO * PI / real(Nangle,8) - deallocate(filt % bins) - allocate(filt % bins(Nangle + 1)) - do iangle = 1, Nangle - filt % bins(iangle) = -PI + (iangle - 1) * dangle - end do - filt % bins(Nangle + 1) = PI - else - call fatal_error("Number of bins for azimuthal filter must be& - & greater than 1 on filter " & - // trim(to_str(filter_id)) // ".") - end if - end if - end select - - case ('energyfunction') - ! Allocate and declare the filter type. - allocate(EnergyFunctionFilter :: f % obj) - select type (filt => f % obj) - type is (EnergyFunctionFilter) - filt % 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_filt, "energy")) then - call fatal_error("Energy grid not specified for EnergyFunction & - &filter on filter " // trim(to_str(filter_id))) - end if - n_words = node_word_count(node_filt, "energy") - allocate(filt % energy(n_words)) - call get_node_array(node_filt, "energy", filt % energy) - - ! Allocate and store interpolant values. - if (.not. check_for_node(node_filt, "y")) then - call fatal_error("y values not specified for EnergyFunction & - &filter on filter " // trim(to_str(filter_id))) - end if - n_words = node_word_count(node_filt, "y") - allocate(filt % y(n_words)) - call get_node_array(node_filt, "y", filt % y) - end select - - case default - ! Specified filter is invalid, raise error - call fatal_error("Unknown filter type '" & - // trim(temp_str) // "' on filter " & - // trim(to_str(filter_id)) // ".") - - end select + ! Read filter data from XML + call f % obj % from_xml(node_filt) ! Set filter id - f % obj % id = filter_id - - ! Add filter to dictionary - call filter_dict % add_key(filter_id, i) + err = openmc_filter_set_id(i_start + i - 1, filter_id) + ! Initialize filter + call f % obj % initialize() end do READ_FILTERS ! ========================================================================== ! READ TALLY DATA - READ_TALLIES: do i = 1, n_user_tallies + ! Check for user tallies + n = size(node_tal_list) + if (n == 0) then + if (master) call warning("No tallies present in tallies.xml file!") + end if + + ! Allocate user tallies + if (n > 0 .and. run_mode /= MODE_PLOTTING) then + err = openmc_extend_tallies(n, i_start, i_end) + end if + + READ_TALLIES: do i = 1, n + ! Allocate tally + err = openmc_tally_set_type(i_start + i - 1, & + C_CHAR_'generic' // C_NULL_CHAR) + ! Get pointer to tally - t => tallies(i) + associate (t => tallies(i_start + i - 1) % obj) ! Get pointer to tally xml node node_tal = node_tal_list(i) - ! Set tally type to volume by default - t % type = TALLY_VOLUME - - ! It's desirable to use a track-length esimator for tallies since - ! generally more events will score to the tally, reducing the - ! variance. However, for tallies that require information on - ! post-collision parameters (e.g. tally with an energyout filter) the - ! analog esimator must be used. - - t % estimator = ESTIMATOR_TRACKLENGTH - ! Copy tally id if (check_for_node(node_tal, "id")) then call get_node_value(node_tal, "id", t % id) @@ -3395,63 +2714,26 @@ contains allocate(temp_filter(n_filter)) if (n_filter > 0) then call get_node_array(node_tal, "filters", temp_filter) + + do j = 1, n_filter + ! Get pointer to filter + if (filter_dict % has_key(temp_filter(j))) then + i_filt = filter_dict % get_key(temp_filter(j)) + f => filters(i_filt) + else + call fatal_error("Could not find filter " & + // trim(to_str(temp_filter(j))) // " specified on tally " & + // trim(to_str(t % id))) + end if + + ! Store the index of the filter + temp_filter(j) = i_filt + end do + + ! Set the filters + err = openmc_tally_set_filters(i_start + i - 1, n_filter, temp_filter) end if - - do j = 1, n_filter - ! Get pointer to filter - if (filter_dict % has_key(temp_filter(j))) then - i_filt = filter_dict % get_key(temp_filter(j)) - f => filters(i_filt) - else - call fatal_error("Could not find filter " & - // trim(to_str(temp_filter(j))) // " specified on tally " & - // trim(to_str(t % id))) - end if - - ! Set the filter index in the tally find_filter array - select type (filt => f % obj) - type is (DistribcellFilter) - t % find_filter(FILTER_DISTRIBCELL) = j - type is (CellFilter) - t % find_filter(FILTER_CELL) = j - type is (CellFromFilter) - t % find_filter(FILTER_CELLFROM) = j - type is (CellbornFilter) - t % find_filter(FILTER_CELLBORN) = j - type is (MaterialFilter) - t % find_filter(FILTER_MATERIAL) = j - type is (UniverseFilter) - t % find_filter(FILTER_UNIVERSE) = j - type is (SurfaceFilter) - t % find_filter(FILTER_SURFACE) = j - type is (MeshFilter) - t % find_filter(FILTER_MESH) = j - type is (EnergyFilter) - t % find_filter(FILTER_ENERGYIN) = j - type is (EnergyoutFilter) - t % find_filter(FILTER_ENERGYOUT) = j - ! Set to analog estimator - t % estimator = ESTIMATOR_ANALOG - type is (DelayedGroupFilter) - t % find_filter(FILTER_DELAYEDGROUP) = j - type is (MuFilter) - t % find_filter(FILTER_MU) = j - ! Set to analog estimator - t % estimator = ESTIMATOR_ANALOG - type is (PolarFilter) - t % find_filter(FILTER_POLAR) = j - type is (AzimuthalFilter) - t % find_filter(FILTER_AZIMUTHAL) = j - type is (EnergyFunctionFilter) - t % find_filter(FILTER_ENERGYFUNCTION) = j - end select - - ! Store the index of the filter - temp_filter(j) = i_filt - end do - - ! Store the filter indices - call move_alloc(FROM=temp_filter, TO=t % filter) + deallocate(temp_filter) ! ======================================================================= ! READ DATA FOR NUCLIDES @@ -3464,15 +2746,15 @@ contains if (trim(sarray(1)) == 'all') then ! Handle special case all - allocate(t % nuclide_bins(n_nuclides_total + 1)) + allocate(t % nuclide_bins(n_nuclides + 1)) - ! Set bins to 1, 2, 3, ..., n_nuclides_total, -1 - t % nuclide_bins(1:n_nuclides_total) = & - (/ (j, j=1, n_nuclides_total) /) - t % nuclide_bins(n_nuclides_total + 1) = -1 + ! Set bins to 1, 2, 3, ..., n_nuclides, -1 + t % nuclide_bins(1:n_nuclides) = & + (/ (j, j=1, n_nuclides) /) + t % nuclide_bins(n_nuclides + 1) = -1 ! Set number of nuclide bins - t % n_nuclide_bins = n_nuclides_total + 1 + t % n_nuclide_bins = n_nuclides + 1 ! Set flag so we can treat this case specially t % all_nuclides = .true. @@ -3492,24 +2774,11 @@ contains word = to_lower(sarray(j)) ! Search through nuclides - pair_list => nuclide_dict % keys() - do while (associated(pair_list)) - if (trim(pair_list % key) == trim(word)) then - word = pair_list % key(1:150) - exit - end if - - ! Advance to next - pair_list => pair_list % next - end do - - ! Check if no nuclide was found - if (.not. associated(pair_list)) then + if (.not. nuclide_dict % has_key(word)) then call fatal_error("Could not find the nuclide " & // trim(word) // " specified in tally " & // trim(to_str(t % id)) // " in any material.") end if - deallocate(pair_list) ! Set bin to index in nuclides array t % nuclide_bins(j) = nuclide_dict % get_key(word) @@ -3860,54 +3129,28 @@ contains ! Get pointer to mesh select type(filt => filters(i_filter_mesh) % obj) type is (MeshFilter) - i_mesh = filt % mesh - m => meshes(i_mesh) + m => meshes(filt % mesh) end select - ! Copy filter indices to temporary array - allocate(temp_filter(size(t % filter) + 1)) - temp_filter(1:size(t % filter)) = t % filter - - ! Move allocation back -- temp_filter becomes deallocated during - ! this call - call move_alloc(FROM=temp_filter, TO=t % filter) - n_filter = size(t % filter) - ! Extend the filters array so we can add a surface filter and ! mesh filter - call add_filters(2) - - ! Increment number of user filters - n_user_filters = n_user_filters + 2 - - ! Get index of the new mesh filter - i_filt = n_user_filters - 1 + err = openmc_extend_filters(2, i_filt_start, i_filt_end) ! Duplicate the mesh filter since other tallies might use this ! filter and we need to change the dimension - allocate(MeshFilter :: filters(i_filt) % obj) - select type(filt => filters(i_filt) % obj) - type is (MeshFilter) - filt % id = i_filt - filt % mesh = i_mesh + filters(i_filt_start) = filters(i_filter_mesh) - ! 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) + ! 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_start) % obj % n_bins = product(m % dimension + 1) - ! Add filter to dictionary - call filter_dict % add_key(filt % id, i_filt) - end select - t % filter(t % find_filter(FILTER_MESH)) = i_filt - - ! Get index of the new surface filter - i_filt = n_user_filters + ! Set ID + err = openmc_filter_set_id(i_filt_start, i_filt_start) ! Add surface filter - allocate(SurfaceFilter :: filters(i_filt) % obj) - select type (filt => filters(i_filt) % obj) + allocate(SurfaceFilter :: filters(i_filt_end) % obj) + select type (filt => filters(i_filt_end) % obj) type is (SurfaceFilter) - filt % id = i_filt filt % n_bins = 4 * m % n_dimension allocate(filt % surfaces(4 * m % n_dimension)) if (m % n_dimension == 1) then @@ -3922,11 +3165,23 @@ contains end if filt % current = .true. - ! Add filter to dictionary - call filter_dict % add_key(filt % id, i_filt) + ! Set ID + err = openmc_filter_set_id(i_filt_end, i_filt_end) end select - t % find_filter(FILTER_SURFACE) = n_filter - t % filter(n_filter) = i_filt + + ! Copy filter indices to resized array + n_filter = size(t % filter) + allocate(temp_filter(n_filter + 1)) + temp_filter(1:size(t % filter)) = t % filter + n_filter = n_filter + 1 + + ! Set mesh and surface filters + temp_filter(t % find_filter(FILTER_MESH)) = i_filt_start + temp_filter(n_filter) = i_filt_end + + ! Set filters + err = openmc_tally_set_filters(i_start + i - 1, n_filter, temp_filter) + deallocate(temp_filter) end if case ('events') @@ -4332,6 +3587,7 @@ contains ! Add tally to dictionary call tally_dict % add_key(t % id, i) + end associate end do READ_TALLIES ! Close XML document @@ -4348,7 +3604,6 @@ contains integer :: i, j integer :: n_cols, col_id, n_comp, n_masks, n_meshlines integer :: meshid - integer :: i_mesh integer, allocatable :: iarray(:) logical :: file_exists ! does plots.xml file exist? character(MAX_LINE_LEN) :: filename ! absolute path to plots.xml @@ -4666,12 +3921,12 @@ contains select case (trim(meshtype)) case ('ufs') - if (.not. associated(ufs_mesh)) then + if (index_ufs_mesh < 0) then call fatal_error("No UFS mesh for meshlines on plot " & // trim(to_str(pl % id))) end if - pl % meshlines_mesh => ufs_mesh + pl % meshlines_mesh => meshes(index_ufs_mesh) case ('cmfd') @@ -4680,26 +3935,16 @@ contains &meshlines on plot " // trim(to_str(pl % id))) end if - select type(filt => filters(cmfd_tallies(1) % & - filter(cmfd_tallies(1) % find_filter(FILTER_MESH))) % obj) - type is (MeshFilter) - i_mesh = filt % mesh - end select - pl % meshlines_mesh => meshes(i_mesh) + pl % meshlines_mesh => cmfd_mesh case ('entropy') - if (.not. associated(entropy_mesh)) then + if (index_entropy_mesh < 0) then call fatal_error("No entropy mesh for meshlines on plot " & // trim(to_str(pl % id))) end if - if (.not. allocated(entropy_mesh % dimension)) then - call fatal_error("No dimension specified on entropy mesh & - &for meshlines on plot " // trim(to_str(pl % id))) - end if - - pl % meshlines_mesh => entropy_mesh + pl % meshlines_mesh => meshes(index_entropy_mesh) case ('tally') @@ -5183,7 +4428,7 @@ contains character(MAX_WORD_LEN) :: name type(SetChar) :: already_read - allocate(nuclides(n_nuclides_total)) + allocate(nuclides(n_nuclides)) allocate(sab_tables(n_sab_tables)) ! Read cross sections @@ -5211,7 +4456,7 @@ contains call file_close(file_id) ! Assign resonant scattering data - if (res_scat_on) call assign_0K_elastic_scattering(nuclides(i_nuclide)) + if (res_scat_on) call nuclides(i_nuclide) % assign_0K_elastic_scattering() ! Determine if minimum/maximum energy for this nuclide is greater/less ! than the previous @@ -5275,7 +4520,7 @@ contains end do ! Associate S(a,b) tables with specific nuclides - call materials(i) % assign_sab_tables(nuclides, sab_tables) + call materials(i) % assign_sab_tables() end do ! Show which nuclide results in lowest energy for neutron transport @@ -5335,7 +4580,7 @@ contains end if ! Use material default or global default temperature - i_material = material_dict % get_key(cells(i) % material(j)) + i_material = cells(i) % material(j) if (material_temps(i_material) /= ERROR_REAL) then cells(i) % sqrtkT(j) = sqrt(K_BOLTZMANN * & material_temps(i_material)) @@ -5346,60 +4591,6 @@ contains end do end subroutine assign_temperatures -!=============================================================================== -! ASSIGN_0K_ELASTIC_SCATTERING -!=============================================================================== - - subroutine assign_0K_elastic_scattering(nuc) - type(Nuclide), intent(inout) :: nuc - - integer :: i - real(8) :: xs_cdf_sum - - nuc % 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 (nuc % name == res_scat_nuclides(i)) then - nuc % resonant = .true. - - ! Make sure nuclide has 0K data - if (.not. allocated(nuc % energy_0K)) then - call fatal_error("Cannot treat " // trim(nuc % name) // " as a & - &resonant scatterer because 0 K elastic scattering data is & - ¬ present.") - end if - - exit - end if - end do - else - ! Otherwise, assume that any that have 0 K elastic scattering data are - ! resonant - nuc % resonant = allocated(nuc % energy_0K) - end if - - if (nuc % resonant) then - ! Build CDF for 0K elastic scattering - xs_cdf_sum = ZERO - allocate(nuc % xs_cdf(0:size(nuc % energy_0K))) - nuc % xs_cdf(0) = ZERO - - associate (E => nuc % energy_0K, xs => nuc % 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)) - nuc % xs_cdf(i) = xs_cdf_sum - end do - end associate - end if - end subroutine assign_0K_elastic_scattering - !=============================================================================== ! READ_MULTIPOLE_DATA checks for the existence of a multipole library in the ! directory and loads it using multipole_read @@ -5450,28 +4641,303 @@ contains end subroutine read_multipole_data !=============================================================================== -! CHECK_DATA_VERSION checks for the right version of nuclear data within HDF5 -! files +! 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 check_data_version(file_id) - integer(HID_T), intent(in) :: file_id + subroutine adjust_indices() - integer, allocatable :: version(:) + 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 :: id ! user-specified id + class(Lattice), pointer :: lat => null() - 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.") + do i = 1, n_cells + ! ======================================================================= + ! ADJUST UNIVERSE INDEX FOR EACH CELL + associate (c => cells(i)) + + 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 - 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.") + + ! ======================================================================= + ! 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 associate + 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 + + end subroutine adjust_indices + +!=============================================================================== +! 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) % obj % filter) + select type(filt => filters(tallies(i) % obj % 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 - end subroutine check_data_version + + ! If distribcell isn't used in this simulation then no more work left to do. + if (.not. distribcell_active) return + + ! 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) % obj % filter) + select type(filt => filters(tallies(i) % obj % 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 input_xml diff --git a/src/main.F90 b/src/main.F90 index fadf9f3bbd..d8e52643c1 100644 --- a/src/main.F90 +++ b/src/main.F90 @@ -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 diff --git a/src/material_header.F90 b/src/material_header.F90 index 5d45c40d60..eac5ab546d 100644 --- a/src/material_header.F90 +++ b/src/material_header.F90 @@ -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 diff --git a/src/mesh.F90 b/src/mesh.F90 index c25e3f7a6a..e997890a4a 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -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 diff --git a/src/mesh_header.F90 b/src/mesh_header.F90 index 9da06f813e..a7aa31b055 100644 --- a/src/mesh_header.F90 +++ b/src/mesh_header.F90 @@ -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 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 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 and 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 must be the same as & + &the number of entries on .") + 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 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 must be the & + &same as the number of entries on .") + 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 coordinates must be greater than & + &the 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 and 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 must be the same & + &as the number of entries on .") + 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 diff --git a/src/mgxs_data.F90 b/src/mgxs_data.F90 index ad20aca83b..00b5fc46ad 100644 --- a/src/mgxs_data.F90 +++ b/src/mgxs_data.F90 @@ -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 diff --git a/src/mgxs_header.F90 b/src/mgxs_header.F90 index faf0fbaff9..b282397245 100644 --- a/src/mgxs_header.F90 +++ b/src/mgxs_header.F90 @@ -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 diff --git a/src/multipole.F90 b/src/multipole.F90 index c59f947272..0282adb7d9 100644 --- a/src/multipole.F90 +++ b/src/multipole.F90 @@ -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 diff --git a/src/nuclide_header.F90 b/src/nuclide_header.F90 index bf1ea97b28..f2b4a69512 100644 --- a/src/nuclide_header.F90 +++ b/src/nuclide_header.F90 @@ -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 & + ¬ 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 diff --git a/src/output.F90 b/src/output.F90 index b239a4c79b..34134168be 100644 --- a/src/output.F90 +++ b/src/output.F90 @@ -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 diff --git a/src/particle_header.F90 b/src/particle_header.F90 index 3f4680c2ff..bda7f03b43 100644 --- a/src/particle_header.F90 +++ b/src/particle_header.F90 @@ -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) diff --git a/src/particle_restart.F90 b/src/particle_restart.F90 index 4438c48c00..53332c794f 100644 --- a/src/particle_restart.F90 +++ b/src/particle_restart.F90 @@ -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() diff --git a/src/particle_restart_write.F90 b/src/particle_restart_write.F90 index 08e80ea1b0..5addf6056f 100644 --- a/src/particle_restart_write.F90 +++ b/src/particle_restart_write.F90 @@ -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 diff --git a/src/physics.F90 b/src/physics.F90 index f40b7fd7b8..cb309f93ac 100644 --- a/src/physics.F90 +++ b/src/physics.F90 @@ -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 diff --git a/src/physics_common.F90 b/src/physics_common.F90 index 98d240c077..63bf62ce62 100644 --- a/src/physics_common.F90 +++ b/src/physics_common.F90 @@ -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 diff --git a/src/physics_mg.F90 b/src/physics_mg.F90 index 9b18b762b0..42094f6d06 100644 --- a/src/physics_mg.F90 +++ b/src/physics_mg.F90 @@ -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 diff --git a/src/plot.F90 b/src/plot.F90 index 067d0c56fc..fe2ddd13b7 100644 --- a/src/plot.F90 +++ b/src/plot.F90 @@ -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) diff --git a/src/plot_header.F90 b/src/plot_header.F90 index a6ea9a580d..1091bd73a8 100644 --- a/src/plot_header.F90 +++ b/src/plot_header.F90 @@ -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 diff --git a/src/relaxng/settings.rnc b/src/relaxng/settings.rnc index 23a0cfd4b7..19a2948c58 100644 --- a/src/relaxng/settings.rnc +++ b/src/relaxng/settings.rnc @@ -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 })? & diff --git a/src/relaxng/settings.rng b/src/relaxng/settings.rng index e75dc7c15e..606b978290 100644 --- a/src/relaxng/settings.rng +++ b/src/relaxng/settings.rng @@ -62,59 +62,8 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + @@ -159,6 +108,96 @@ + + + + + + + + + + + + + + + regular + + + regular + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -585,6 +624,11 @@ + + + + + @@ -660,60 +704,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/src/sab_header.F90 b/src/sab_header.F90 index e0b79f2485..6dd617790b 100644 --- a/src/sab_header.F90 +++ b/src/sab_header.F90 @@ -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 diff --git a/src/settings.F90 b/src/settings.F90 new file mode 100644 index 0000000000..83aebce860 --- /dev/null +++ b/src/settings.F90 @@ -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 diff --git a/src/simulation.F90 b/src/simulation.F90 index 7427443bbe..a240f55b06 100644 --- a/src/simulation.F90 +++ b/src/simulation.F90 @@ -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 diff --git a/src/simulation_header.F90 b/src/simulation_header.F90 new file mode 100644 index 0000000000..cfb75b4492 --- /dev/null +++ b/src/simulation_header.F90 @@ -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 diff --git a/src/source.F90 b/src/source.F90 index 517715b563..0689cb4035 100644 --- a/src/source.F90 +++ b/src/source.F90 @@ -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 diff --git a/src/source_header.F90 b/src/source_header.F90 index eefc007a47..a60696996a 100644 --- a/src/source_header.F90 +++ b/src/source_header.F90 @@ -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 diff --git a/src/state_point.F90 b/src/state_point.F90 index e2a476e7e9..5dde708aa9 100644 --- a/src/state_point.F90 +++ b/src/state_point.F90 @@ -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))) diff --git a/src/string.F90 b/src/string.F90 index efb0dd982c..71d9d6e966 100644 --- a/src/string.F90 +++ b/src/string.F90 @@ -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 diff --git a/src/summary.F90 b/src/summary.F90 index 9c952fe70a..e271fbaba6 100644 --- a/src/summary.F90 +++ b/src/summary.F90 @@ -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 diff --git a/src/surface_header.F90 b/src/surface_header.F90 index 68e5144b7c..ed4ef86e09 100644 --- a/src/surface_header.F90 +++ b/src/surface_header.F90 @@ -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 diff --git a/src/tally.F90 b/src/tallies/tally.F90 similarity index 96% rename from src/tally.F90 rename to src/tallies/tally.F90 index ee2fc992f4..9e40bfd6c6 100644 --- a/src/tally.F90 +++ b/src/tallies/tally.F90 @@ -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 all. !=============================================================================== - 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 diff --git a/src/tallies/tally_derivative_header.F90 b/src/tallies/tally_derivative_header.F90 new file mode 100644 index 0000000000..fcf4a203b9 --- /dev/null +++ b/src/tallies/tally_derivative_header.F90 @@ -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 elements in the& + & tally XML file") + end if + + ! Make sure the id is > 0. + if (this % id <= 0) then + call fatal_error(" 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 '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 diff --git a/src/tallies/tally_filter.F90 b/src/tallies/tally_filter.F90 new file mode 100644 index 0000000000..587f8dd902 --- /dev/null +++ b/src/tallies/tally_filter.F90 @@ -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 diff --git a/src/tallies/tally_filter_azimuthal.F90 b/src/tallies/tally_filter_azimuthal.F90 new file mode 100644 index 0000000000..272d111d14 --- /dev/null +++ b/src/tallies/tally_filter_azimuthal.F90 @@ -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 diff --git a/src/tallies/tally_filter_cell.F90 b/src/tallies/tally_filter_cell.F90 new file mode 100644 index 0000000000..22f3c0c579 --- /dev/null +++ b/src/tallies/tally_filter_cell.F90 @@ -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 diff --git a/src/tallies/tally_filter_cellborn.F90 b/src/tallies/tally_filter_cellborn.F90 new file mode 100644 index 0000000000..b23b5b3449 --- /dev/null +++ b/src/tallies/tally_filter_cellborn.F90 @@ -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 diff --git a/src/tallies/tally_filter_cellfrom.F90 b/src/tallies/tally_filter_cellfrom.F90 new file mode 100644 index 0000000000..fa1f87e0e8 --- /dev/null +++ b/src/tallies/tally_filter_cellfrom.F90 @@ -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 diff --git a/src/tallies/tally_filter_delayedgroup.F90 b/src/tallies/tally_filter_delayedgroup.F90 new file mode 100644 index 0000000000..32010e8157 --- /dev/null +++ b/src/tallies/tally_filter_delayedgroup.F90 @@ -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 diff --git a/src/tallies/tally_filter_distribcell.F90 b/src/tallies/tally_filter_distribcell.F90 new file mode 100644 index 0000000000..7643eca4a5 --- /dev/null +++ b/src/tallies/tally_filter_distribcell.F90 @@ -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 diff --git a/src/tallies/tally_filter_energy.F90 b/src/tallies/tally_filter_energy.F90 new file mode 100644 index 0000000000..7f96552800 --- /dev/null +++ b/src/tallies/tally_filter_energy.F90 @@ -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 diff --git a/src/tallies/tally_filter_energyfunc.F90 b/src/tallies/tally_filter_energyfunc.F90 new file mode 100644 index 0000000000..efaabae2ee --- /dev/null +++ b/src/tallies/tally_filter_energyfunc.F90 @@ -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 diff --git a/src/tallies/tally_filter_header.F90 b/src/tallies/tally_filter_header.F90 new file mode 100644 index 0000000000..e6a6f20c34 --- /dev/null +++ b/src/tallies/tally_filter_header.F90 @@ -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 diff --git a/src/tallies/tally_filter_material.F90 b/src/tallies/tally_filter_material.F90 new file mode 100644 index 0000000000..14afdc842a --- /dev/null +++ b/src/tallies/tally_filter_material.F90 @@ -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 diff --git a/src/tallies/tally_filter_mesh.F90 b/src/tallies/tally_filter_mesh.F90 new file mode 100644 index 0000000000..0428973c41 --- /dev/null +++ b/src/tallies/tally_filter_mesh.F90 @@ -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 diff --git a/src/tallies/tally_filter_mu.F90 b/src/tallies/tally_filter_mu.F90 new file mode 100644 index 0000000000..c949289b66 --- /dev/null +++ b/src/tallies/tally_filter_mu.F90 @@ -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 diff --git a/src/tallies/tally_filter_polar.F90 b/src/tallies/tally_filter_polar.F90 new file mode 100644 index 0000000000..89815c1028 --- /dev/null +++ b/src/tallies/tally_filter_polar.F90 @@ -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 diff --git a/src/tallies/tally_filter_surface.F90 b/src/tallies/tally_filter_surface.F90 new file mode 100644 index 0000000000..9c5341022f --- /dev/null +++ b/src/tallies/tally_filter_surface.F90 @@ -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 diff --git a/src/tallies/tally_filter_universe.F90 b/src/tallies/tally_filter_universe.F90 new file mode 100644 index 0000000000..195e2544a3 --- /dev/null +++ b/src/tallies/tally_filter_universe.F90 @@ -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 diff --git a/src/tallies/tally_header.F90 b/src/tallies/tally_header.F90 new file mode 100644 index 0000000000..a823b7df5c --- /dev/null +++ b/src/tallies/tally_header.F90 @@ -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 diff --git a/src/trigger.F90 b/src/tallies/trigger.F90 similarity index 96% rename from src/trigger.F90 rename to src/tallies/trigger.F90 index cb5f2c4c85..772e739bad 100644 --- a/src/trigger.F90 +++ b/src/tallies/trigger.F90 @@ -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 diff --git a/src/trigger_header.F90 b/src/tallies/trigger_header.F90 similarity index 89% rename from src/trigger_header.F90 rename to src/tallies/trigger_header.F90 index 96421314cd..87507224ad 100644 --- a/src/trigger_header.F90 +++ b/src/tallies/trigger_header.F90 @@ -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 diff --git a/src/tally_filter.F90 b/src/tally_filter.F90 deleted file mode 100644 index eb83b319c2..0000000000 --- a/src/tally_filter.F90 +++ /dev/null @@ -1,1567 +0,0 @@ -module tally_filter - - use algorithm, only: binary_search - use constants, only: ONE, NO_BIN_FOUND, FP_PRECISION, ERROR_REAL - use dict_header, only: DictIntInt - use geometry_header, only: root_universe, RectLattice, HexLattice - use global - use hdf5_interface - use mesh_header, only: RegularMesh - 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 particle_header, only: Particle - use string, only: to_str - use tally_filter_header, only: TallyFilter, TallyFilterContainer, & - TallyFilterMatch - - use hdf5, only: HID_T - - implicit none - -!=============================================================================== -! 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, extends(TallyFilter) :: MeshFilter - integer :: mesh - contains - procedure :: get_all_bins => get_all_bins_mesh - procedure :: to_statepoint => to_statepoint_mesh - procedure :: text_label => text_label_mesh - end type MeshFilter - -!=============================================================================== -! UNIVERSEFILTER specifies which geometric universes tally events reside in. -!=============================================================================== - type, extends(TallyFilter) :: UniverseFilter - integer, allocatable :: universes(:) - type(DictIntInt) :: map - contains - 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 - -!=============================================================================== -! MATERIAL specifies which material tally events reside in. -!=============================================================================== - type, extends(TallyFilter) :: MaterialFilter - integer, allocatable :: materials(:) - type(DictIntInt) :: map - contains - 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 - -!=============================================================================== -! CELLFILTER specifies which geometric cells tally events reside in. -!=============================================================================== - type, extends(TallyFilter) :: CellFilter - integer, allocatable :: cells(:) - type(DictIntInt) :: map - contains - 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 - -!=============================================================================== -! CELLFROMFILTER specifies which geometric cells particles exit when crossing a -! surface. -!=============================================================================== - type, extends(CellFilter) :: CellFromFilter - contains - 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 - -!=============================================================================== -! DISTRIBCELLFILTER specifies which distributed geometric cells tally events -! reside in. -!=============================================================================== - type, extends(TallyFilter) :: DistribcellFilter - integer :: cell - contains - 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 - -!=============================================================================== -! CELLBORNFILTER specifies which cell the particle was born in. -!=============================================================================== - type, extends(TallyFilter) :: CellbornFilter - integer, allocatable :: cells(:) - type(DictIntInt) :: map - contains - 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 - -!=============================================================================== -! SURFACEFILTER specifies which surface particles are crossing -!=============================================================================== - type, extends(TallyFilter) :: SurfaceFilter - integer, allocatable :: surfaces(:) - - ! True if this filter is used for surface currents - logical :: current = .false. - contains - 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 - -!=============================================================================== -! ENERGYFILTER bins the incident neutron energy. -!=============================================================================== - type, 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 :: 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, extends(TallyFilter) :: EnergyoutFilter - real(8), allocatable :: bins(:) - - ! True if transport group number can be used directly to get bin number - logical :: matches_transport_groups = .false. - - contains - procedure :: get_all_bins => get_all_bins_energyout - procedure :: to_statepoint => to_statepoint_energyout - procedure :: text_label => text_label_energyout - end type EnergyoutFilter - -!=============================================================================== -! 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, extends(TallyFilter) :: DelayedGroupFilter - integer, allocatable :: groups(:) - contains - procedure :: get_all_bins => get_all_bins_dg - procedure :: to_statepoint => to_statepoint_dg - procedure :: text_label => text_label_dg - end type DelayedGroupFilter - -!=============================================================================== -! MUFILTER bins the incoming-outgoing direction cosine. This is only used for -! scatter reactions. -!=============================================================================== - type, extends(TallyFilter) :: MuFilter - real(8), allocatable :: bins(:) - contains - procedure :: get_all_bins => get_all_bins_mu - procedure :: to_statepoint => to_statepoint_mu - procedure :: text_label => text_label_mu - end type MuFilter - -!=============================================================================== -! POLARFILTER bins the incident neutron polar angle (relative to the global -! z-axis). -!=============================================================================== - type, extends(TallyFilter) :: PolarFilter - real(8), allocatable :: bins(:) - contains - procedure :: get_all_bins => get_all_bins_polar - procedure :: to_statepoint => to_statepoint_polar - procedure :: text_label => text_label_polar - end type PolarFilter - -!=============================================================================== -! AZIMUTHALFILTER bins the incident neutron azimuthal angle (relative to the -! global xy-plane). -!=============================================================================== - type, extends(TallyFilter) :: AzimuthalFilter - real(8), allocatable :: bins(:) - contains - procedure :: get_all_bins => get_all_bins_azimuthal - procedure :: to_statepoint => to_statepoint_azimuthal - procedure :: text_label => text_label_azimuthal - end type AzimuthalFilter - -!=============================================================================== -! EnergyFunctionFilter multiplies tally scores by an arbitrary function of -! incident energy described by a piecewise linear-linear interpolation. -!=============================================================================== - type, extends(TallyFilter) :: EnergyFunctionFilter - real(8), allocatable :: energy(:) - real(8), allocatable :: y(:) - - contains - procedure :: get_all_bins => get_all_bins_energyfunction - procedure :: to_statepoint => to_statepoint_energyfunction - procedure :: text_label => text_label_energyfunction - end type EnergyFunctionFilter - -contains - -!=============================================================================== -! METHODS: for a description of these methods, see their counterparts bound to -! the abstract TallyFilter class. -!=============================================================================== - -!=============================================================================== -! MeshFilter methods -!=============================================================================== - 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 get_mesh_bin(m, 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 get_mesh_indices(m, xyz0, ijk0(:n), start_in_mesh) - call get_mesh_indices(m, 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 (n == 1) then - if (.not. mesh_intersects_1d(m, xyz0, xyz1)) then - return - end if - else if (n == 2) then - if (.not. mesh_intersects_2d(m, xyz0, xyz1)) then - return - end if - else - if (.not. mesh_intersects_3d(m, xyz0, xyz1)) then - return - end if - end if - 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 = mesh_indices_to_bin(m, 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(:) - type(RegularMesh), pointer :: m - - m => meshes(this % mesh) - allocate(ijk(m % n_dimension)) - call bin_to_mesh_indices(m, 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 function text_label_mesh - -!=============================================================================== -! UniverseFilter methods -!=============================================================================== - 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 - -!=============================================================================== -! MaterialFilter methods -!=============================================================================== - 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 - -!=============================================================================== -! CellFilter methods -!=============================================================================== - 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 - -!=============================================================================== -! CellFromFilter methods -!=============================================================================== - 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 - - ! Iterate over coordinate levels to see with cells match - - 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) - 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 - -!=============================================================================== -! DistribcellFilter methods -!=============================================================================== - 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) - 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 - -!=============================================================================== -! CellbornFilter methods -!=============================================================================== - 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 - -!=============================================================================== -! SurfaceFilter methods -!=============================================================================== - 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 - -!=============================================================================== -! EnergyFilter methods -!=============================================================================== - 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 ((.not. run_CE) .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 ((.not. run_CE) .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 - -!=============================================================================== -! DelayedGroupFilter methods -!=============================================================================== - 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 - -!=============================================================================== -! MuFilter methods -!=============================================================================== - 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 - -!=============================================================================== -! PolarFilter methods -!=============================================================================== - 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 - -!=============================================================================== -! AzimuthalFilter methods -!=============================================================================== - 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 - -!=============================================================================== -! EnergyFunctionFilter methods -!=============================================================================== - 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) - - ! Make sure the correct energy is used. - if (estimator == ESTIMATOR_TRACKLENGTH) then - E = p % E - else - E = p % last_E - end if - - ! 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 - -!=============================================================================== -! 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 - -!=============================================================================== -! ADD_FILTERS creates or extends the filters array -!=============================================================================== - - subroutine add_filters(n) - - integer, intent(in) :: n ! number of filters to add - - 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 - - ! Set n_filters - n_filters = size(filters) - - end subroutine add_filters - -end module tally_filter diff --git a/src/tally_filter_header.F90 b/src/tally_filter_header.F90 deleted file mode 100644 index d69dd299d1..0000000000 --- a/src/tally_filter_header.F90 +++ /dev/null @@ -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 diff --git a/src/tally_header.F90 b/src/tally_header.F90 deleted file mode 100644 index 76e3d143f9..0000000000 --- a/src/tally_header.F90 +++ /dev/null @@ -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 diff --git a/src/tally_initialize.F90 b/src/tally_initialize.F90 deleted file mode 100644 index 46c0283642..0000000000 --- a/src/tally_initialize.F90 +++ /dev/null @@ -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 diff --git a/src/timer_header.F90 b/src/timer_header.F90 index 6f9785d565..a147a551df 100644 --- a/src/timer_header.F90 +++ b/src/timer_header.F90 @@ -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 !=============================================================================== diff --git a/src/track_output.F90 b/src/track_output.F90 index bdef9579c2..244bf182e0 100644 --- a/src/track_output.F90 +++ b/src/track_output.F90 @@ -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 diff --git a/src/tracking.F90 b/src/tracking.F90 index a5b9386c0c..726a263adf 100644 --- a/src/tracking.F90 +++ b/src/tracking.F90 @@ -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, & diff --git a/src/volume_calc.F90 b/src/volume_calc.F90 index f8cf4085a5..48f93f0e6a 100644 --- a/src/volume_calc.F90 +++ b/src/volume_calc.F90 @@ -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 diff --git a/src/volume_header.F90 b/src/volume_header.F90 index a01b664dfe..59a579a5fb 100644 --- a/src/volume_header.F90 +++ b/src/volume_header.F90 @@ -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 diff --git a/tests/test_cmfd_feed/settings.xml b/tests/test_cmfd_feed/settings.xml index 3e8b77b393..742aa22330 100644 --- a/tests/test_cmfd_feed/settings.xml +++ b/tests/test_cmfd_feed/settings.xml @@ -16,13 +16,14 @@ - + 10 1 1 -10.0 -1.0 -1.0 10.0 1.0 1.0 - + + 10 - - true + + true diff --git a/tests/test_cmfd_nofeed/settings.xml b/tests/test_cmfd_nofeed/settings.xml index 3e8b77b393..b56acb4b76 100644 --- a/tests/test_cmfd_nofeed/settings.xml +++ b/tests/test_cmfd_nofeed/settings.xml @@ -16,11 +16,12 @@ - + 10 1 1 -10.0 -1.0 -1.0 10.0 1.0 1.0 - + + 10 true diff --git a/tests/test_entropy/settings.xml b/tests/test_entropy/settings.xml index df6a851ef6..493da72237 100644 --- a/tests/test_entropy/settings.xml +++ b/tests/test_entropy/settings.xml @@ -12,10 +12,12 @@ - + 10 10 10 -10. -10. -10. 10. 10. 10. - + + + 1 diff --git a/tests/test_plot/settings.xml b/tests/test_plot/settings.xml index 197b9c7093..adf256d2d4 100644 --- a/tests/test_plot/settings.xml +++ b/tests/test_plot/settings.xml @@ -3,10 +3,11 @@ plot - + 5 4 3 -10 -10 -10 10 10 10 - + + 1