diff --git a/openmc/filter.py b/openmc/filter.py index d6ee70f148..8a54e05cee 100644 --- a/openmc/filter.py +++ b/openmc/filter.py @@ -162,6 +162,11 @@ class Filter(object): if not isinstance(bins, Iterable): bins = [bins] + # If the bin is 0D numpy array, promote to 1D + elif isinstance(bins, np.ndarray): + if bins.shape == (): + bins.shape = (1,) + # If the bins are in a collection, convert it to a list else: bins = list(bins) diff --git a/src/cmfd_data.F90 b/src/cmfd_data.F90 index 347351e318..0f1d9420be 100644 --- a/src/cmfd_data.F90 +++ b/src/cmfd_data.F90 @@ -6,6 +6,7 @@ module cmfd_data !============================================================================== use constants + use tally_filter, only: MeshFilter implicit none private @@ -94,7 +95,10 @@ contains ! Associate tallies and mesh t => cmfd_tallies(1) - i_mesh = t % filters(t % find_filter(FILTER_MESH)) % int_bins(1) + select type(filt => t % filters(t % find_filter(FILTER_MESH)) % obj) + type is (MeshFilter) + i_mesh = filt % mesh + end select m => meshes(i_mesh) ! Set mesh widths @@ -109,7 +113,10 @@ contains ! Associate tallies and mesh t => cmfd_tallies(ital) - i_mesh = t % filters(t % find_filter(FILTER_MESH)) % int_bins(1) + select type(filt => t % filters(t % find_filter(FILTER_MESH)) % obj) + type is (MeshFilter) + i_mesh = filt % mesh + end select m => meshes(i_mesh) i_filter_mesh = t % find_filter(FILTER_MESH) @@ -138,7 +145,7 @@ contains TALLY: if (ital == 1) then ! Reset all bins to 1 - matching_bins(1:t%n_filters) = 1 + matching_bins(1:size(t % filters)) = 1 ! Set ijk as mesh indices ijk = (/ i, j, k /) @@ -152,7 +159,8 @@ contains end if ! Calculate score index from bins - score_index = sum((matching_bins(1:t%n_filters) - 1) * t%stride) + 1 + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t%stride) + 1 ! Get flux flux = t % results(1,score_index) % sum @@ -181,7 +189,7 @@ contains INGROUP: do g = 1, ng ! Reset all bins to 1 - matching_bins(1:t%n_filters) = 1 + matching_bins(1:size(t % filters)) = 1 ! Set ijk as mesh indices ijk = (/ i, j, k /) @@ -198,7 +206,8 @@ contains end if ! Calculate score index from bins - score_index = sum((matching_bins(1:t%n_filters) - 1) * t%stride) + 1 + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t%stride) + 1 ! Get scattering cmfd % scattxs(h,g,i,j,k) = t % results(1,score_index) % sum /& @@ -220,7 +229,7 @@ contains else if (ital == 3) then ! Initialize and filter for energy - matching_bins(1:t%n_filters) = 1 + matching_bins(1:size(t % filters)) = 1 if (i_filter_ein > 0) then matching_bins(i_filter_ein) = ng - h + 1 end if @@ -229,60 +238,72 @@ contains matching_bins(i_filter_mesh) = mesh_indices_to_bin(m, & (/ i-1, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_RIGHT - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! outgoing + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t%stride) + 1 ! outgoing cmfd % current(1,h,i,j,k) = t % results(1,score_index) % sum matching_bins(i_filter_surf) = OUT_RIGHT - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! incoming + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! incoming cmfd % current(2,h,i,j,k) = t % results(1,score_index) % sum ! Right surface matching_bins(i_filter_mesh) = mesh_indices_to_bin(m, & (/ i, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_RIGHT - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! incoming + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! incoming cmfd % current(3,h,i,j,k) = t % results(1,score_index) % sum matching_bins(i_filter_surf) = OUT_RIGHT - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! outgoing + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! outgoing cmfd % current(4,h,i,j,k) = t % results(1,score_index) % sum ! Back surface matching_bins(i_filter_mesh) = mesh_indices_to_bin(m, & (/ i, j-1, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_FRONT - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! outgoing + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! outgoing cmfd % current(5,h,i,j,k) = t % results(1,score_index) % sum matching_bins(i_filter_surf) = OUT_FRONT - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! incoming + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! incoming cmfd % current(6,h,i,j,k) = t % results(1,score_index) % sum ! Front surface matching_bins(i_filter_mesh) = mesh_indices_to_bin(m, & (/ i, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_FRONT - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! incoming + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! incoming cmfd % current(7,h,i,j,k) = t % results(1,score_index) % sum matching_bins(i_filter_surf) = OUT_FRONT - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! outgoing + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! outgoing cmfd % current(8,h,i,j,k) = t % results(1,score_index) % sum ! Bottom surface matching_bins(i_filter_mesh) = mesh_indices_to_bin(m, & (/ i, j, k-1 /) + 1, .true.) matching_bins(i_filter_surf) = IN_TOP - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! outgoing + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! outgoing cmfd % current(9,h,i,j,k) = t % results(1,score_index) % sum matching_bins(i_filter_surf) = OUT_TOP - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! incoming + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! incoming cmfd % current(10,h,i,j,k) = t % results(1,score_index) % sum ! Top surface matching_bins(i_filter_mesh) = mesh_indices_to_bin(m, & (/ i, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_TOP - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! incoming + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! incoming cmfd % current(11,h,i,j,k) = t % results(1,score_index) % sum matching_bins(i_filter_surf) = OUT_TOP - score_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 ! outgoing + score_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! outgoing cmfd % current(12,h,i,j,k) = t % results(1,score_index) % sum end if TALLY diff --git a/src/cmfd_input.F90 b/src/cmfd_input.F90 index f69c09fe1c..baa08e76e8 100644 --- a/src/cmfd_input.F90 +++ b/src/cmfd_input.F90 @@ -267,14 +267,16 @@ contains use mesh_header, only: RegularMesh use string use tally, only: setup_active_cmfdtallies - use tally_header, only: TallyObject, TallyFilter + use tally_header, only: TallyObject + use tally_filter_header + use tally_filter use tally_initialize, only: add_tallies use xml_interface type(Node), pointer :: doc ! pointer to XML doc info character(MAX_LINE_LEN) :: temp_str ! temp string - integer :: i ! loop counter + integer :: i, j ! loop counter integer :: n ! size of arrays in mesh specification integer :: ng ! number of energy groups (default 1) integer :: n_filters ! number of filters @@ -283,7 +285,7 @@ contains real(8) :: rarray3(3) ! temp double array type(TallyObject), pointer :: t type(RegularMesh), pointer :: m - type(TallyFilter) :: filters(N_FILTER_TYPES) ! temporary filters + type(TallyFilterContainer) :: filters(N_FILTER_TYPES) ! temporary filters type(Node), pointer :: node_mesh ! Set global variables if they are 0 (this can happen if there is no tally @@ -410,21 +412,25 @@ contains ! Set up mesh filter n_filters = 1 - filters(n_filters) % type = FILTER_MESH - filters(n_filters) % n_bins = product(m % dimension) - allocate(filters(n_filters) % int_bins(1)) - filters(n_filters) % int_bins(1) = n_user_meshes + 1 + allocate(MeshFilter :: filters(n_filters) % obj) + select type (filt => filters(n_filters) % obj) + type is (MeshFilter) + filt % n_bins = product(m % dimension) + filt % mesh = n_user_meshes + 1 + end select t % find_filter(FILTER_MESH) = n_filters ! Read and set incoming energy mesh filter if (check_for_node(node_mesh, "energy")) then n_filters = n_filters + 1 - filters(n_filters) % type = FILTER_ENERGYIN - ng = get_arraysize_double(node_mesh, "energy") - filters(n_filters) % n_bins = ng - 1 - allocate(filters(n_filters) % real_bins(ng)) - call get_node_array(node_mesh, "energy", & - filters(n_filters) % real_bins) + allocate(EnergyFilter :: filters(n_filters) % obj) + select type (filt => filters(n_filters) % obj) + type is (EnergyFilter) + ng = get_arraysize_double(node_mesh, "energy") + filt % n_bins = ng - 1 + allocate(filt % bins(ng)) + call get_node_array(node_mesh, "energy", filt % bins) + end select t % find_filter(FILTER_ENERGYIN) = n_filters end if @@ -448,9 +454,10 @@ contains t % type = TALLY_VOLUME ! Allocate and set filters - t % n_filters = n_filters allocate(t % filters(n_filters)) - t % filters = filters(1:n_filters) + do j = 1, n_filters + call move_alloc(filters(j) % obj, t % filters(j) % obj) + end do ! Allocate scoring bins allocate(t % score_bins(3)) @@ -481,23 +488,22 @@ contains ! read and set outgoing energy mesh filter if (check_for_node(node_mesh, "energy")) then n_filters = n_filters + 1 - filters(n_filters) % type = FILTER_ENERGYOUT - ng = get_arraysize_double(node_mesh, "energy") - filters(n_filters) % n_bins = ng - 1 - allocate(filters(n_filters) % real_bins(ng)) - call get_node_array(node_mesh, "energy", & - filters(n_filters) % real_bins) + allocate(EnergyoutFilter :: filters(n_filters) % obj) + select type (filt => filters(n_filters) % obj) + type is (EnergyoutFilter) + ng = get_arraysize_double(node_mesh, "energy") + filt % n_bins = ng - 1 + allocate(filt % bins(ng)) + call get_node_array(node_mesh, "energy", filt % bins) + end select t % find_filter(FILTER_ENERGYOUT) = n_filters end if ! Allocate and set filters - t % n_filters = n_filters allocate(t % filters(n_filters)) - t % filters = filters(1:n_filters) - - ! deallocate filters bins array - if (check_for_node(node_mesh, "energy")) & - deallocate(filters(n_filters) % real_bins) + do j = 1, n_filters + call move_alloc(filters(j) % obj, t % filters(j) % obj) + end do ! Allocate macro reactions allocate(t % score_bins(2)) @@ -522,25 +528,25 @@ contains ! Add extra filter for surface n_filters = n_filters + 1 - filters(n_filters) % type = FILTER_SURFACE - filters(n_filters) % n_bins = 2 * m % n_dimension - allocate(filters(n_filters) % int_bins(2 * m % n_dimension)) - if (m % n_dimension == 2) then - filters(n_filters) % int_bins = (/ IN_RIGHT, OUT_RIGHT, IN_FRONT, & - OUT_FRONT /) - elseif (m % n_dimension == 3) then - filters(n_filters) % int_bins = (/ IN_RIGHT, OUT_RIGHT, IN_FRONT, & - OUT_FRONT, IN_TOP, OUT_TOP /) - end if + allocate(SurfaceFilter :: filters(n_filters) % obj) + select type(filt => filters(n_filters) % obj) + type is(SurfaceFilter) + filt % n_bins = 2 * m % n_dimension + allocate(filt % surfaces(2 * m % n_dimension)) + if (m % n_dimension == 2) then + filt % surfaces = (/ IN_RIGHT, OUT_RIGHT, IN_FRONT, OUT_FRONT /) + elseif (m % n_dimension == 3) then + filt % surfaces = (/ IN_RIGHT, OUT_RIGHT, IN_FRONT, OUT_FRONT, & + IN_TOP, OUT_TOP /) + end if + end select t % find_filter(FILTER_SURFACE) = n_filters ! Allocate and set filters - t % n_filters = n_filters allocate(t % filters(n_filters)) - t % filters = filters(1:n_filters) - - ! Deallocate filters bins array - deallocate(filters(n_filters) % int_bins) + do j = 1, n_filters + call move_alloc(filters(j) % obj, t % filters(j) % obj) + end do ! Allocate macro reactions allocate(t % score_bins(1)) @@ -558,15 +564,10 @@ contains ! We need to increase the dimension by one since we also need ! currents coming into and out of the boundary mesh cells. i_filter_mesh = t % find_filter(FILTER_MESH) - t % filters(i_filter_mesh) % n_bins = product(m % dimension + 1) + t % filters(i_filter_mesh) % obj % n_bins = product(m % dimension + 1) end if - ! Deallocate filter bins - deallocate(filters(1) % int_bins) - if (check_for_node(node_mesh, "energy")) & - deallocate(filters(2) % real_bins) - end do ! Put cmfd tallies into active tally array and turn tallies on diff --git a/src/geometry.F90 b/src/geometry.F90 index 767e2db108..6d4ca77671 100644 --- a/src/geometry.F90 +++ b/src/geometry.F90 @@ -499,7 +499,7 @@ contains end if ! Set previous coordinate going slightly past surface crossing - p % last_xyz = p % coord(1) % xyz + TINY_BIT * p % coord(1) % uvw + p % last_xyz_current = p % coord(1) % xyz + TINY_BIT * p % coord(1) % uvw ! Diagnostic message if (verbosity >= 10 .or. trace) then @@ -563,7 +563,7 @@ contains end if ! Set previous coordinate going slightly past surface crossing - p % last_xyz = p % coord(1) % xyz + TINY_BIT * p % coord(1) % uvw + p % last_xyz_current = p % coord(1) % xyz + TINY_BIT * p % coord(1) % uvw ! Diagnostic message if (verbosity >= 10 .or. trace) then diff --git a/src/global.F90 b/src/global.F90 index 1b1e5632a4..1558c050e4 100644 --- a/src/global.F90 +++ b/src/global.F90 @@ -14,7 +14,7 @@ module global use set_header, only: SetInt use surface_header, only: SurfaceContainer use source_header, only: SourceDistribution - use tally_header, only: TallyObject, TallyMap, TallyResult + use tally_header, only: TallyObject, TallyResult use trigger_header, only: KTrigger use timer_header, only: Timer @@ -137,6 +137,7 @@ module global type(RegularMesh), allocatable, target :: meshes(:) type(TallyObject), allocatable, target :: tallies(:) integer, allocatable :: matching_bins(:) + real(8), allocatable :: filter_weights(:) ! Pointers for different tallies type(TallyObject), pointer :: user_tallies(:) => null() @@ -176,9 +177,6 @@ module global !$omp threadprivate(global_tally_collision, global_tally_absorption, & !$omp& global_tally_tracklength, global_tally_leakage) - ! Tally map structure - type(TallyMap), allocatable :: tally_maps(:) - integer :: n_meshes = 0 ! # of structured meshes integer :: n_user_meshes = 0 ! # of structured user meshes integer :: n_tallies = 0 ! # of tallies @@ -443,7 +441,8 @@ module global type(Nuclide0K), allocatable, target :: nuclides_0K(:) ! 0K nuclides info !$omp threadprivate(micro_xs, material_xs, fission_bank, n_bank, & -!$omp& trace, thread_id, current_work, matching_bins) +!$omp& trace, thread_id, current_work, matching_bins, & +!$omp& filter_weights) contains @@ -509,7 +508,7 @@ contains if (allocated(meshes)) deallocate(meshes) if (allocated(tallies)) deallocate(tallies) if (allocated(matching_bins)) deallocate(matching_bins) - if (allocated(tally_maps)) deallocate(tally_maps) + if (allocated(filter_weights)) deallocate(filter_weights) ! Deallocate fission and source bank and entropy !$omp parallel diff --git a/src/initialize.F90 b/src/initialize.F90 index 37eeb1f3e5..99adf967f0 100644 --- a/src/initialize.F90 +++ b/src/initialize.F90 @@ -22,8 +22,9 @@ module initialize use state_point, only: load_state_point use string, only: to_str, starts_with, ends_with, str_to_int use summary, only: write_summary - use tally_header, only: TallyObject, TallyResult, TallyFilter + use tally_header, only: TallyObject, TallyResult use tally_initialize,only: configure_tallies + use tally_filter use tally, only: init_tally_routines #ifdef MPI @@ -711,76 +712,15 @@ contains ! ======================================================================= ! ADJUST INDICES FOR EACH TALLY FILTER - FILTER_LOOP: do j = 1, t%n_filters - - select case (t%filters(j)%type) - case (FILTER_DISTRIBCELL) - do k = 1, size(t%filters(j)%int_bins) - id = t%filters(j)%int_bins(k) - if (cell_dict%has_key(id)) then - t%filters(j)%int_bins(k) = cell_dict%get_key(id) - else - call fatal_error("Could not find cell " // trim(to_str(id)) // & - " specified on tally " // trim(to_str(t%id))) - end if - - end do - case (FILTER_CELL, FILTER_CELLBORN) - - do k = 1, t%filters(j)%n_bins - id = t%filters(j)%int_bins(k) - if (cell_dict%has_key(id)) then - t%filters(j)%int_bins(k) = cell_dict%get_key(id) - else - call fatal_error("Could not find cell " // trim(to_str(id)) & - &// " specified on tally " // trim(to_str(t%id))) - end if - end do - - case (FILTER_SURFACE) + FILTER_LOOP: do j = 1, size(t % filters) + select type(filt => t % filters(j) % obj) + type is (SurfaceFilter) ! Check if this is a surface filter only for surface currents - if (any(t%score_bins == SCORE_CURRENT)) cycle FILTER_LOOP - - do k = 1, t%filters(j)%n_bins - id = t%filters(j)%int_bins(k) - if (surface_dict%has_key(id)) then - t%filters(j)%int_bins(k) = surface_dict%get_key(id) - else - call fatal_error("Could not find surface " // trim(to_str(id)) & - &// " specified on tally " // trim(to_str(t%id))) - end if - end do - - case (FILTER_UNIVERSE) - - do k = 1, t%filters(j)%n_bins - id = t%filters(j)%int_bins(k) - if (universe_dict%has_key(id)) then - t%filters(j)%int_bins(k) = universe_dict%get_key(id) - else - call fatal_error("Could not find universe " // trim(to_str(id)) & - &// " specified on tally " // trim(to_str(t%id))) - end if - end do - - case (FILTER_MATERIAL) - - do k = 1, t%filters(j)%n_bins - id = t%filters(j)%int_bins(k) - if (material_dict%has_key(id)) then - t%filters(j)%int_bins(k) = material_dict%get_key(id) - else - call fatal_error("Could not find material " // trim(to_str(id)) & - &// " specified on tally " // trim(to_str(t%id))) - end if - end do - - case (FILTER_MESH) - - ! The mesh filter already has been set to the index in meshes rather - ! than the user-specified id, so it doesn't need to be changed. - + if (.not. any(t % score_bins == SCORE_CURRENT)) & + call filt % initialize() + class default + call filt % initialize() end select end do FILTER_LOOP @@ -894,14 +834,11 @@ contains ! We need distribcell if any tallies have distribcell filters. do i = 1, n_tallies - do j = 1, tallies(i) % n_filters - if (tallies(i) % filters(j) % type == FILTER_DISTRIBCELL) then + do j = 1, size(tallies(i) % filters) + select type(filt => tallies(i) % filters(j) % obj) + type is (DistribcellFilter) distribcell_active = .true. - if (size(tallies(i) % filters(j) % int_bins) > 1) then - call fatal_error("A distribcell filter was specified with & - &multiple bins. This feature is not supported.") - end if - end if + end select end do end do @@ -924,13 +861,12 @@ contains ! Set the number of bins in all distribcell filters. do i = 1, n_tallies - do j = 1, tallies(i) % n_filters - associate (filt => tallies(i) % filters(j)) - if (filt % type == FILTER_DISTRIBCELL) then - ! Set the number of bins to the number of instances of the cell. - filt % n_bins = cells(filt % int_bins(1)) % instances - end if - end associate + do j = 1, size(tallies(i) % filters) + select type(filt => tallies(i) % filters(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 @@ -990,10 +926,11 @@ contains ! List all cells referenced in distribcell filters. do i = 1, n_tallies - do j = 1, tallies(i) % n_filters - if (tallies(i) % filters(j) % type == FILTER_DISTRIBCELL) then - call cell_list % add(tallies(i) % filters(j) % int_bins(1)) - end if + do j = 1, size(tallies(i) % filters) + select type(filt => tallies(i) % filters(j) % obj) + type is (DistribcellFilter) + call cell_list % add(filt % cell) + end select end do end do diff --git a/src/input_xml.F90 b/src/input_xml.F90 index 3e5a687124..c46f00b666 100644 --- a/src/input_xml.F90 +++ b/src/input_xml.F90 @@ -24,7 +24,8 @@ module input_xml 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 - use tally_header, only: TallyObject, TallyFilter + use tally_header, only: TallyObject + use tally_filter use tally_initialize, only: add_tallies use xml_interface @@ -2667,7 +2668,7 @@ contains type(ElemKeyValueCI), pointer :: pair_list type(TallyObject), pointer :: t type(RegularMesh), pointer :: m - type(TallyFilter), allocatable :: filters(:) ! temporary filters + type(TallyFilterContainer), allocatable :: filters(:) ! temporary filters type(Node), pointer :: doc => null() type(Node), pointer :: node_mesh => null() type(Node), pointer :: node_tal => null() @@ -2907,115 +2908,122 @@ contains call get_node_list(node_tal, "filter", node_filt_list) n_filters = get_list_size(node_filt_list) - if (n_filters /= 0) then + ! Allocate filters array + allocate(t % filters(n_filters)) - ! Allocate filters array - t % n_filters = n_filters - allocate(t % filters(n_filters)) + READ_FILTERS: do j = 1, n_filters + ! Get pointer to filter xml node + call get_list_item(node_filt_list, j, node_filt) - READ_FILTERS: do j = 1, n_filters - ! Get pointer to filter xml node - call get_list_item(node_filt_list, j, node_filt) + ! Convert filter type to lower case + temp_str = '' + if (check_for_node(node_filt, "type")) & + call get_node_value(node_filt, "type", temp_str) + temp_str = to_lower(temp_str) - ! Convert filter type to lower case - temp_str = '' - if (check_for_node(node_filt, "type")) & - call get_node_value(node_filt, "type", temp_str) - temp_str = to_lower(temp_str) - - ! Determine number of bins - if (check_for_node(node_filt, "bins")) then - if (temp_str == 'energy' .or. temp_str == 'energyout' .or. & - temp_str == 'mu' .or. temp_str == 'polar' .or. & - temp_str == 'azimuthal') then - n_words = get_arraysize_double(node_filt, "bins") - else - n_words = get_arraysize_integer(node_filt, "bins") - end if + ! Determine number of bins + if (check_for_node(node_filt, "bins")) then + if (temp_str == 'energy' .or. temp_str == 'energyout' .or. & + temp_str == 'mu' .or. temp_str == 'polar' .or. & + temp_str == 'azimuthal') then + n_words = get_arraysize_double(node_filt, "bins") else - call fatal_error("Bins not set in filter on tally " & - // trim(to_str(t % id))) + n_words = get_arraysize_integer(node_filt, "bins") end if + else + call fatal_error("Bins not set in filter on tally " & + // trim(to_str(t % id))) + end if - ! Determine type of filter - select case (temp_str) + ! Determine type of filter + select case (temp_str) - case ('distribcell') - - ! Set type of filter - t % filters(j) % type = FILTER_DISTRIBCELL - - ! Going to add new filters to this tally if n_words > 1 + case ('distribcell') + ! Allocate and declare the filter type + allocate(DistribcellFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % 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 + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_DISTRIBCELL) = j + case ('cell') + ! Allocate and declare the filter type + allocate(CellFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % obj) + type is (CellFilter) ! Allocate and store bins - allocate(t % filters(j) % int_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % int_bins) - - case ('cell') - ! Set type of filter - t % filters(j) % type = FILTER_CELL - - ! Set number of bins - t % filters(j) % n_bins = n_words + filt % n_bins = n_words + allocate(filt % cells(n_words)) + call get_node_array(node_filt, "bins", filt % cells) + end select + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_CELL) = j + case ('cellborn') + ! Allocate and declare the filter type + allocate(CellbornFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % obj) + type is (CellbornFilter) ! Allocate and store bins - allocate(t % filters(j) % int_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % int_bins) - - case ('cellborn') - ! Set type of filter - t % filters(j) % type = FILTER_CELLBORN - - ! Set number of bins - t % filters(j) % n_bins = n_words + filt % n_bins = n_words + allocate(filt % cells(n_words)) + call get_node_array(node_filt, "bins", filt % cells) + end select + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_CELLBORN) = j + case ('material') + ! Allocate and declare the filter type + allocate(MaterialFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % obj) + type is (MaterialFilter) ! Allocate and store bins - allocate(t % filters(j) % int_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % int_bins) - - case ('material') - ! Set type of filter - t % filters(j) % type = FILTER_MATERIAL - - ! Set number of bins - t % filters(j) % n_bins = n_words + filt % n_bins = n_words + allocate(filt % materials(n_words)) + call get_node_array(node_filt, "bins", filt % materials) + end select + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_MATERIAL) = j + case ('universe') + ! Allocate and declare the filter type + allocate(UniverseFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % obj) + type is (UniverseFilter) ! Allocate and store bins - allocate(t % filters(j) % int_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % int_bins) - - case ('universe') - ! Set type of filter - t % filters(j) % type = FILTER_UNIVERSE - - ! Set number of bins - t % filters(j) % n_bins = n_words + filt % n_bins = n_words + allocate(filt % universes(n_words)) + call get_node_array(node_filt, "bins", filt % universes) + end select + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_UNIVERSE) = j + case ('surface') + call fatal_error("Surface filter is not yet supported!") + ! Allocate and declare the filter type + allocate(SurfaceFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % obj) + type is (SurfaceFilter) ! Allocate and store bins - allocate(t % filters(j) % int_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % int_bins) + filt % n_bins = n_words + allocate(filt % surfaces(n_words)) + call get_node_array(node_filt, "bins", filt % surfaces) + end select + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_SURFACE) = j - case ('surface') - call fatal_error("Surface filter is not yet supported!") - - ! Set type of filter - t % filters(j) % type = FILTER_SURFACE - - ! Set number of bins - t % filters(j) % n_bins = n_words - - ! Allocate and store bins - allocate(t % filters(j) % int_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % int_bins) - - case ('mesh') - ! Set type of filter - t % filters(j) % type = FILTER_MESH - - ! Check to make sure multiple meshes weren't given - if (n_words /= 1) then - call fatal_error("Can only have one mesh filter specified.") - end if + case ('mesh') + ! Allocate and declare the filter type + allocate(MeshFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % 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) @@ -3032,214 +3040,220 @@ contains ! Determine number of bins -- this is assuming that the tally is ! a volume tally and not a surface current tally. If it is a ! surface current tally, the number of bins will get reset later - t % filters(j) % n_bins = product(m % dimension) + filt % n_bins = product(m % dimension) - ! Allocate and store index of mesh - allocate(t % filters(j) % int_bins(1)) - t % filters(j) % int_bins(1) = i_mesh - - case ('energy') - ! Set type of filter - t % filters(j) % type = FILTER_ENERGYIN - - ! Set number of bins - t % filters(j) % n_bins = n_words - 1 + ! Store the index of the mesh + filt % mesh = i_mesh + end select + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_MESH) = j + case ('energy') + ! Allocate and declare the filter type + allocate(EnergyFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % obj) + type is (EnergyFilter) ! Allocate and store bins - allocate(t % filters(j) % real_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % real_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 + ! 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 == energy_groups + 1) then - if (all(t % filters(j) % real_bins == & - energy_bins(energy_groups + 1:1:-1))) & - t % energy_matches_groups = .true. + if (all(filt % bins == energy_bins(energy_groups + 1:1:-1))) & + then + filt % matches_transport_groups = .true. + end if end if end if + end select + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_ENERGYIN) = j - case ('energyout') - ! Set type of filter - t % filters(j) % type = FILTER_ENERGYOUT - - ! Set number of bins - t % filters(j) % n_bins = n_words - 1 - + case ('energyout') + ! Allocate and declare the filter type + allocate(EnergyoutFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % obj) + type is (EnergyoutFilter) ! Allocate and store bins - allocate(t % filters(j) % real_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % real_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 + ! 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 == energy_groups + 1) then - if (all(t % filters(j) % real_bins == & - energy_bins(energy_groups + 1:1:-1))) & - t % energyout_matches_groups = .true. + if (all(filt % bins == energy_bins(energy_groups + 1:1:-1))) & + then + filt % matches_transport_groups = .true. + end if end if end if + end select + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_ENERGYOUT) = j - ! Set to analog estimator - t % estimator = ESTIMATOR_ANALOG + ! Set to analog estimator + t % estimator = ESTIMATOR_ANALOG - case ('delayedgroup') - ! Check to see if running in MG mode, because if so, the current - ! system isnt set up yet to support delayed group data and thus - ! these tallies - if (.not. run_CE) then - call fatal_error("delayedgroup filter on tally " & - // trim(to_str(t % id)) // " not yet supported& - & for multi-group mode.") - end if - - ! Set type of filter - t % filters(j) % type = FILTER_DELAYEDGROUP - - ! Set number of bins - t % filters(j) % n_bins = n_words + case ('delayedgroup') + ! Check to see if running in MG mode, because if so, the current + ! system isnt set up yet to support delayed group data and thus + ! these tallies + if (.not. run_CE) then + call fatal_error("delayedgroup filter on tally " & + // trim(to_str(t % id)) // " not yet supported& + & for multi-group mode.") + end if + ! Allocate and declare the filter type + allocate(DelayedGroupFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % obj) + type is (DelayedGroupFilter) ! Allocate and store bins - allocate(t % filters(j) % int_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % int_bins) + filt % n_bins = n_words + allocate(filt % groups(n_words)) + call get_node_array(node_filt, "bins", filt % groups) - ! Check bins to make sure all are between 1 and MAX_DELAYED_GROUPS + ! Check that bins are all are between 1 and MAX_DELAYED_GROUPS do d = 1, n_words - if (t % filters(j) % int_bins(d) < 1 .or. & - t % filters(j) % int_bins(d) > MAX_DELAYED_GROUPS) then + if (filt % groups(d) < 1 .or. & + filt % groups(d) > MAX_DELAYED_GROUPS) then call fatal_error("Encountered delayedgroup bin with index " & - // trim(to_str(t % filters(j) % int_bins(d))) // " that is& - & outside the range of 1 to MAX_DELAYED_GROUPS ( " & + // 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 + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_DELAYEDGROUP) = j - case ('mu') - ! Set type of filter - t % filters(j) % type = FILTER_MU - - ! Set number of bins - t % filters(j) % n_bins = n_words - 1 - + case ('mu') + ! Allocate and declare the filter type + allocate(MuFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % obj) + type is (MuFilter) ! Allocate and store bins - allocate(t % filters(j) % real_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % real_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 subivide [-1,1] evenly with the input being the number of 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(t % filters(j) % real_bins(1)) + Nangle = int(filt % bins(1)) if (Nangle > 1) then - t % filters(j) % n_bins = Nangle + filt % n_bins = Nangle dangle = TWO / real(Nangle,8) - deallocate(t % filters(j) % real_bins) - allocate(t % filters(j) % real_bins(Nangle + 1)) + deallocate(filt % bins) + allocate(filt % bins(Nangle + 1)) do iangle = 1, Nangle - t % filters(j) % real_bins(iangle) = -ONE + (iangle - 1) * dangle + filt % bins(iangle) = -ONE + (iangle - 1) * dangle end do - t % filters(j) % real_bins(Nangle + 1) = ONE + filt % bins(Nangle + 1) = ONE else call fatal_error("Number of bins for mu filter must be& - & greater than 1 on tally " // trim(to_str(t % id)) // ".") + & greater than 1 on tally " & + // trim(to_str(t % id)) // ".") end if - end if + end select + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_MU) = j - ! Set to analog estimator - t % estimator = ESTIMATOR_ANALOG - - case ('polar') - ! Set type of filter - t % filters(j) % type = FILTER_POLAR - - ! Set number of bins - t % filters(j) % n_bins = n_words - 1 + ! Set to analog estimator + t % estimator = ESTIMATOR_ANALOG + case ('polar') + ! Allocate and declare the filter type + allocate(PolarFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % obj) + type is (PolarFilter) ! Allocate and store bins - allocate(t % filters(j) % real_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % real_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 subivide [0,pi] evenly with the input being the number of 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(t % filters(j) % real_bins(1)) + Nangle = int(filt % bins(1)) if (Nangle > 1) then - t % filters(j) % n_bins = Nangle + filt % n_bins = Nangle dangle = PI / real(Nangle,8) - deallocate(t % filters(j) % real_bins) - allocate(t % filters(j) % real_bins(Nangle + 1)) + deallocate(filt % bins) + allocate(filt % bins(Nangle + 1)) do iangle = 1, Nangle - t % filters(j) % real_bins(iangle) = (iangle - 1) * dangle + filt % bins(iangle) = (iangle - 1) * dangle end do - t % filters(j) % real_bins(Nangle + 1) = PI + filt % bins(Nangle + 1) = PI else - call fatal_error("Number of bins for polar filter must be& - & greater than 1 on tally " // trim(to_str(t % id)) // ".") + call fatal_error("Number of bins for mu filter must be& + & greater than 1 on tally " & + // trim(to_str(t % id)) // ".") end if - end if + end select + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_POLAR) = j - case ('azimuthal') - ! Set type of filter - t % filters(j) % type = FILTER_AZIMUTHAL - - ! Set number of bins - t % filters(j) % n_bins = n_words - 1 - + case ('azimuthal') + ! Allocate and declare the filter type + allocate(AzimuthalFilter::t % filters(j) % obj) + select type (filt => t % filters(j) % obj) + type is (AzimuthalFilter) ! Allocate and store bins - allocate(t % filters(j) % real_bins(n_words)) - call get_node_array(node_filt, "bins", t % filters(j) % real_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 sub-divide [-pi,pi) evenly with the input being the number of + ! 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(t % filters(j) % real_bins(1)) + Nangle = int(filt % bins(1)) if (Nangle > 1) then - t % filters(j) % n_bins = Nangle + filt % n_bins = Nangle dangle = TWO * PI / real(Nangle,8) - deallocate(t % filters(j) % real_bins) - allocate(t % filters(j) % real_bins(Nangle + 1)) + deallocate(filt % bins) + allocate(filt % bins(Nangle + 1)) do iangle = 1, Nangle - t % filters(j) % real_bins(iangle) = -PI + (iangle - 1) * dangle + filt % bins(iangle) = -PI + (iangle - 1) * dangle end do - t % filters(j) % real_bins(Nangle + 1) = PI + filt % bins(Nangle + 1) = PI else - call fatal_error("Number of bins for azimuthal filter must be& - & greater than 1 on tally " // trim(to_str(t % id)) // ".") + call fatal_error("Number of bins for mu filter must be& + & greater than 1 on tally " & + // trim(to_str(t % id)) // ".") end if - end if - - case default - ! Specified tally filter is invalid, raise error - call fatal_error("Unknown filter type '" & - // trim(temp_str) // "' on tally " & - // trim(to_str(t % id)) // ".") - end select + ! Set the filter index in the tally find_filter array + t % find_filter(FILTER_AZIMUTHAL) = j - ! Set find_filter, e.g. if filter(3) has type FILTER_CELL, then - ! find_filter(FILTER_CELL) would be set to 3. + case default + ! Specified tally filter is invalid, raise error + call fatal_error("Unknown filter type '" & + // trim(temp_str) // "' on tally " & + // trim(to_str(t % id)) // ".") - t % find_filter(t % filters(j) % type) = j + end select - end do READ_FILTERS + end do READ_FILTERS - ! Check that both cell and surface weren't specified - if (t % find_filter(FILTER_CELL) > 0 .and. & - t % find_filter(FILTER_SURFACE) > 0) then - call fatal_error("Cannot specify both cell and surface filters for & - &tally " // trim(to_str(t % id))) - end if - - else - ! No filters were specified - t % n_filters = 0 + ! Check that both cell and surface weren't specified + if (t % find_filter(FILTER_CELL) > 0 .and. & + t % find_filter(FILTER_SURFACE) > 0) then + call fatal_error("Cannot specify both cell and surface filters for & + &tally " // trim(to_str(t % id))) end if ! ======================================================================= @@ -3275,8 +3289,9 @@ contains if (trim(sarray(j)) == 'total') then ! Check if a delayedgroup filter is present for this tally - do l = 1, t % n_filters - if (t % filters(l) % type == FILTER_DELAYEDGROUP) then + do l = 1, size(t % filters) + select type(filt => t % filters(l) % obj) + type is (DelayedGroupFilter) call warning("A delayedgroup filter was used on a total & &nuclide tally. Cross section libraries are not & &guaranteed to have the same delayed group structure & @@ -3285,7 +3300,7 @@ contains &all isotopes while the JEFF 3.1.1 library has the same & &delayed group structure across all isotopes. Use with & &caution!") - end if + end select end do t % nuclide_bins(j) = -1 @@ -3334,8 +3349,9 @@ contains t % n_nuclide_bins = 1 ! Check if a delayedgroup filter is present for this tally - do l = 1, t % n_filters - if (t % filters(l) % type == FILTER_DELAYEDGROUP) then + do l = 1, size(t % filters) + select type(filt => t % filters(l) % obj) + type is (DelayedGroupFilter) call warning("A delayedgroup filter was used on a total nuclide & &tally. Cross section libraries are not guaranteed to have the& & same delayed group structure across all isotopes. In & @@ -3343,7 +3359,7 @@ contains &group structure across all isotopes while the JEFF 3.1.1 & &library has the same delayed group structure across all & &isotopes. Use with caution!") - end if + end select end do end if @@ -3659,36 +3675,42 @@ contains &filter.") end if - ! Get pointer to mesh - i_mesh = t % filters(k) % int_bins(1) - m => meshes(i_mesh) + ! Declare the type of the mesh filter + select type(filt => t % filters(k) % obj) + type is (MeshFilter) - ! We need to increase the dimension by one since we also need - ! currents coming into and out of the boundary mesh cells. - t % filters(k) % n_bins = product(m % dimension + 1) + ! Get pointer to mesh + i_mesh = filt % mesh + m => meshes(i_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) + end select ! Copy filters to temporary array - allocate(filters(t % n_filters + 1)) - filters(1:t % n_filters) = t % filters + allocate(filters(size(t % filters) + 1)) + filters(1:size(t % filters)) = t % filters ! Move allocation back -- filters becomes deallocated during ! this call call move_alloc(FROM=filters, TO=t%filters) ! Add surface filter - t % n_filters = t % n_filters + 1 - t % filters(t % n_filters) % type = FILTER_SURFACE - t % filters(t % n_filters) % n_bins = 2 * m % n_dimension - allocate(t % filters(t % n_filters) % int_bins(& - 2 * m % n_dimension)) - if (m % n_dimension == 2) then - t % filters(t % n_filters) % int_bins = (/ IN_RIGHT, & - OUT_RIGHT, IN_FRONT, OUT_FRONT /) - elseif (m % n_dimension == 3) then - t % filters(t % n_filters) % int_bins = (/ IN_RIGHT, & - OUT_RIGHT, IN_FRONT, OUT_FRONT, IN_TOP, OUT_TOP /) - end if - t % find_filter(FILTER_SURFACE) = t % n_filters + n_filters = size(t % filters) + allocate(SurfaceFilter :: t % filters(n_filters) % obj) + select type (filt => t % filters(size(t % filters)) % obj) + type is (SurfaceFilter) + filt % n_bins = 2 * m % n_dimension + allocate(filt % surfaces(2 * m % n_dimension)) + if (m % n_dimension == 2) then + filt % surfaces = (/ IN_RIGHT, OUT_RIGHT, IN_FRONT, OUT_FRONT /) + elseif (m % n_dimension == 3) then + filt % surfaces = (/ IN_RIGHT, OUT_RIGHT, IN_FRONT, OUT_FRONT,& + IN_TOP, OUT_TOP /) + end if + end select + t % find_filter(FILTER_SURFACE) = size(t % filters) case ('events') t % score_bins(j) = SCORE_EVENTS @@ -4398,9 +4420,11 @@ contains &meshlines on plot " // trim(to_str(pl % id))) end if - i_mesh = cmfd_tallies(1) % & - filters(cmfd_tallies(1) % find_filter(FILTER_MESH)) % & - int_bins(1) + select type(filt => cmfd_tallies(1) % & + filters(cmfd_tallies(1) % find_filter(FILTER_MESH)) % obj) + type is (MeshFilter) + i_mesh = filt % mesh + end select pl % meshlines_mesh => meshes(i_mesh) case ('entropy') diff --git a/src/mesh.F90 b/src/mesh.F90 index 4ec84345ba..0b227f4f5d 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -290,34 +290,42 @@ contains ! Check if line intersects left surface -- calculate the intersection point ! y - yi = y0 + (xm0 - x0) * (y1 - y0) / (x1 - x0) - if (yi >= ym0 .and. yi < ym1) then - intersects = .true. - return + 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 - xi = x0 + (ym0 - y0) * (x1 - x0) / (y1 - y0) - if (xi >= xm0 .and. xi < xm1) then - intersects = .true. - return + 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 - yi = y0 + (xm1 - x0) * (y1 - y0) / (x1 - x0) - if (yi >= ym0 .and. yi < ym1) then - intersects = .true. - return + 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 - xi = x0 + (ym1 - y0) * (x1 - x0) / (y1 - y0) - if (xi >= xm0 .and. xi < xm1) then - intersects = .true. - return + 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 @@ -359,56 +367,68 @@ contains ! Check if line intersects left surface -- calculate the intersection point ! (y,z) - 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 + 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) - 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 + 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) - 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 + 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) - 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 + 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) - 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 + 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) - 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 + 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 diff --git a/src/output.F90 b/src/output.F90 index 22733a3051..9b9388fc74 100644 --- a/src/output.F90 +++ b/src/output.F90 @@ -17,6 +17,7 @@ module output use sab_header, only: SAlphaBeta use string, only: to_upper, to_str use tally_header, only: TallyObject + use tally_filter implicit none @@ -736,7 +737,6 @@ contains integer :: k ! loop index for scoring bins integer :: n ! loop index for nuclides integer :: l ! loop index for user scores - integer :: type ! type of tally filter integer :: indent ! number of spaces to preceed output integer :: filter_index ! index in results array for filters integer :: score_index ! scoring bin index @@ -747,7 +747,6 @@ contains real(8) :: t_value ! t-values for confidence intervals real(8) :: alpha ! significance level for CI character(MAX_FILE_LEN) :: filename ! name of output file - character(16) :: filter_name(N_FILTER_TYPES) ! names of tally filters 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 @@ -756,21 +755,6 @@ contains ! Skip if there are no tallies if (n_tallies == 0) return - ! Initialize names for tally filter types - filter_name(FILTER_UNIVERSE) = "Universe" - filter_name(FILTER_MATERIAL) = "Material" - filter_name(FILTER_DISTRIBCELL) = "Distributed Cell" - filter_name(FILTER_CELL) = "Cell" - filter_name(FILTER_CELLBORN) = "Birth Cell" - filter_name(FILTER_SURFACE) = "Surface" - filter_name(FILTER_MESH) = "Mesh" - filter_name(FILTER_ENERGYIN) = "Incoming Energy" - filter_name(FILTER_ENERGYOUT) = "Outgoing Energy" - filter_name(FILTER_MU) = "Change-in-Angle" - filter_name(FILTER_POLAR) = "Polar Angle" - filter_name(FILTER_AZIMUTHAL) = "Azimuthal Angle" - filter_name(FILTER_DELAYEDGROUP) = "Delayed Group" - ! Initialize names for scores score_names(abs(SCORE_FLUX)) = "Flux" score_names(abs(SCORE_TOTAL)) = "Total Reaction Rate" @@ -841,14 +825,14 @@ contains ! to be used for a given tally. ! Initialize bins, filter level, and indentation - matching_bins(1:t%n_filters) = 0 + matching_bins(1:size(t % filters)) = 0 j = 1 indent = 0 print_bin: do find_bin: do ! Check for no filters - if (t % n_filters == 0) exit find_bin + if (size(t % filters) == 0) exit find_bin ! Increment bin combination matching_bins(j) = matching_bins(j) + 1 @@ -856,7 +840,7 @@ contains ! ================================================================= ! REACHED END OF BINS FOR THIS FILTER, MOVE TO NEXT FILTER - if (matching_bins(j) > t % filters(j) % n_bins) then + if (matching_bins(j) > t % filters(j) % obj % n_bins) then ! If this is the first filter, then exit if (j == 1) exit print_bin @@ -869,12 +853,11 @@ contains else ! Check if this is last filter - if (j == t % n_filters) exit find_bin + if (j == size(t % filters)) exit find_bin ! Print current filter information - type = t % filters(j) % type - write(UNIT=unit_tally, FMT='(1X,2A,1X,A)') repeat(" ", indent), & - trim(filter_name(type)), trim(get_label(t, j)) + write(UNIT=unit_tally, FMT='(1X,2A)') repeat(" ", indent), & + trim(t % filters(j) % obj % text_label(matching_bins(j))) indent = indent + 2 j = j + 1 end if @@ -882,25 +865,25 @@ contains end do find_bin ! Print filter information - if (t % n_filters > 0) then - type = t % filters(j) % type - write(UNIT=unit_tally, FMT='(1X,2A,1X,A)') repeat(" ", indent), & - trim(filter_name(type)), trim(get_label(t, j)) + if (size(t % filters) > 0) then + write(UNIT=unit_tally, FMT='(1X,2A)') repeat(" ", indent), & + trim(t % filters(j) % obj % text_label(matching_bins(j))) end if ! Determine scoring index for this bin combination -- note that unlike ! in the score_tally subroutine, we have to use max(bins,1) since all ! bins below the lowest filter level will be zeros - if (t % n_filters > 0) then - filter_index = sum((max(matching_bins(1:t%n_filters),1) - 1) * t % stride) + 1 + if (size(t % filters) > 0) then + filter_index = sum((max(matching_bins(1:size(t % filters)),1) - 1) & + * t % stride) + 1 else filter_index = 1 end if ! Write results for this filter bin combination score_index = 0 - if (t % n_filters > 0) indent = indent + 2 + if (size(t % filters) > 0) indent = indent + 2 do n = 1, t % n_nuclide_bins ! Write label for nuclide i_nuclide = t % nuclide_bins(n) @@ -972,7 +955,7 @@ contains end do indent = indent - 2 - if (t % n_filters == 0) exit print_bin + if (size(t % filters) == 0) exit print_bin end do print_bin @@ -1009,16 +992,19 @@ contains ! Get pointer to mesh i_filter_mesh = t % find_filter(FILTER_MESH) i_filter_surf = t % find_filter(FILTER_SURFACE) - m => meshes(t % filters(i_filter_mesh) % int_bins(1)) + select type(filt => t % filters(i_filter_mesh) % obj) + type is (MeshFilter) + m => meshes(filt % mesh) + end select ! initialize bins array - matching_bins(1:t%n_filters) = 1 + matching_bins(1:size(t % filters)) = 1 ! determine how many energy in bins there are i_filter_ein = t % find_filter(FILTER_ENERGYIN) if (i_filter_ein > 0) then print_ebin = .true. - n = t % filters(i_filter_ein) % n_bins + n = t % filters(i_filter_ein) % obj % n_bins else print_ebin = .false. n = 1 @@ -1041,22 +1027,25 @@ contains matching_bins(i_filter_ein) = l ! Write incoming energy bin - write(UNIT=unit_tally, FMT='(3X,A,1X,A)') & - "Incoming Energy", trim(get_label(t, i_filter_ein)) + write(UNIT=unit_tally, FMT='(3X,A)') & + trim(t % filters(i_filter_ein) % obj % text_label( & + matching_bins(i_filter_ein))) end if ! Left Surface matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, (/ i-1, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_RIGHT - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Outgoing Current to Left", & to_str(t % results(1,filter_index) % sum), & trim(to_str(t % results(1,filter_index) % sum_sq)) matching_bins(i_filter_surf) = OUT_RIGHT - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Incoming Current from Left", & to_str(t % results(1,filter_index) % sum), & @@ -1066,14 +1055,16 @@ contains matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, (/ i, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_RIGHT - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Incoming Current from Right", & to_str(t % results(1,filter_index) % sum), & trim(to_str(t % results(1,filter_index) % sum_sq)) matching_bins(i_filter_surf) = OUT_RIGHT - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Outgoing Current to Right", & to_str(t % results(1,filter_index) % sum), & @@ -1083,14 +1074,16 @@ contains matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, (/ i, j-1, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_FRONT - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Outgoing Current to Back", & to_str(t % results(1,filter_index) % sum), & trim(to_str(t % results(1,filter_index) % sum_sq)) matching_bins(i_filter_surf) = OUT_FRONT - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Incoming Current from Back", & to_str(t % results(1,filter_index) % sum), & @@ -1100,14 +1093,16 @@ contains matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, (/ i, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_FRONT - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Incoming Current from Front", & to_str(t % results(1,filter_index) % sum), & trim(to_str(t % results(1,filter_index) % sum_sq)) matching_bins(i_filter_surf) = OUT_FRONT - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Outgoing Current to Front", & to_str(t % results(1,filter_index) % sum), & @@ -1117,14 +1112,16 @@ contains matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, (/ i, j, k-1 /) + 1, .true.) matching_bins(i_filter_surf) = IN_TOP - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Outgoing Current to Bottom", & to_str(t % results(1,filter_index) % sum), & trim(to_str(t % results(1,filter_index) % sum_sq)) matching_bins(i_filter_surf) = OUT_TOP - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Incoming Current from Bottom", & to_str(t % results(1,filter_index) % sum), & @@ -1134,14 +1131,16 @@ contains matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, (/ i, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_TOP - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Incoming Current from Top", & to_str(t % results(1,filter_index) % sum), & trim(to_str(t % results(1,filter_index) % sum_sq)) matching_bins(i_filter_surf) = OUT_TOP - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 write(UNIT=unit_tally, FMT='(5X,A,T35,A,"+/- ",A)') & "Outgoing Current to Top", & to_str(t % results(1,filter_index) % sum), & @@ -1154,329 +1153,4 @@ contains end subroutine write_surface_current -!=============================================================================== -! GET_LABEL returns a label for a cell/surface/etc given a tally, filter type, -! and corresponding bin -!=============================================================================== - - function get_label(t, i_filter) result(label) - type(TallyObject), intent(in) :: t ! tally object - integer, intent(in) :: i_filter ! index in filters array - character(MAX_LINE_LEN) :: label ! user-specified identifier - - integer :: i ! index in cells/surfaces/etc array - integer :: bin - integer :: offset - integer, allocatable :: ijk(:) ! indices in mesh - real(8) :: E0 ! lower bound for energy bin - real(8) :: E1 ! upper bound for energy bin - type(RegularMesh), pointer :: m - type(Universe), pointer :: univ - - bin = matching_bins(i_filter) - - select case(t % filters(i_filter) % type) - case (FILTER_UNIVERSE) - i = t % filters(i_filter) % int_bins(bin) - label = to_str(universes(i) % id) - case (FILTER_MATERIAL) - i = t % filters(i_filter) % int_bins(bin) - label = to_str(materials(i) % id) - case (FILTER_CELL, FILTER_CELLBORN) - i = t % filters(i_filter) % int_bins(bin) - label = to_str(cells(i) % id) - case (FILTER_DISTRIBCELL) - label = '' - univ => universes(BASE_UNIVERSE) - offset = 0 - call find_offset(t % filters(i_filter) % int_bins(1), & - univ, bin-1, offset, label) - case (FILTER_SURFACE) - i = t % filters(i_filter) % int_bins(bin) - label = to_str(surfaces(i)%obj%id) - case (FILTER_MESH) - m => meshes(t % filters(i_filter) % int_bins(1)) - allocate(ijk(m % n_dimension)) - call bin_to_mesh_indices(m, bin, ijk) - if (m % n_dimension == 2) then - label = "Index (" // trim(to_str(ijk(1))) // ", " // & - trim(to_str(ijk(2))) // ")" - elseif (m % n_dimension == 3) then - label = "Index (" // trim(to_str(ijk(1))) // ", " // & - trim(to_str(ijk(2))) // ", " // trim(to_str(ijk(3))) // ")" - end if - case (FILTER_ENERGYIN, FILTER_ENERGYOUT, FILTER_MU, FILTER_POLAR, & - FILTER_AZIMUTHAL) - E0 = t % filters(i_filter) % real_bins(bin) - E1 = t % filters(i_filter) % real_bins(bin + 1) - label = "[" // trim(to_str(E0)) // ", " // trim(to_str(E1)) // ")" - case (FILTER_DELAYEDGROUP) - i = t % filters(i_filter) % int_bins(bin) - label = to_str(i) - end select - - end function get_label - -!=============================================================================== -! FIND_OFFSET 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(goal, univ, final, offset, path) - - integer, intent(in) :: goal ! The target cell index - type(Universe), intent(in) :: univ ! Universe to begin search - integer, intent(in) :: final ! 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 - 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(goal) % distribcell_index - - n = univ % n_cells - - ! Write to the geometry stack - if (univ%id == 0) then - path = trim(path) // to_str(univ%id) - else - path = trim(path) // "->" // 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) == goal .and. offset == final) then - c => cells(univ % cells(i)) - path = trim(path) // "->" // 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. - - cell_index = univ % cells(i) - c => cells(cell_index) - - 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 - - cell_index = univ % cells(j) - c => cells(cell_index) - - ! Skip normal cells which do not have offsets - if (c % type == CELL_NORMAL) then - cycle - end if - - ! 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 /= CELL_NORMAL) 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 == CELL_FILL) 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 (final < temp_offset + offset) then - this_cell = .true. - end if - end if - end if - - if (n == 1 .and. c % type /= CELL_NORMAL) 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) // "->" // to_str(c%id) - - ! ==================================================================== - ! CELL CONTAINS LOWER UNIVERSE, RECURSIVELY FIND CELL - if (c % type == CELL_FILL) then - - ! Enter this cell to update the current offset - offset = c % offset(map) + offset - - next_univ => universes(c % fill) - call find_offset(goal, next_univ, final, offset, path) - return - - ! ==================================================================== - ! CELL CONTAINS LATTICE, RECURSIVELY FIND CELL - elseif (c % type == CELL_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) // "->" // 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 (final >= 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)) - path = trim(path) // "(" // trim(to_str(k)) // & - "," // trim(to_str(l)) // "," // & - trim(to_str(m)) // ")" - call find_offset(goal, next_univ, final, 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)) - path = trim(path) // "(" // trim(to_str(old_k)) // & - "," // trim(to_str(old_l)) // "," // & - trim(to_str(old_m)) // ")" - call find_offset(goal, next_univ, final, offset, path) - return - end if - - end do - end do - end do - - ! ================================================================== - ! HEXAGONAL LATTICES - type is (HexLattice) - - ! Write to the geometry stack - path = trim(path) // "->" // 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 (final >= 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)) - path = trim(path) // "(" // & - trim(to_str(k - lat % n_rings)) // "," // & - trim(to_str(l - lat % n_rings)) // "," // & - trim(to_str(m)) // ")" - call find_offset(goal, next_univ, final, 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)) - path = trim(path) // "(" // & - trim(to_str(old_k - lat % n_rings)) // "," // & - trim(to_str(old_l - lat % n_rings)) // "," // & - trim(to_str(old_m)) // ")" - call find_offset(goal, next_univ, final, 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 output diff --git a/src/particle_header.F90 b/src/particle_header.F90 index a313c6ed58..ee854aea37 100644 --- a/src/particle_header.F90 +++ b/src/particle_header.F90 @@ -59,10 +59,13 @@ module particle_header logical :: alive ! is particle alive? ! Pre-collision physical data - real(8) :: last_xyz(3) ! previous coordinates - real(8) :: last_uvw(3) ! previous direction coordinates - real(8) :: last_wgt ! pre-collision particle weight - real(8) :: absorb_wgt ! weight absorbed for survival biasing + real(8) :: last_xyz_current(3) ! coordinates of the last collision or + ! reflective/periodic surface crossing + ! for current tallies + real(8) :: last_xyz(3) ! previous coordinates + real(8) :: last_uvw(3) ! previous direction coordinates + real(8) :: last_wgt ! pre-collision particle weight + real(8) :: absorb_wgt ! weight absorbed for survival biasing ! What event last took place logical :: fission ! did the particle cause implicit fission @@ -193,20 +196,21 @@ contains call this % initialize() ! copy attributes from source bank site - this % wgt = src % wgt - this % last_wgt = src % wgt - this % coord(1) % xyz = src % xyz - this % coord(1) % uvw = src % uvw - this % last_xyz = src % xyz - this % last_uvw = src % uvw + this % wgt = src % wgt + this % last_wgt = src % wgt + this % coord(1) % xyz = src % xyz + this % coord(1) % uvw = src % uvw + this % last_xyz_current = src % xyz + this % last_xyz = src % xyz + this % last_uvw = src % uvw if (run_CE) then - this % E = src % E + this % E = src % E else - this % g = int(src % E) - this % last_g = int(src % E) - this % E = energy_bin_avg(this % g) + this % g = int(src % E) + this % last_g = int(src % E) + this % E = energy_bin_avg(this % g) end if - this % last_E = this % E + this % last_E = this % E end subroutine initialize_from_source diff --git a/src/particle_restart.F90 b/src/particle_restart.F90 index 846d37160d..a1c32f723e 100644 --- a/src/particle_restart.F90 +++ b/src/particle_restart.F90 @@ -107,11 +107,12 @@ contains end if ! Set particle last attributes - p % last_wgt = p % wgt - p % last_xyz = p % coord(1)%xyz - p % last_uvw = p % coord(1)%uvw - p % last_E = p % E - p % last_g = p % g + p % last_wgt = p % wgt + p % last_xyz_current = p % coord(1)%xyz + p % last_xyz = p % coord(1)%xyz + p % last_uvw = p % coord(1)%uvw + p % last_E = p % E + p % last_g = p % g ! Close hdf5 file call file_close(file_id) diff --git a/src/state_point.F90 b/src/state_point.F90 index 87ef4ead77..abe034897a 100644 --- a/src/state_point.F90 +++ b/src/state_point.F90 @@ -237,57 +237,13 @@ contains end select call write_dataset(tally_group, "n_realizations", & tally % n_realizations) - call write_dataset(tally_group, "n_filters", tally % n_filters) + call write_dataset(tally_group, "n_filters", size(tally % filters)) ! Write filter information - FILTER_LOOP: do j = 1, tally % n_filters + FILTER_LOOP: do j = 1, size(tally % filters) filter_group = create_group(tally_group, "filter " // & trim(to_str(j))) - - ! Write name of type - select case (tally % filters(j) % type) - case(FILTER_UNIVERSE) - call write_dataset(filter_group, "type", "universe") - case(FILTER_MATERIAL) - call write_dataset(filter_group, "type", "material") - case(FILTER_CELL) - call write_dataset(filter_group, "type", "cell") - case(FILTER_CELLBORN) - call write_dataset(filter_group, "type", "cellborn") - case(FILTER_SURFACE) - call write_dataset(filter_group, "type", "surface") - case(FILTER_MESH) - call write_dataset(filter_group, "type", "mesh") - case(FILTER_ENERGYIN) - call write_dataset(filter_group, "type", "energy") - case(FILTER_ENERGYOUT) - call write_dataset(filter_group, "type", "energyout") - case(FILTER_MU) - call write_dataset(filter_group, "type", "mu") - case(FILTER_POLAR) - call write_dataset(filter_group, "type", "polar") - case(FILTER_AZIMUTHAL) - call write_dataset(filter_group, "type", "azimuthal") - case(FILTER_DISTRIBCELL) - call write_dataset(filter_group, "type", "distribcell") - case(FILTER_DELAYEDGROUP) - call write_dataset(filter_group, "type", "delayedgroup") - end select - - call write_dataset(filter_group, "n_bins", & - tally % filters(j) % n_bins) - if (tally % filters(j) % type == FILTER_ENERGYIN .or. & - tally % filters(j) % type == FILTER_ENERGYOUT .or. & - tally % filters(j) % type == FILTER_MU .or. & - tally % filters(j) % type == FILTER_POLAR .or. & - tally % filters(j) % type == FILTER_AZIMUTHAL) then - call write_dataset(filter_group, "bins", & - tally % filters(j) % real_bins) - else - call write_dataset(filter_group, "bins", & - tally % filters(j) % int_bins) - end if - + call tally % filters(j) % obj % to_statepoint(filter_group) call close_group(filter_group) end do FILTER_LOOP diff --git a/src/summary.F90 b/src/summary.F90 index 9ad9aa23c0..b02336d97e 100644 --- a/src/summary.F90 +++ b/src/summary.F90 @@ -3,7 +3,7 @@ module summary use constants use endf, only: reaction_name use geometry_header, only: Cell, Universe, Lattice, RectLattice, & - &HexLattice, BASE_UNIVERSE + &HexLattice use global use hdf5_interface use material_header, only: Material @@ -13,7 +13,6 @@ module summary use surface_header use string, only: to_str use tally_header, only: TallyObject - use output, only: find_offset use hdf5 @@ -584,10 +583,6 @@ contains type(RegularMesh), pointer :: m type(TallyObject), pointer :: t - integer :: offset ! distibcell offset - character(MAX_LINE_LEN), allocatable :: paths(:) ! distribcell paths array - character(MAX_LINE_LEN) :: path ! distribcell path - tallies_group = create_group(file_id, "tallies") ! Write total number of meshes @@ -628,74 +623,11 @@ contains call write_dataset(tally_group, "name", t%name) ! Write number of filters - call write_dataset(tally_group, "n_filters", t%n_filters) + call write_dataset(tally_group, "n_filters", size(t % filters)) - FILTER_LOOP: do j = 1, t % n_filters + FILTER_LOOP: do j = 1, size(t % filters) filter_group = create_group(tally_group, "filter " // trim(to_str(j))) - - ! Write number of bins for this filter - call write_dataset(filter_group, "n_bins", t % filters(j) % n_bins) - - ! Write filter bins - if (t % filters(j) % type == FILTER_ENERGYIN .or. & - t % filters(j)% type == FILTER_ENERGYOUT .or. & - t % filters(j) % type == FILTER_MU .or. & - t % filters(j) % type == FILTER_POLAR .or. & - t % filters(j) % type == FILTER_AZIMUTHAL) then - call write_dataset(filter_group, "bins", t % filters(j) % real_bins) - else - call write_dataset(filter_group, "bins", t % filters(j) % int_bins) - end if - - ! Write paths to reach each distribcell instance - if (t % filters(j) % type == FILTER_DISTRIBCELL) then - ! Allocate array of strings for each distribcell path - allocate(paths(t % filters(j) % n_bins)) - - ! Store path for each distribcell instance - do k = 1, t % filters(j) % n_bins - path = '' - offset = 1 - call find_offset(t % filters(j) % int_bins(1), & - universes(BASE_UNIVERSE), k, offset, path) - paths(k) = path - end do - - ! Write array of distribcell paths to summary file - call write_dataset(filter_group, "paths", paths) - deallocate(paths) - end if - - ! Write name of type - select case (t%filters(j)%type) - case(FILTER_UNIVERSE) - call write_dataset(filter_group, "type", "universe") - case(FILTER_MATERIAL) - call write_dataset(filter_group, "type", "material") - case(FILTER_CELL) - call write_dataset(filter_group, "type", "cell") - case(FILTER_CELLBORN) - call write_dataset(filter_group, "type", "cellborn") - case(FILTER_SURFACE) - call write_dataset(filter_group, "type", "surface") - case(FILTER_MESH) - call write_dataset(filter_group, "type", "mesh") - case(FILTER_ENERGYIN) - call write_dataset(filter_group, "type", "energy") - case(FILTER_ENERGYOUT) - call write_dataset(filter_group, "type", "energyout") - case(FILTER_DISTRIBCELL) - call write_dataset(filter_group, "type", "distribcell") - case(FILTER_MU) - call write_dataset(filter_group, "type", "mu") - case(FILTER_POLAR) - call write_dataset(filter_group, "type", "polar") - case(FILTER_AZIMUTHAL) - call write_dataset(filter_group, "type", "azimuthal") - case(FILTER_DELAYEDGROUP) - call write_dataset(filter_group, "type", "delayedgroup") - end select - + call t % filters(j) % obj % to_summary(filter_group) call close_group(filter_group) end do FILTER_LOOP diff --git a/src/tally.F90 b/src/tally.F90 index 2c77119173..ec46a61940 100644 --- a/src/tally.F90 +++ b/src/tally.F90 @@ -14,7 +14,8 @@ module tally use particle_header, only: LocalCoord, Particle use search, only: binary_search use string, only: to_str - use tally_header, only: TallyResult, TallyMapItem, TallyMapElement + use tally_header, only: TallyResult + use tally_filter #ifdef MPI use message_passing @@ -28,7 +29,6 @@ module tally procedure(score_general_), pointer :: score_general => null() procedure(score_analog_tally_), pointer :: score_analog_tally => null() - procedure(get_scoring_bins_), pointer :: get_scoring_bins => null() abstract interface subroutine score_general_(p, t, start_index, filter_index, i_nuclide, & @@ -48,13 +48,6 @@ module tally import Particle type(Particle), intent(in) :: p end subroutine score_analog_tally_ - - subroutine get_scoring_bins_(p, i_tally, found_bin) - import Particle - type(Particle), intent(in) :: p - integer, intent(in) :: i_tally - logical, intent(out) :: found_bin - end subroutine get_scoring_bins_ end interface contains @@ -68,18 +61,18 @@ contains if (run_CE) then score_general => score_general_ce score_analog_tally => score_analog_tally_ce - get_scoring_bins => get_scoring_bins_ce else score_general => score_general_mg score_analog_tally => score_analog_tally_mg - get_scoring_bins => get_scoring_bins_mg end if end subroutine init_tally_routines !=============================================================================== ! SCORE_GENERAL* adds scores to the tally array for the given filter and -! nuclide. This will work for either analog or tracklength tallies. Note that -! atom_density and flux are not used for analog tallies. +! nuclide. This function is called by all volume tallies. For analog tallies, +! the flux estimate depends on the score type so the flux argument is really +! just used for filter weights. The atom_density argument is not used for +! analog tallies. !=============================================================================== subroutine score_general_ce(p, t, start_index, filter_index, i_nuclide, & @@ -137,7 +130,7 @@ contains else score = p % last_wgt end if - score = score / material_xs % total + score = score / material_xs % total * flux else ! For flux, we need no cross section @@ -153,9 +146,9 @@ contains if (survival_biasing) then ! We need to account for the fact that some weight was already ! absorbed - score = p % last_wgt + p % absorb_wgt + score = p % last_wgt + p % absorb_wgt * flux else - score = p % last_wgt + score = p % last_wgt * flux end if else @@ -190,7 +183,7 @@ contains ! Score the flux weighted inverse velocity with velocity in units of ! cm/s score = score / material_xs % total & - / (sqrt(TWO * E / (MASS_NEUTRON_MEV)) * C_LIGHT * 100.0_8) + / (sqrt(TWO * E / (MASS_NEUTRON_MEV)) * C_LIGHT * 100.0_8) * flux else ! For inverse velocity, we don't need a cross section. The velocity is @@ -206,7 +199,7 @@ contains ! Since only scattering events make it here, again we can use ! the weight entering the collision as the estimator for the ! reaction rate - score = p % last_wgt + score = p % last_wgt * flux else ! Note SCORE_SCATTER_N not available for tracklength/collision. @@ -229,7 +222,7 @@ contains ! Since only scattering events make it here, again we can use ! the weight entering the collision as the estimator for the ! reaction rate - score = p % last_wgt + score = p % last_wgt * flux case (SCORE_SCATTER_YN) @@ -242,7 +235,7 @@ contains ! Since only scattering events make it here, again we can use ! the weight entering the collision as the estimator for the ! reaction rate - score = p % last_wgt + score = p % last_wgt * flux case (SCORE_NU_SCATTER, SCORE_NU_SCATTER_N) @@ -256,7 +249,7 @@ contains (p % event_MT >= N_N1 .and. p % event_MT <= N_NC)) then ! Don't waste time on very common reactions we know have multiplicities ! of one. - score = p % last_wgt + score = p % last_wgt * flux else m = nuclides(p%event_nuclide)%reaction_index% & get_key(p % event_MT) @@ -266,11 +259,11 @@ contains select type (yield => rxn % products(1) % yield) type is (Constant1D) ! Grab the yield from the reaction - score = p % last_wgt * yield % y + score = p % last_wgt * yield % y * flux class default ! the yield was already incorporated in to p % wgt per the ! scattering routine - score = p % wgt + score = p % wgt * flux end select end associate end if @@ -290,7 +283,7 @@ contains (p % event_MT >= N_N1 .and. p % event_MT <= N_NC)) then ! Don't waste time on very common reactions we know have multiplicities ! of one. - score = p % last_wgt + score = p % last_wgt * flux else m = nuclides(p%event_nuclide)%reaction_index% & get_key(p % event_MT) @@ -300,11 +293,11 @@ contains select type (yield => rxn % products(1) % yield) type is (Constant1D) ! Grab the yield from the reaction - score = p % last_wgt * yield % y + score = p % last_wgt * yield % y * flux class default ! the yield was already incorporated in to p % wgt per the ! scattering routine - score = p % wgt + score = p % wgt * flux end select end associate end if @@ -324,7 +317,7 @@ contains (p % event_MT >= N_N1 .and. p % event_MT <= N_NC)) then ! Don't waste time on very common reactions we know have multiplicities ! of one. - score = p % last_wgt + score = p % last_wgt * flux else m = nuclides(p%event_nuclide)%reaction_index% & get_key(p % event_MT) @@ -334,11 +327,11 @@ contains select type (yield => rxn % products(1) % yield) type is (Constant1D) ! Grab the yield from the reaction - score = p % last_wgt * yield % y + score = p % last_wgt * yield % y * flux class default ! the yield was already incorporated in to p % wgt per the ! scattering routine - score = p % wgt + score = p % wgt * flux end select end associate end if @@ -349,13 +342,13 @@ contains if (survival_biasing) then ! No absorption events actually occur if survival biasing is on -- ! just use weight absorbed in survival biasing - score = p % absorb_wgt + score = p % absorb_wgt * flux else ! Skip any event where the particle wasn't absorbed if (p % event == EVENT_SCATTER) cycle SCORE_LOOP ! All fission and absorption events will contribute here, so we ! can just use the particle's weight entering the collision - score = p % last_wgt + score = p % last_wgt * flux end if else @@ -375,7 +368,7 @@ contains ! fission if (micro_xs(p % event_nuclide) % absorption > ZERO) then score = p % absorb_wgt * micro_xs(p % event_nuclide) % fission & - / micro_xs(p % event_nuclide) % absorption + / micro_xs(p % event_nuclide) % absorption * flux else score = ZERO end if @@ -386,7 +379,7 @@ contains ! particle's weight entering the collision as the estimate for the ! fission reaction rate score = p % last_wgt * micro_xs(p % event_nuclide) % fission & - / micro_xs(p % event_nuclide) % absorption + / micro_xs(p % event_nuclide) % absorption * flux end if else @@ -417,7 +410,7 @@ contains ! nu-fission if (micro_xs(p % event_nuclide) % absorption > ZERO) then score = p % absorb_wgt * micro_xs(p % event_nuclide) % & - nu_fission / micro_xs(p % event_nuclide) % absorption + nu_fission / micro_xs(p % event_nuclide) % absorption * flux else score = ZERO end if @@ -429,7 +422,7 @@ contains ! score the number of particles that were banked in the fission ! bank. Since this was weighted by 1/keff, we multiply by keff ! to get the proper score. - score = keff * p % wgt_bank + score = keff * p % wgt_bank * flux end if else @@ -478,16 +471,17 @@ contains end if else + ! make sure the correct energy is used + if (t % estimator == ESTIMATOR_TRACKLENGTH) then + E = p % E + else + E = p % last_E + end if + if (i_nuclide > 0) then score = micro_xs(i_nuclide) % fission * nuclides(i_nuclide) % & nu(E, EMISSION_PROMPT) * atom_density * flux else - ! make sure the correct energy is used - if (t % estimator == ESTIMATOR_TRACKLENGTH) then - E = p % E - else - E = p % last_E - end if score = ZERO @@ -540,23 +534,28 @@ contains ! Check if the delayed group filter is present if (dg_filter > 0) then + select type(filt => t % filters(dg_filter) % obj) + type is (DelayedGroupFilter) - ! Loop over all delayed group bins and tally to them - ! individually - do d_bin = 1, t % filters(dg_filter) % n_bins + ! Loop over all delayed group bins and tally to them + ! individually + do d_bin = 1, filt % n_bins - ! Get the delayed group for this bin - d = t % filters(dg_filter) % int_bins(d_bin) + ! Get the delayed group for this bin + d = filt % groups(d_bin) - ! Compute the yield for this delayed group - yield = nuclides(p % event_nuclide) % nu(E, EMISSION_DELAYED, d) + ! Compute the yield for this delayed group + yield = nuclides(p % event_nuclide) & + % nu(E, EMISSION_DELAYED, d) - ! Compute the score and tally to bin - score = p % absorb_wgt * yield * micro_xs(p % event_nuclide) & - % fission / micro_xs(p % event_nuclide) % absorption - call score_fission_delayed_dg(t, d_bin, score, score_index) - end do - cycle SCORE_LOOP + ! Compute the score and tally to bin + score = p % absorb_wgt * yield & + * micro_xs(p % event_nuclide) % fission & + / micro_xs(p % event_nuclide) % absorption + call score_fission_delayed_dg(t, d_bin, score, score_index) + end do + cycle SCORE_LOOP + end select else ! If the delayed group filter is not present, compute the score ! by multiplying the absorbed weight by the fraction of the @@ -580,18 +579,22 @@ contains ! Check if the delayed group filter is present if (dg_filter > 0) then + select type(filt => t % filters(dg_filter) % obj) + type is (DelayedGroupFilter) - ! Loop over all delayed group bins and tally to them individually - do d_bin = 1, t % filters(dg_filter) % n_bins + ! Loop over all delayed group bins and tally to them + ! individually + do d_bin = 1, filt % n_bins - ! Get the delayed group for this bin - d = t % filters(dg_filter) % int_bins(d_bin) + ! Get the delayed group for this bin + d = filt % groups(d_bin) - ! Compute the score and tally to bin - score = keff * p % wgt_bank / p % n_bank * p % n_delayed_bank(d) - call score_fission_delayed_dg(t, d_bin, score, score_index) - end do - cycle SCORE_LOOP + ! Compute the score and tally to bin + score = keff * p % wgt_bank / p % n_bank * p % n_delayed_bank(d) + call score_fission_delayed_dg(t, d_bin, score, score_index) + end do + cycle SCORE_LOOP + end select else ! Add the contribution from all delayed groups @@ -605,22 +608,26 @@ contains ! Check if the delayed group filter is present if (dg_filter > 0) then + select type(filt => t % filters(dg_filter) % obj) + type is (DelayedGroupFilter) - ! Loop over all delayed group bins and tally to them individually - do d_bin = 1, t % filters(dg_filter) % n_bins + ! Loop over all delayed group bins and tally to them + ! individually + do d_bin = 1, filt % n_bins - ! Get the delayed group for this bin - d = t % filters(dg_filter) % int_bins(d_bin) + ! Get the delayed group for this bin + d = filt % groups(d_bin) - ! Compute the yield for this delayed group - yield = nuclides(i_nuclide) % nu(E, EMISSION_DELAYED, d) + ! Compute the yield for this delayed group + yield = nuclides(i_nuclide) % nu(E, EMISSION_DELAYED, d) - ! Compute the score and tally to bin - score = micro_xs(i_nuclide) % fission * yield * & - atom_density * flux - call score_fission_delayed_dg(t, d_bin, score, score_index) - end do - cycle SCORE_LOOP + ! Compute the score and tally to bin + score = micro_xs(i_nuclide) % fission * yield * & + atom_density * flux + call score_fission_delayed_dg(t, d_bin, score, score_index) + end do + cycle SCORE_LOOP + end select else ! If the delayed group filter is not present, compute the score @@ -634,31 +641,35 @@ contains ! Check if the delayed group filter is present if (dg_filter > 0) then + select type(filt => t % filters(dg_filter) % obj) + type is (DelayedGroupFilter) - ! Loop over all nuclides in the current material - do l = 1, materials(p % material) % n_nuclides + ! Loop over all nuclides in the current material + do l = 1, materials(p % material) % n_nuclides - ! Get atom density - atom_density_ = materials(p % material) % atom_density(l) + ! Get atom density + atom_density_ = materials(p % material) % atom_density(l) - ! Get index in nuclides array - i_nuc = materials(p % material) % nuclide(l) + ! Get index in nuclides array + i_nuc = materials(p % material) % nuclide(l) - ! Loop over all delayed group bins and tally to them individually - do d_bin = 1, t % filters(dg_filter) % n_bins + ! Loop over all delayed group bins and tally to them + ! individually + do d_bin = 1, filt % n_bins - ! Get the delayed group for this bin - d = t % filters(dg_filter) % int_bins(d_bin) + ! Get the delayed group for this bin + d = filt % groups(d_bin) - ! Get the yield for the desired nuclide and delayed group - yield = nuclides(i_nuc) % nu(E, EMISSION_DELAYED, d) + ! Get the yield for the desired nuclide and delayed group + yield = nuclides(i_nuc) % nu(E, EMISSION_DELAYED, d) - ! Compute the score and tally to bin - score = micro_xs(i_nuc) % fission * yield * atom_density_ * flux - call score_fission_delayed_dg(t, d_bin, score, score_index) + ! Compute the score and tally to bin + score = micro_xs(i_nuc) % fission * yield * atom_density_ * flux + call score_fission_delayed_dg(t, d_bin, score, score_index) + end do end do - end do - cycle SCORE_LOOP + cycle SCORE_LOOP + end select else score = ZERO @@ -699,7 +710,7 @@ contains score = p%absorb_wgt * & nuc%reactions(nuc%index_fission(1))%Q_value * & micro_xs(p%event_nuclide)%fission / & - micro_xs(p%event_nuclide)%absorption + micro_xs(p%event_nuclide)%absorption * flux end if end associate else @@ -713,7 +724,7 @@ contains score = p%last_wgt * & nuc%reactions(nuc%index_fission(1))%Q_value * & micro_xs(p%event_nuclide)%fission / & - micro_xs(p%event_nuclide)%absorption + micro_xs(p%event_nuclide)%absorption * flux end if end associate end if @@ -751,7 +762,7 @@ contains if (t % estimator == ESTIMATOR_ANALOG) then ! Check if event MT matches if (p % event_MT /= ELASTIC) cycle SCORE_LOOP - score = p % last_wgt + score = p % last_wgt * flux else if (i_nuclide > 0) then @@ -766,7 +777,7 @@ contains ! Any other score is assumed to be a MT number. Thus, we just need ! to check if it matches the MT number of the event if (p % event_MT /= score_bin) cycle SCORE_LOOP - score = p % last_wgt + score = p % last_wgt * flux else ! Any other cross section has to be calculated on-the-fly. For @@ -922,7 +933,7 @@ contains else score = p % last_wgt end if - score = score / material_xs % total + score = score / material_xs % total * flux else ! For flux, we need no cross section @@ -945,7 +956,7 @@ contains if (i_nuclide > 0) then score = score * atom_density * & nucxs % get_xs('total', p_g, UVW=p_uvw) / & - matxs % get_xs('total', p_g, UVW=p_uvw) + matxs % get_xs('total', p_g, UVW=p_uvw) * flux end if else @@ -971,7 +982,7 @@ contains else score = p % last_wgt end if - score = score * inverse_velocities(p_g) / material_xs % total + score = score * inverse_velocities(p_g) / material_xs % total * flux else ! For inverse velocity, we need no cross section @@ -994,7 +1005,7 @@ contains ! Since only scattering events make it here, again we can use ! the weight entering the collision as the estimator for the ! reaction rate - score = p % last_wgt + score = p % last_wgt * flux ! Since we transport based on material data, the angle selected ! was not selected from the f(mu) for the nuclide. Therefore @@ -1037,7 +1048,7 @@ contains ! For scattering production, we need to use the pre-collision ! weight times the multiplicity as the estimate for the number of ! neutrons exiting a reaction with neutrons in the exit channel - score = p % wgt + score = p % wgt * flux ! Since we transport based on material data, the angle selected ! was not selected from the f(mu) for the nuclide. Therefore @@ -1067,13 +1078,13 @@ contains if (survival_biasing) then ! No absorption events actually occur if survival biasing is on -- ! just use weight absorbed in survival biasing - score = p % absorb_wgt + score = p % absorb_wgt * flux else ! Skip any event where the particle wasn't absorbed if (p % event == EVENT_SCATTER) cycle SCORE_LOOP ! All fission and absorption events will contribute here, so we ! can just use the particle's weight entering the collision - score = p % last_wgt + score = p % last_wgt * flux end if if (i_nuclide > 0) then score = score * atom_density * & @@ -1096,24 +1107,24 @@ contains ! No fission events occur if survival biasing is on -- need to ! calculate fraction of absorptions that would have resulted in ! fission - score = p % absorb_wgt + score = p % absorb_wgt * flux else ! Skip any non-absorption events if (p % event == EVENT_SCATTER) cycle SCORE_LOOP ! All fission events will contribute, so again we can use ! particle's weight entering the collision as the estimate for the ! fission reaction rate - score = p % last_wgt + score = p % last_wgt * flux end if if (i_nuclide > 0) then - score = score * atom_density * & - nucxs % get_xs('fission', p_g, UVW=p_uvw) / & - matxs % get_xs('absorption', p_g, UVW=p_uvw) - else - score = score * & - matxs % get_xs('fission', p_g, UVW=p_uvw) / & - matxs % get_xs('absorption', p_g, UVW=p_uvw) - end if + score = score * atom_density * & + nucxs % get_xs('fission', p_g, UVW=p_uvw) / & + matxs % get_xs('absorption', p_g, UVW=p_uvw) + else + score = score * & + matxs % get_xs('fission', p_g, UVW=p_uvw) / & + matxs % get_xs('absorption', p_g, UVW=p_uvw) + end if else if (i_nuclide > 0) then score = nucxs % get_xs('fission', p_g, UVW=p_uvw) * & @@ -1143,7 +1154,7 @@ contains ! No fission events occur if survival biasing is on -- need to ! calculate fraction of absorptions that would have resulted in ! nu-fission - score = p % absorb_wgt + score = p % absorb_wgt * flux if (i_nuclide > 0) then score = score * atom_density * & nucxs % get_xs('nu_fission', p_g, UVW=p_uvw) / & @@ -1161,7 +1172,7 @@ contains ! score the number of particles that were banked in the fission ! bank. Since this was weighted by 1/keff, we multiply by keff ! to get the proper score. - score = keff * p % wgt_bank + score = keff * p % wgt_bank * flux if (i_nuclide > 0) then score = score * atom_density * & nucxs % get_xs('fission', p_g, UVW=p_uvw) / & @@ -1185,14 +1196,14 @@ contains ! No fission events occur if survival biasing is on -- need to ! calculate fraction of absorptions that would have resulted in ! fission - score = p % absorb_wgt + score = p % absorb_wgt * flux else ! Skip any non-absorption events if (p % event == EVENT_SCATTER) cycle SCORE_LOOP ! All fission events will contribute, so again we can use ! particle's weight entering the collision as the estimate for the ! fission reaction rate - score = p % last_wgt + score = p % last_wgt * flux end if if (i_nuclide > 0) then score = score * atom_density * & @@ -1408,11 +1419,12 @@ contains integer :: i integer :: i_tally + integer :: i_filt integer :: k ! loop index for nuclide bins ! position during the loop integer :: filter_index ! single index for single bin integer :: i_nuclide ! index in nuclides array - logical :: found_bin ! scoring bin found? + real(8) :: filter_weight ! combined weight of all filters type(TallyObject), pointer :: t ! A loop over all tallies is necessary because we need to simultaneously @@ -1423,63 +1435,103 @@ contains i_tally = active_analog_tallies % get_item(i) t => tallies(i_tally) - ! ======================================================================= - ! DETERMINE SCORING BIN COMBINATION + ! Find the first bin in each filter. There may be more than one matching + ! bin per filter, but we'll deal with those later. + do i_filt = 1, size(t % filters) + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + NO_BIN_FOUND, matching_bins(i_filt), filter_weights(i_filt)) + ! If there are no valid bins for this filter, then there is nothing to + ! score and we can move on to the next tally. + if (matching_bins(i_filt) == NO_BIN_FOUND) cycle TALLY_LOOP + end do - call get_scoring_bins(p, i_tally, found_bin) - if (.not. found_bin) cycle + ! ======================================================================== + ! Loop until we've covered all valid bins on each of the filters. - ! ======================================================================= - ! CALCULATE RESULTS AND ACCUMULATE TALLY + FILTER_LOOP: do - ! If we have made it here, we have a scoring combination of bins for this - ! tally -- now we need to determine where in the results array we should - ! be accumulating the tally values + ! Determine scoring index and weight for this filter combination + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 + filter_weight = product(filter_weights(:size(t % filters))) - ! Determine scoring index for this filter combination - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + ! ====================================================================== + ! Nuclide logic - ! Check for nuclide bins - k = 0 - NUCLIDE_LOOP: do while (k < t % n_nuclide_bins) + ! Check for nuclide bins + k = 0 + NUCLIDE_LOOP: do while (k < t % n_nuclide_bins) - ! Increment the index in the list of nuclide bins - k = k + 1 + ! Increment the index in the list of nuclide bins + k = k + 1 + + if (t % all_nuclides) then + ! In the case that the user has requested to tally all nuclides, we + ! can take advantage of the fact that we know exactly how nuclide + ! bins correspond to nuclide indices. + if (k == 1) then + ! If we just entered, set the nuclide bin index to the index in + ! the nuclides array since this will match the index in the + ! nuclide bin array. + k = p % event_nuclide + 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 + else + ! After we've tallied in both the individual nuclide bin and the + ! total material bin, we're done + exit + end if - if (t % all_nuclides) then - ! In the case that the user has requested to tally all nuclides, we - ! can take advantage of the fact that we know exactly how nuclide - ! bins correspond to nuclide indices. - if (k == 1) then - ! If we just entered, set the nuclide bin index to the index in - ! the nuclides array since this will match the index in the - ! nuclide bin array. - k = p % event_nuclide - 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 else - ! After we've tallied in both the individual nuclide bin and the - ! total material bin, we're done - exit + ! If the user has explicitly specified nuclides (or specified + ! none), we need to search through the nuclide bin list one by + ! one. First we need to get the value of the nuclide bin + i_nuclide = t % nuclide_bins(k) + + ! Now compare the value against that of the colliding nuclide. + if (i_nuclide /= p % event_nuclide .and. i_nuclide /= -1) cycle end if - else - ! If the user has explicitly specified nuclides (or specified - ! none), we need to search through the nuclide bin list one by - ! one. First we need to get the value of the nuclide bin - i_nuclide = t % nuclide_bins(k) + ! Determine score for each bin + call score_general(p, t, (k-1)*t % n_score_bins, filter_index, & + i_nuclide, ZERO, filter_weight) - ! Now compare the value against that of the colliding nuclide. - if (i_nuclide /= p % event_nuclide .and. i_nuclide /= -1) cycle - end if + end do NUCLIDE_LOOP - ! Determine score for each bin - call score_general(p, t, (k-1)*t % n_score_bins, filter_index, & - i_nuclide, ZERO, ZERO) + ! ====================================================================== + ! Filter logic - end do NUCLIDE_LOOP + ! If there are no filters, then we are done. + if (size(t % filters) == 0) exit FILTER_LOOP + + ! Increment the filter bins, starting with the last filter. If we get a + ! NO_BIN_FOUND for the last filter, it means we finished all valid bins + ! for that filter, but next-to-last filter might have more than one + ! valid bin so we need to increment that one as well, and so on. + do i_filt = size(t % filters), 1, -1 + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + matching_bins(i_filt), matching_bins(i_filt), & + filter_weights(i_filt)) + if (matching_bins(i_filt) /= NO_BIN_FOUND) exit + end do + + ! If we got all NO_BIN_FOUNDs, then we have finished all valid bins for + ! each of the filters. Exit the loop. + if (all(matching_bins(:size(t % filters)) == NO_BIN_FOUND)) & + exit FILTER_LOOP + + ! Reset all the filters with NO_BIN_FOUND. This will set them back to + ! their first valid bin. + do i_filt = 1, size(t % filters) + if (matching_bins(i_filt) == NO_BIN_FOUND) then + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + matching_bins(i_filt), matching_bins(i_filt), & + filter_weights(i_filt)) + end if + end do + end do FILTER_LOOP ! If the user has specified that we can assume all tallies are spatially ! separate, this implies that once a tally has been scored to, we needn't @@ -1501,14 +1553,15 @@ contains integer :: i, m integer :: i_tally + integer :: i_filt integer :: k ! loop index for nuclide bins ! position during the loop integer :: filter_index ! single index for single bin integer :: i_nuclide ! index in nuclides array - logical :: found_bin ! scoring bin found? + real(8) :: filter_weight ! combined weight of all filters + real(8) :: atom_density type(TallyObject), pointer :: t type(Material), pointer :: mat - real(8) :: atom_density ! 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 @@ -1522,44 +1575,84 @@ contains ! nuclides are in the material mat => materials(p % material) - ! ======================================================================= - ! DETERMINE SCORING BIN COMBINATION + ! Find the first bin in each filter. There may be more than one matching + ! bin per filter, but we'll deal with those later. + do i_filt = 1, size(t % filters) + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + NO_BIN_FOUND, matching_bins(i_filt), filter_weights(i_filt)) + ! If there are no valid bins for this filter, then there is nothing to + ! score and we can move on to the next tally. + if (matching_bins(i_filt) == NO_BIN_FOUND) cycle TALLY_LOOP + end do - call get_scoring_bins(p, i_tally, found_bin) - if (.not. found_bin) cycle + ! ======================================================================== + ! Loop until we've covered all valid bins on each of the filters. - ! ======================================================================= - ! CALCULATE RESULTS AND ACCUMULATE TALLY + FILTER_LOOP: do - ! If we have made it here, we have a scoring combination of bins for this - ! tally -- now we need to determine where in the results array we should - ! be accumulating the tally values + ! Determine scoring index and weight for this filter combination + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 + filter_weight = product(filter_weights(:size(t % filters))) - ! Determine scoring index for this filter combination - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + ! ====================================================================== + ! Nuclide logic - ! Check for nuclide bins - k = 0 - NUCLIDE_LOOP: do while (k < t % n_nuclide_bins) + ! Check for nuclide bins + k = 0 + NUCLIDE_LOOP: do while (k < t % n_nuclide_bins) - ! Increment the index in the list of nuclide bins - k = k + 1 + ! Increment the index in the list of nuclide bins + k = k + 1 - i_nuclide = t % nuclide_bins(k) + i_nuclide = t % nuclide_bins(k) - ! Check to see if this nuclide was in the material of our collision. - do m = 1, mat % n_nuclides - if (mat % nuclide(m) == i_nuclide) then - atom_density = mat % atom_density(m) - exit - end if + ! Check to see if this nuclide was in the material of our collision. + do m = 1, mat % n_nuclides + if (mat % nuclide(m) == i_nuclide) then + atom_density = mat % atom_density(m) + exit + end if + end do + + ! Determine score for each bin + call score_general(p, t, (k-1)*t % n_score_bins, filter_index, & + i_nuclide, atom_density, filter_weight) + + end do NUCLIDE_LOOP + + ! ====================================================================== + ! Filter logic + + ! If there are no filters, then we are done. + if (size(t % filters) == 0) exit FILTER_LOOP + + ! Increment the filter bins, starting with the last filter. If we get a + ! NO_BIN_FOUND for the last filter, it means we finished all valid bins + ! for that filter, but next-to-last filter might have more than one + ! valid bin so we need to increment that one as well, and so on. + do i_filt = size(t % filters), 1, -1 + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + matching_bins(i_filt), matching_bins(i_filt), & + filter_weights(i_filt)) + if (matching_bins(i_filt) /= NO_BIN_FOUND) exit end do - ! Determine score for each bin - call score_general(p, t, (k-1)*t % n_score_bins, filter_index, & - i_nuclide, atom_density, ZERO) + ! If we got all NO_BIN_FOUNDs, then we have finished all valid bins for + ! each of the filters. Exit the loop. + if (all(matching_bins(:size(t % filters)) == NO_BIN_FOUND)) & + exit FILTER_LOOP - end do NUCLIDE_LOOP + ! Reset all the filters with NO_BIN_FOUND. This will set them back to + ! their first valid bin. + do i_filt = 1, size(t % filters) + if (matching_bins(i_filt) == NO_BIN_FOUND) then + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + matching_bins(i_filt), matching_bins(i_filt), & + filter_weights(i_filt)) + end if + end do + end do FILTER_LOOP ! If the user has specified that we can assume all tallies are spatially ! separate, this implies that once a tally has been scored to, we needn't @@ -1598,6 +1691,7 @@ contains integer :: k ! loop index for bank sites integer :: bin_energyout ! original outgoing energy bin integer :: i_filter ! index for matching filter bin combination + real(8) :: filter_weight ! combined weight of all filters real(8) :: score ! actual score real(8) :: E_out ! energy of fission bank site @@ -1605,77 +1699,93 @@ contains i = t % find_filter(FILTER_ENERGYOUT) bin_energyout = matching_bins(i) - ! Get number of energies on filter - n = size(t % filters(i) % real_bins) + ! declare the energyout filter type + select type(eo_filt => t % filters(i) % obj) + type is (EnergyoutFilter) - ! Since the creation of fission sites is weighted such that it is - ! expected to create n_particles sites, we need to multiply the - ! score by keff to get the true nu-fission rate. Otherwise, the sum - ! of all nu-fission rates would be ~1.0. + ! Get number of energies on filter + n = size(eo_filt % bins) - ! loop over number of particles banked - do k = 1, p % n_bank + ! Since the creation of fission sites is weighted such that it is + ! expected to create n_particles sites, we need to multiply the + ! score by keff to get the true nu-fission rate. Otherwise, the sum + ! of all nu-fission rates would be ~1.0. - ! get the delayed group - g = fission_bank(n_bank - p % n_bank + k) % delayed_group + ! loop over number of particles banked + do k = 1, p % n_bank - ! determine score based on bank site weight and keff - score = keff * fission_bank(n_bank - p % n_bank + k) % wgt + ! get the delayed group + g = fission_bank(n_bank - p % n_bank + k) % delayed_group - ! determine outgoing energy from fission bank - E_out = fission_bank(n_bank - p % n_bank + k) % E + ! determine score based on bank site weight and keff + score = keff * fission_bank(n_bank - p % n_bank + k) % wgt - ! check if outgoing energy is within specified range on filter - if (E_out < t % filters(i) % real_bins(1) .or. & - E_out > t % filters(i) % real_bins(n)) cycle + ! determine outgoing energy from fission bank + E_out = fission_bank(n_bank - p % n_bank + k) % E - ! change outgoing energy bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, n, E_out) + ! check if outgoing energy is within specified range on filter + if (E_out < eo_filt % bins(1) .or. E_out > eo_filt % bins(n)) cycle - ! Case for tallying prompt neutrons - if (score_bin == SCORE_NU_FISSION .or. & - (score_bin == SCORE_PROMPT_NU_FISSION .and. g == 0)) then + ! change outgoing energy bin + Matching_bins(i) = binary_search(eo_filt % bins, n, E_out) - ! determine scoring index - i_filter = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + ! Case for tallying prompt neutrons + if (score_bin == SCORE_NU_FISSION .or. & + (score_bin == SCORE_PROMPT_NU_FISSION .and. g == 0)) then - ! Add score to tally -!$omp atomic - t % results(i_score, i_filter) % value = & - t % results(i_score, i_filter) % value + score - - ! Case for tallying delayed emissions - else if (score_bin == SCORE_DELAYED_NU_FISSION .and. g /= 0) then - - ! Get the index of delayed group filter - j = t % find_filter(FILTER_DELAYEDGROUP) - - ! if the delayed group filter is present, tally to corresponding - ! delayed group bin if it exists - if (j > 0) then - - ! loop over delayed group bins until the corresponding bin is found - do d_bin = 1, t % filters(j) % n_bins - d = t % filters(j) % int_bins(d_bin) - - ! check whether the delayed group of the particle is equal to the - ! delayed group of this bin - if (d == g) call score_fission_delayed_dg(t, d_bin, score, i_score) - end do - - ! if the delayed group filter is not present, add score to tally - else - - ! determine scoring index - i_filter = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + ! determine scoring index and weight for this filter combination + i_filter = sum((matching_bins(1:size(t%filters)) - 1) * t % stride) & + + 1 + filter_weight = product(filter_weights(:size(t % filters))) ! Add score to tally !$omp atomic t % results(i_score, i_filter) % value = & - t % results(i_score, i_filter) % value + score + t % results(i_score, i_filter) % value + score * filter_weight + + ! Case for tallying delayed emissions + else if (score_bin == SCORE_DELAYED_NU_FISSION .and. g /= 0) then + + ! Get the index of delayed group filter + j = t % find_filter(FILTER_DELAYEDGROUP) + + ! if the delayed group filter is present, tally to corresponding + ! delayed group bin if it exists + if (j > 0) then + + ! declare the delayed group filter type + select type(dg_filt => t % filters(j) % obj) + type is (DelayedGroupFilter) + + ! loop over delayed group bins until the corresponding bin is + ! found + do d_bin = 1, dg_filt % n_bins + d = dg_filt % groups(d_bin) + + ! check whether the delayed group of the particle is equal to + ! the delayed group of this bin + if (d == g) then + call score_fission_delayed_dg(t, d_bin, score, i_score) + end if + end do + end select + + ! if the delayed group filter is not present, add score to tally + else + + ! determine scoring index and weight for this filter combination + i_filter = sum((matching_bins(1:size(t%filters)) - 1) * t % stride)& + + 1 + filter_weight = product(filter_weights(:size(t % filters))) + + ! Add score to tally +!$omp atomic + t % results(i_score, i_filter) % value = & + t % results(i_score, i_filter) % value + score * filter_weight + end if end if - end if - end do + end do + end select ! reset outgoing energy bin and score index matching_bins(i) = bin_energyout @@ -1694,6 +1804,7 @@ contains integer :: k ! loop index for bank sites integer :: bin_energyout ! original outgoing energy bin integer :: i_filter ! index for matching filter bin combination + real(8) :: filter_weight ! combined weight of all filters real(8) :: score ! actual score integer :: gout ! energy group of fission bank site integer :: gin ! energy group of incident particle @@ -1703,60 +1814,65 @@ contains i = t % find_filter(FILTER_ENERGYOUT) bin_energyout = matching_bins(i) - ! Get number of energies on filter - n = size(t % filters(i) % real_bins) + ! Declare the filter type + select type(filt => t % filters(i) % obj) + type is (EnergyoutFilter) - ! Since the creation of fission sites is weighted such that it is - ! expected to create n_particles sites, we need to multiply the - ! score by keff to get the true nu-fission rate. Otherwise, the sum - ! of all nu-fission rates would be ~1.0. + ! Get number of energies on filter + n = size(filt % bins) - ! loop over number of particles banked - do k = 1, p % n_bank - ! determine score based on bank site weight and keff - score = keff * fission_bank(n_bank - p % n_bank + k) % wgt - if (i_nuclide > 0) then - if (survival_biasing) then - gin = p % g - else - gin = p % last_g + ! Since the creation of fission sites is weighted such that it is + ! expected to create n_particles sites, we need to multiply the + ! score by keff to get the true nu-fission rate. Otherwise, the sum + ! of all nu-fission rates would be ~1.0. + + ! loop over number of particles banked + do k = 1, p % n_bank + ! determine score based on bank site weight and keff + score = keff * fission_bank(n_bank - p % n_bank + k) % wgt + if (i_nuclide > 0) then + if (survival_biasing) then + gin = p % g + else + gin = p % last_g + end if + score = score * atom_density * & + nuclides_MG(i_nuclide) % obj % get_xs('fission', gin, & + UVW=p % last_uvw) / & + macro_xs(p % material) % obj % get_xs('fission', gin, & + UVW=p % last_uvw) end if - score = score * atom_density * & - nuclides_MG(i_nuclide) % obj % get_xs('fission', gin, & - UVW=p % last_uvw) / & - macro_xs(p % material) % obj % get_xs('fission', gin, & - UVW=p % last_uvw) - end if - if (t % energyout_matches_groups) then - ! determine outgoing energy from fission bank - gout = int(fission_bank(n_bank - p % n_bank + k) % E) + if (filt % matches_transport_groups) then + ! determine outgoing energy from fission bank + gout = int(fission_bank(n_bank - p % n_bank + k) % E) - ! change outgoing energy bin - matching_bins(i) = gout - else - ! determine outgoing energy from fission bank - E_out = energy_bin_avg(int(fission_bank(n_bank - p % n_bank + k) % E)) + ! change outgoing energy bin + matching_bins(i) = gout + else + ! determine outgoing energy from fission bank + E_out = energy_bin_avg(int(fission_bank(n_bank - p % n_bank + k) % E)) - ! check if outgoing energy is within specified range on filter - if (E_out < t % filters(i) % real_bins(1) .or. & - E_out > t % filters(i) % real_bins(n)) cycle + ! check if outgoing energy is within specified range on filter + if (E_out < filt % bins(1) .or. E_out > filt % bins(n)) cycle - ! change outgoing energy bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, n, E_out) - end if + ! change outgoing energy bin + matching_bins(i) = binary_search(filt % bins, n, E_out) + end if - ! determine scoring index - i_filter = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + ! determine scoring index and weight for this filter combination + i_filter = sum((matching_bins(1:size(t%filters)) - 1) * t % stride) + 1 + filter_weight = product(filter_weights(:size(t % filters))) - ! Add score to tally + ! Add score to tally !$omp atomic - t % results(i_score, i_filter) % value = & - t % results(i_score, i_filter) % value + score - end do + t % results(i_score, i_filter) % value = & + t % results(i_score, i_filter) % value + score * filter_weight + end do ! reset outgoing energy bin and score index matching_bins(i) = bin_energyout + end select end subroutine score_fission_eout_mg @@ -1768,23 +1884,26 @@ contains subroutine score_fission_delayed_dg(t, d_bin, score, score_index) type(TallyObject), intent(inout) :: t - integer, intent(in) :: score_index ! index for score integer, intent(in) :: d_bin ! delayed group bin index + real(8), intent(in) :: score ! actual score + integer, intent(in) :: score_index ! index for score integer :: bin_original ! original bin index integer :: filter_index ! index for matching filter bin combination - real(8) :: score ! actual score + real(8) :: filter_weight ! combined weight of all filters ! save original delayed group bin bin_original = matching_bins(t % find_filter(FILTER_DELAYEDGROUP)) matching_bins(t % find_filter(FILTER_DELAYEDGROUP)) = d_bin - ! Compute the filter index based on the modified matching_bins - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + ! determine scoring index and weight on the modified matching_bins + filter_index = sum((matching_bins(1:size(t % filters)) - 1) * t % stride) & + + 1 + filter_weight = product(filter_weights(:size(t % filters))) !$omp atomic t % results(score_index, filter_index) % value = & - t % results(score_index, filter_index) % value + score + t % results(score_index, filter_index) % value + score * filter_weight ! reset original delayed group bin matching_bins(t % find_filter(FILTER_DELAYEDGROUP)) = bin_original @@ -1805,13 +1924,14 @@ contains integer :: i integer :: i_tally + integer :: i_filt integer :: j ! loop index for scoring bins integer :: k ! loop index for nuclide bins integer :: filter_index ! single index for single bin integer :: i_nuclide ! index in nuclides array (from bins) real(8) :: flux ! tracklength estimate of flux real(8) :: atom_density ! atom density of single nuclide in atom/b-cm - logical :: found_bin ! scoring bin found? + real(8) :: filter_weight ! combined weight of all filters type(TallyObject), pointer :: t type(Material), pointer :: mat @@ -1826,70 +1946,103 @@ contains i_tally = active_tracklength_tallies % get_item(i) t => tallies(i_tally) - ! Check if this tally has a mesh filter -- if so, we treat it separately - ! since multiple bins can be scored to with a single track + ! Find the first bin in each filter. There may be more than one matching + ! bin per filter, but we'll deal with those later. + do i_filt = 1, size(t % filters) + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + NO_BIN_FOUND, matching_bins(i_filt), filter_weights(i_filt)) + ! If there are no valid bins for this filter, then there is nothing to + ! score and we can move on to the next tally. + if (matching_bins(i_filt) == NO_BIN_FOUND) cycle TALLY_LOOP + end do - if (t % find_filter(FILTER_MESH) > 0) then - call score_tl_on_mesh(p, i_tally, distance) - cycle - end if + ! ======================================================================== + ! Loop until we've covered all valid bins on each of the filters. - ! ======================================================================= - ! DETERMINE SCORING BIN COMBINATION + FILTER_LOOP: do - call get_scoring_bins(p, i_tally, found_bin) - if (.not. found_bin) cycle + ! Determine scoring index and weight for this filter combination + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 + filter_weight = product(filter_weights(:size(t % filters))) - ! ======================================================================= - ! CALCULATE RESULTS AND ACCUMULATE TALLY + ! ====================================================================== + ! Nuclide logic - ! If we have made it here, we have a scoring combination of bins for this - ! tally -- now we need to determine where in the results array we should - ! be accumulating the tally values - - ! Determine scoring index for this filter combination - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 - - if (t % all_nuclides) then - if (p % material /= MATERIAL_VOID) then - call score_all_nuclides(p, i_tally, flux, filter_index) - end if - else - - NUCLIDE_BIN_LOOP: do k = 1, t % n_nuclide_bins - ! Get index of nuclide in nuclides array - i_nuclide = t % nuclide_bins(k) - - if (i_nuclide > 0) then - if (p % material /= MATERIAL_VOID) then - ! Get pointer to current material - mat => materials(p % material) - - ! Determine if nuclide is actually in material - NUCLIDE_MAT_LOOP: do j = 1, mat % n_nuclides - ! If index of nuclide matches the j-th nuclide listed in the - ! material, break out of the loop - if (i_nuclide == mat % nuclide(j)) exit - - ! If we've reached the last nuclide in the material, it means - ! the specified nuclide to be tallied is not in this material - if (j == mat % n_nuclides) then - cycle NUCLIDE_BIN_LOOP - end if - end do NUCLIDE_MAT_LOOP - - atom_density = mat % atom_density(j) - else - atom_density = ZERO - end if + if (t % all_nuclides) then + if (p % material /= MATERIAL_VOID) then + call score_all_nuclides(p, i_tally, flux, filter_index) end if + else - ! Determine score for each bin - call score_general(p, t, (k-1)*t % n_score_bins, filter_index, & - i_nuclide, atom_density, flux) + NUCLIDE_BIN_LOOP: do k = 1, t % n_nuclide_bins + ! Get index of nuclide in nuclides array + i_nuclide = t % nuclide_bins(k) - end do NUCLIDE_BIN_LOOP - end if + if (i_nuclide > 0) then + if (p % material /= MATERIAL_VOID) then + ! Get pointer to current material + mat => materials(p % material) + + ! Determine if nuclide is actually in material + NUCLIDE_MAT_LOOP: do j = 1, mat % n_nuclides + ! If index of nuclide matches the j-th nuclide listed in the + ! material, break out of the loop + if (i_nuclide == mat % nuclide(j)) exit + + ! If we've reached the last nuclide in the material, it means + ! the specified nuclide to be tallied is not in this material + if (j == mat % n_nuclides) then + cycle NUCLIDE_BIN_LOOP + end if + end do NUCLIDE_MAT_LOOP + + atom_density = mat % atom_density(j) + else + atom_density = ZERO + end if + end if + + ! Determine score for each bin + call score_general(p, t, (k-1)*t % n_score_bins, filter_index, & + i_nuclide, atom_density, flux * filter_weight) + + end do NUCLIDE_BIN_LOOP + + end if + + ! ====================================================================== + ! Filter logic + + ! If there are no filters, then we are done. + if (size(t % filters) == 0) exit FILTER_LOOP + + ! Increment the filter bins, starting with the last filter. If we get a + ! NO_BIN_FOUND for the last filter, it means we finished all valid bins + ! for that filter, but next-to-last filter might have more than one + ! valid bin so we need to increment that one as well, and so on. + do i_filt = size(t % filters), 1, -1 + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + matching_bins(i_filt), matching_bins(i_filt), & + filter_weights(i_filt)) + if (matching_bins(i_filt) /= NO_BIN_FOUND) exit + end do + + ! If we got all NO_BIN_FOUNDs, then we have finished all valid bins for + ! each of the filters. Exit the loop. + if (all(matching_bins(:size(t % filters)) == NO_BIN_FOUND)) & + exit FILTER_LOOP + + ! Reset all the filters with NO_BIN_FOUND. This will set them back to + ! their first valid bin. + do i_filt = 1, size(t % filters) + if (matching_bins(i_filt) == NO_BIN_FOUND) then + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + matching_bins(i_filt), matching_bins(i_filt), & + filter_weights(i_filt)) + end if + end do + end do FILTER_LOOP ! If the user has specified that we can assume all tallies are spatially ! separate, this implies that once a tally has been scored to, we needn't @@ -1905,289 +2058,6 @@ contains end subroutine score_tracklength_tally -!=============================================================================== -! SCORE_TL_ON_MESH calculate fluxes and reaction rates based on the track-length -! estimate of the flux specifically for tallies that have mesh filters. For -! these tallies, it is possible to score to multiple mesh cells for each track. -!=============================================================================== - - subroutine score_tl_on_mesh(p, i_tally, d_track) - - type(Particle), intent(in) :: p - integer, intent(in) :: i_tally - real(8), intent(in) :: d_track - - integer :: i ! loop index for filter/score bins - integer :: j ! loop index for direction - integer :: k ! loop index for mesh cell crossings - integer :: b ! loop index for nuclide bins - integer :: ijk0(3) ! indices of starting coordinates - integer :: ijk1(3) ! indices of ending coordinates - integer :: ijk_cross(3) ! indices of mesh cell crossed - integer :: n_cross ! number of surface crossings - integer :: filter_index ! single index for single bin - integer :: i_nuclide ! index in nuclides array - integer :: i_filter_mesh ! index of mesh filter in filters array - real(8) :: atom_density ! density of individual nuclide in atom/b-cm - real(8) :: flux ! tracklength estimate of flux - 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(3) ! coordinates of next boundary - real(8) :: d(3) ! distance to each bounding surface - real(8) :: distance ! distance traveled in mesh cell - logical :: found_bin ! was a scoring bin found? - logical :: start_in_mesh ! starting coordinates inside mesh? - logical :: end_in_mesh ! ending coordinates inside mesh? - real(8) :: theta - real(8) :: phi - type(TallyObject), pointer :: t - type(RegularMesh), pointer :: m - type(Material), pointer :: mat - - t => tallies(i_tally) - matching_bins(1:t%n_filters) = 1 - - ! ========================================================================== - ! CHECK IF THIS TRACK INTERSECTS THE MESH - - ! Copy starting and ending location of particle - xyz0 = p % coord(1) % xyz - (d_track - TINY_BIT) * p % coord(1) % uvw - xyz1 = p % coord(1) % xyz - TINY_BIT * p % coord(1) % uvw - - ! Get index for mesh filter - i_filter_mesh = t % find_filter(FILTER_MESH) - - ! Determine indices for starting and ending location - m => meshes(t % filters(i_filter_mesh) % int_bins(1)) - call get_mesh_indices(m, xyz0, ijk0(:m % n_dimension), start_in_mesh) - call get_mesh_indices(m, xyz1, ijk1(:m % n_dimension), end_in_mesh) - - ! Check 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 (m % n_dimension == 2) then - if (.not. mesh_intersects_2d(m, xyz0, xyz1)) return - else - if (.not. mesh_intersects_3d(m, xyz0, xyz1)) return - end if - end if - - ! Reset starting and ending location - xyz0 = p % coord(1) % xyz - d_track * p % coord(1) % uvw - xyz1 = p % coord(1) % xyz - - ! ========================================================================= - ! CHECK FOR SCORING COMBINATION FOR FILTERS OTHER THAN MESH - - FILTER_LOOP: do i = 1, t % n_filters - - select case (t % filters(i) % type) - case (FILTER_UNIVERSE) - ! determine next universe bin - ! TODO: Account for multiple universes when performing this filter - matching_bins(i) = get_next_bin(FILTER_UNIVERSE, & - p % coord(p % n_coord) % universe, i_tally) - - case (FILTER_MATERIAL) - matching_bins(i) = get_next_bin(FILTER_MATERIAL, & - p % material, i_tally) - - case (FILTER_CELL) - ! determine next cell bin - do j = 1, p % n_coord - position(FILTER_CELL) = 0 - matching_bins(i) = get_next_bin(FILTER_CELL, & - p % coord(j) % cell, i_tally) - if (matching_bins(i) /= NO_BIN_FOUND) exit - end do - - case (FILTER_CELLBORN) - ! determine next cellborn bin - matching_bins(i) = get_next_bin(FILTER_CELLBORN, & - p % cell_born, i_tally) - - case (FILTER_SURFACE) - ! determine next surface bin - matching_bins(i) = get_next_bin(FILTER_SURFACE, & - p % surface, i_tally) - - case (FILTER_ENERGYIN) - ! determine incoming energy bin - k = t % filters(i) % n_bins - - ! check if energy of the particle is within energy bins - if (p % E < t % filters(i) % real_bins(1) .or. & - p % E > t % filters(i) % real_bins(k + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find incoming energy bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - k + 1, p % E) - end if - - case (FILTER_POLAR) - ! Get theta value - theta = acos(p % coord(1) % uvw(3)) - - ! determine polar angle bin - k = t % filters(i) % n_bins - - ! check if particle is within polar angle bins - if (theta < t % filters(i) % real_bins(1) .or. & - theta > t % filters(i) % real_bins(k + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find polar angle bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - k + 1, theta) - end if - - case (FILTER_AZIMUTHAL) - ! make sure the correct direction vector is used - phi = atan2(p % coord(1) % uvw(2), p % coord(1) % uvw(1)) - - ! determine mu bin - k = t % filters(i) % n_bins - - ! check if particle is within azimuthal angle bins - if (phi < t % filters(i) % real_bins(1) .or. & - phi > t % filters(i) % real_bins(k + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find azimuthal angle bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - k + 1, phi) - end if - - end select - - ! Check if no matching bin was found - if (matching_bins(i) == NO_BIN_FOUND) return - - end do FILTER_LOOP - - ! ========================================================================== - ! DETERMINE WHICH MESH CELLS TO SCORE TO - - ! Calculate number of surface crossings - n_cross = sum(abs(ijk1(:m % n_dimension) - ijk0(:m % n_dimension))) + 1 - - ! Copy particle's direction - uvw = p % coord(1) % uvw - - ! Bounding coordinates - do j = 1, m % n_dimension - if (uvw(j) > 0) then - xyz_cross(j) = m % lower_left(j) + ijk0(j) * m % width(j) - else - xyz_cross(j) = m % lower_left(j) + (ijk0(j) - 1) * m % width(j) - end if - end do - - MESH_LOOP: do k = 1, n_cross - found_bin = .false. - - ! Calculate distance to each bounding surface. We need to treat special - ! case where the cosine of the angle is zero since this would result in a - ! divide-by-zero. - - if (k == n_cross) xyz_cross = xyz1 - - do j = 1, m % n_dimension - if (uvw(j) == 0) then - d(j) = INFINITY - else - d(j) = (xyz_cross(j) - xyz0(j))/uvw(j) - end if - end do - - ! Determine the closest bounding surface of the mesh cell by calculating - ! the minimum distance - - j = minloc(d(:m % n_dimension), 1) - distance = d(j) - - ! Now use the minimum distance and diretion of the particle to determine - ! which surface was crossed - - if (all(ijk0(:m % n_dimension) >= 1) .and. all(ijk0(:m % n_dimension) <= m % dimension)) then - ijk_cross = ijk0 - found_bin = .true. - end if - - ! Increment indices and determine new crossing point - if (uvw(j) > 0) then - ijk0(j) = ijk0(j) + 1 - xyz_cross(j) = xyz_cross(j) + m % width(j) - else - ijk0(j) = ijk0(j) - 1 - xyz_cross(j) = xyz_cross(j) - m % width(j) - end if - - ! ======================================================================= - ! SCORE TO THIS MESH CELL - - if (found_bin) then - ! Calculate track-length estimate of flux - flux = p % wgt * distance - - ! Determine mesh bin - matching_bins(i_filter_mesh) = mesh_indices_to_bin(m, ijk_cross) - - ! Determining scoring index - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 - - if (t % all_nuclides) then - if (p % material /= MATERIAL_VOID) then - ! Score reaction rates for each nuclide in material - call score_all_nuclides(p, i_tally, flux, filter_index) - end if - else - NUCLIDE_BIN_LOOP: do b = 1, t % n_nuclide_bins - ! Get index of nuclide in nuclides array - i_nuclide = t % nuclide_bins(b) - - if (i_nuclide > 0) then - if (p % material /= MATERIAL_VOID) then - ! Get pointer to current material - mat => materials(p % material) - - ! Determine if nuclide is actually in material - NUCLIDE_MAT_LOOP: do j = 1, mat % n_nuclides - ! If index of nuclide matches the j-th nuclide listed in - ! the material, break out of the loop - if (i_nuclide == mat % nuclide(j)) exit - - ! If we've reached the last nuclide in the material, it - ! means the specified nuclide to be tallied is not in this - ! material - if (j == mat % n_nuclides) then - cycle NUCLIDE_BIN_LOOP - end if - end do NUCLIDE_MAT_LOOP - - atom_density = mat % atom_density(j) - else - atom_density = ZERO - end if - end if - - ! Determine score for each bin - call score_general(p, t, (b-1)*t % n_score_bins, filter_index, & - i_nuclide, atom_density, flux) - - end do NUCLIDE_BIN_LOOP - end if - end if - - ! Calculate new coordinates - xyz0 = xyz0 + distance * uvw - - end do MESH_LOOP - - end subroutine score_tl_on_mesh - !=============================================================================== ! SCORE_COLLISION_TALLY calculates fluxes and reaction rates based on the ! 1/Sigma_t estimate of the flux. This is triggered after every collision. It @@ -2202,6 +2072,7 @@ contains integer :: i integer :: i_tally + integer :: i_filt integer :: j ! loop index for scoring bins integer :: k ! loop index for nuclide bins integer :: filter_index ! single index for single bin @@ -2209,7 +2080,7 @@ contains real(8) :: flux ! collision estimate of flux real(8) :: atom_density ! atom density of single nuclide ! in atom/b-cm - logical :: found_bin ! scoring bin found? + real(8) :: filter_weight ! combined weight of all filters type(TallyObject), pointer :: t type(Material), pointer :: mat @@ -2229,62 +2100,103 @@ contains i_tally = active_collision_tallies % get_item(i) t => tallies(i_tally) - ! ======================================================================= - ! DETERMINE SCORING BIN COMBINATION + ! Find the first bin in each filter. There may be more than one matching + ! bin per filter, but we'll deal with those later. + do i_filt = 1, size(t % filters) + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + NO_BIN_FOUND, matching_bins(i_filt), filter_weights(i_filt)) + ! If there are no valid bins for this filter, then there is nothing to + ! score and we can move on to the next tally. + if (matching_bins(i_filt) == NO_BIN_FOUND) cycle TALLY_LOOP + end do - call get_scoring_bins(p, i_tally, found_bin) - if (.not. found_bin) cycle + ! ======================================================================== + ! Loop until we've covered all valid bins on each of the filters. - ! ======================================================================= - ! CALCULATE RESULTS AND ACCUMULATE TALLY + FILTER_LOOP: do - ! If we have made it here, we have a scoring combination of bins for this - ! tally -- now we need to determine where in the results array we should - ! be accumulating the tally values + ! Determine scoring index and weight for this filter combination + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 + filter_weight = product(filter_weights(:size(t % filters))) - ! Determine scoring index for this filter combination - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + ! ====================================================================== + ! Nuclide logic - if (t % all_nuclides) then - if (p % material /= MATERIAL_VOID) then - call score_all_nuclides(p, i_tally, flux, filter_index) - end if - else - - NUCLIDE_BIN_LOOP: do k = 1, t % n_nuclide_bins - ! Get index of nuclide in nuclides array - i_nuclide = t % nuclide_bins(k) - - if (i_nuclide > 0) then - if (p % material /= MATERIAL_VOID) then - ! Get pointer to current material - mat => materials(p % material) - - ! Determine if nuclide is actually in material - NUCLIDE_MAT_LOOP: do j = 1, mat % n_nuclides - ! If index of nuclide matches the j-th nuclide listed in the - ! material, break out of the loop - if (i_nuclide == mat % nuclide(j)) exit - - ! If we've reached the last nuclide in the material, it means - ! the specified nuclide to be tallied is not in this material - if (j == mat % n_nuclides) then - cycle NUCLIDE_BIN_LOOP - end if - end do NUCLIDE_MAT_LOOP - - atom_density = mat % atom_density(j) - else - atom_density = ZERO - end if + if (t % all_nuclides) then + if (p % material /= MATERIAL_VOID) then + call score_all_nuclides(p, i_tally, flux, filter_index) end if + else - ! Determine score for each bin - call score_general(p, t, (k-1)*t % n_score_bins, filter_index, & - i_nuclide, atom_density, flux) + NUCLIDE_BIN_LOOP: do k = 1, t % n_nuclide_bins + ! Get index of nuclide in nuclides array + i_nuclide = t % nuclide_bins(k) - end do NUCLIDE_BIN_LOOP - end if + if (i_nuclide > 0) then + if (p % material /= MATERIAL_VOID) then + ! Get pointer to current material + mat => materials(p % material) + + ! Determine if nuclide is actually in material + NUCLIDE_MAT_LOOP: do j = 1, mat % n_nuclides + ! If index of nuclide matches the j-th nuclide listed in the + ! material, break out of the loop + if (i_nuclide == mat % nuclide(j)) exit + + ! If we've reached the last nuclide in the material, it means + ! the specified nuclide to be tallied is not in this material + if (j == mat % n_nuclides) then + cycle NUCLIDE_BIN_LOOP + end if + end do NUCLIDE_MAT_LOOP + + atom_density = mat % atom_density(j) + else + atom_density = ZERO + end if + end if + + ! Determine score for each bin + call score_general(p, t, (k-1)*t % n_score_bins, filter_index, & + i_nuclide, atom_density, flux * filter_weight) + + end do NUCLIDE_BIN_LOOP + + end if + + ! ====================================================================== + ! Filter logic + + ! If there are no filters, then we are done. + if (size(t % filters) == 0) exit FILTER_LOOP + + ! Increment the filter bins, starting with the last filter. If we get a + ! NO_BIN_FOUND for the last filter, it means we finished all valid bins + ! for that filter, but next-to-last filter might have more than one + ! valid bin so we need to increment that one as well, and so on. + do i_filt = size(t % filters), 1, -1 + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + matching_bins(i_filt), matching_bins(i_filt), & + filter_weights(i_filt)) + if (matching_bins(i_filt) /= NO_BIN_FOUND) exit + end do + + ! If we got all NO_BIN_FOUNDs, then we have finished all valid bins for + ! each of the filters. Exit the loop. + if (all(matching_bins(:size(t % filters)) == NO_BIN_FOUND)) & + exit FILTER_LOOP + + ! Reset all the filters with NO_BIN_FOUND. This will set them back to + ! their first valid bin. + do i_filt = 1, size(t % filters) + if (matching_bins(i_filt) == NO_BIN_FOUND) then + call t % filters(i_filt) % obj % get_next_bin(p, t % estimator, & + matching_bins(i_filt), matching_bins(i_filt), & + filter_weights(i_filt)) + end if + end do + end do FILTER_LOOP ! If the user has specified that we can assume all tallies are spatially ! separate, this implies that once a tally has been scored to, we needn't @@ -2300,433 +2212,6 @@ contains end subroutine score_collision_tally -!=============================================================================== -! GET_SCORING_BINS determines a combination of filter bins that should be scored -! for a tally based on the particle's current attributes. -!=============================================================================== - - subroutine get_scoring_bins_ce(p, i_tally, found_bin) - - type(Particle), intent(in) :: p - integer, intent(in) :: i_tally - logical, intent(out) :: found_bin - - integer :: i ! loop index for filters - integer :: j - integer :: n ! number of bins for single filter - integer :: offset ! offset for distribcell - integer :: distribcell_index ! index in distribcell arrays - real(8) :: E ! particle energy - real(8) :: theta, phi ! Polar and Azimuthal Angles, respectively - type(TallyObject), pointer :: t - type(RegularMesh), pointer :: m - - found_bin = .true. - t => tallies(i_tally) - matching_bins(1:t%n_filters) = 1 - - FILTER_LOOP: do i = 1, t % n_filters - - select case (t % filters(i) % type) - case (FILTER_MESH) - ! determine mesh bin - m => meshes(t % filters(i) % int_bins(1)) - - ! Determine if we're in the mesh first - call get_mesh_bin(m, p % coord(1) % xyz, matching_bins(i)) - - case (FILTER_UNIVERSE) - ! determine next universe bin - ! TODO: Account for multiple universes when performing this filter - matching_bins(i) = get_next_bin(FILTER_UNIVERSE, & - p % coord(p % n_coord) % universe, i_tally) - - case (FILTER_MATERIAL) - if (p % material == MATERIAL_VOID) then - matching_bins(i) = NO_BIN_FOUND - else - matching_bins(i) = get_next_bin(FILTER_MATERIAL, & - p % material, i_tally) - endif - - case (FILTER_CELL) - ! determine next cell bin - do j = 1, p % n_coord - position(FILTER_CELL) = 0 - matching_bins(i) = get_next_bin(FILTER_CELL, & - p % coord(j) % cell, i_tally) - if (matching_bins(i) /= NO_BIN_FOUND) exit - end do - - case (FILTER_DISTRIBCELL) - ! determine next distribcell bin - distribcell_index = cells(t % filters(i) % int_bins(1)) & - % distribcell_index - matching_bins(i) = NO_BIN_FOUND - offset = 0 - do j = 1, p % n_coord - if (cells(p % coord(j) % cell) % type == CELL_FILL) then - offset = offset + cells(p % coord(j) % cell) % & - offset(distribcell_index) - elseif(cells(p % coord(j) % cell) % type == CELL_LATTICE) then - if (lattices(p % coord(j + 1) % lattice) % obj & - % are_valid_indices([& - p % coord(j + 1) % lattice_x, & - p % coord(j + 1) % lattice_y, & - p % coord(j + 1) % lattice_z])) then - offset = offset + lattices(p % coord(j + 1) % lattice) % obj % & - offset(distribcell_index, & - p % coord(j + 1) % lattice_x, & - p % coord(j + 1) % lattice_y, & - p % coord(j + 1) % lattice_z) - end if - end if - if (t % filters(i) % int_bins(1) == p % coord(j) % cell) then - matching_bins(i) = offset + 1 - exit - end if - end do - - case (FILTER_CELLBORN) - ! determine next cellborn bin - matching_bins(i) = get_next_bin(FILTER_CELLBORN, & - p % cell_born, i_tally) - - case (FILTER_SURFACE) - ! determine next surface bin - matching_bins(i) = get_next_bin(FILTER_SURFACE, & - p % surface, i_tally) - - case (FILTER_ENERGYIN) - ! determine incoming energy bin - n = t % filters(i) % n_bins - - ! make sure the correct energy is used - if (t % estimator == ESTIMATOR_TRACKLENGTH) then - E = p % E - else - E = p % last_E - end if - - ! check if energy of the particle is within energy bins - if (E < t % filters(i) % real_bins(1) .or. & - E > t % filters(i) % real_bins(n + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find incoming energy bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - n + 1, E) - end if - - case (FILTER_ENERGYOUT) - ! determine outgoing energy bin - n = t % filters(i) % n_bins - - ! check if energy of the particle is within energy bins - if (p % E < t % filters(i) % real_bins(1) .or. & - p % E > t % filters(i) % real_bins(n + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find incoming energy bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - n + 1, p % E) - end if - - case (FILTER_DELAYEDGROUP) - - if (survival_biasing .and. t % find_filter(FILTER_ENERGYOUT) <= 0) then - matching_bins(i) = 1 - elseif (active_tracklength_tallies % size() > 0) then - matching_bins(i) = 1 - else - if (p % delayed_group == 0) then - matching_bins = NO_BIN_FOUND - else - matching_bins(i) = p % delayed_group - end if - end if - - case (FILTER_MU) - ! determine mu bin - n = t % filters(i) % n_bins - - ! check if particle is within mu bins - if (p % mu < t % filters(i) % real_bins(1) .or. & - p % mu > t % filters(i) % real_bins(n + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find mu bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - n + 1, p % mu) - end if - - case (FILTER_POLAR) - ! make sure the correct direction vector is used - if (t % estimator == ESTIMATOR_TRACKLENGTH) then - theta = acos(p % coord(1) % uvw(3)) - else - theta = acos(p % last_uvw(3)) - end if - - ! determine polar angle bin - n = t % filters(i) % n_bins - - ! check if particle is within polar angle bins - if (theta < t % filters(i) % real_bins(1) .or. & - theta > t % filters(i) % real_bins(n + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find polar angle bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - n + 1, theta) - end if - - case (FILTER_AZIMUTHAL) - ! make sure the correct direction vector is used - if (t % 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 - ! determine mu bin - n = t % filters(i) % n_bins - - ! check if particle is within azimuthal angle bins - if (phi < t % filters(i) % real_bins(1) .or. & - phi > t % filters(i) % real_bins(n + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find azimuthal angle bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - n + 1, phi) - end if - - end select - - ! If the current filter didn't match, exit this subroutine - if (matching_bins(i) == NO_BIN_FOUND) then - found_bin = .false. - return - end if - - end do FILTER_LOOP - - end subroutine get_scoring_bins_ce - - subroutine get_scoring_bins_mg(p, i_tally, found_bin) - - type(Particle), intent(in) :: p - integer, intent(in) :: i_tally - logical, intent(out) :: found_bin - - integer :: i ! loop index for filters - integer :: j - integer :: n ! number of bins for single filter - integer :: distribcell_index ! index in distribcell arrays - integer :: offset ! offset for distribcell - real(8) :: theta, phi ! Polar and Azimuthal Angles, respectively - real(8) :: E - type(TallyObject), pointer :: t - type(RegularMesh), pointer :: m - - found_bin = .true. - t => tallies(i_tally) - matching_bins(1:t%n_filters) = 1 - - FILTER_LOOP: do i = 1, t % n_filters - - select case (t % filters(i) % type) - case (FILTER_MESH) - ! determine mesh bin - m => meshes(t % filters(i) % int_bins(1)) - - ! Determine if we're in the mesh first - call get_mesh_bin(m, p % coord(1) % xyz, matching_bins(i)) - - case (FILTER_UNIVERSE) - ! determine next universe bin - ! TODO: Account for multiple universes when performing this filter - matching_bins(i) = get_next_bin(FILTER_UNIVERSE, & - p % coord(p % n_coord) % universe, i_tally) - - case (FILTER_MATERIAL) - if (p % material == MATERIAL_VOID) then - matching_bins(i) = NO_BIN_FOUND - else - matching_bins(i) = get_next_bin(FILTER_MATERIAL, & - p % material, i_tally) - endif - - case (FILTER_CELL) - ! determine next cell bin - do j = 1, p % n_coord - position(FILTER_CELL) = 0 - matching_bins(i) = get_next_bin(FILTER_CELL, & - p % coord(j) % cell, i_tally) - if (matching_bins(i) /= NO_BIN_FOUND) exit - end do - - case (FILTER_DISTRIBCELL) - ! determine next distribcell bin - distribcell_index = cells(t % filters(i) % int_bins(1)) & - % distribcell_index - matching_bins(i) = NO_BIN_FOUND - offset = 0 - do j = 1, p % n_coord - if (cells(p % coord(j) % cell) % type == CELL_FILL) then - offset = offset + cells(p % coord(j) % cell) % & - offset(distribcell_index) - elseif(cells(p % coord(j) % cell) % type == CELL_LATTICE) then - if (lattices(p % coord(j + 1) % lattice) % obj & - % are_valid_indices([& - p % coord(j + 1) % lattice_x, & - p % coord(j + 1) % lattice_y, & - p % coord(j + 1) % lattice_z])) then - offset = offset + lattices(p % coord(j + 1) % lattice) % obj % & - offset(distribcell_index, & - p % coord(j + 1) % lattice_x, & - p % coord(j + 1) % lattice_y, & - p % coord(j + 1) % lattice_z) - end if - end if - if (t % filters(i) % int_bins(1) == p % coord(j) % cell) then - matching_bins(i) = offset + 1 - exit - end if - end do - - case (FILTER_CELLBORN) - ! determine next cellborn bin - matching_bins(i) = get_next_bin(FILTER_CELLBORN, & - p % cell_born, i_tally) - - case (FILTER_SURFACE) - ! determine next surface bin - matching_bins(i) = get_next_bin(FILTER_SURFACE, & - p % surface, i_tally) - - case (FILTER_ENERGYIN) - if (t % energy_matches_groups) then - ! make sure the correct energy group is used - ! Since all groups are filters, the filter bin is the group - if (t % estimator == ESTIMATOR_TRACKLENGTH) then - matching_bins(i) = p % g - else - matching_bins(i) = p % last_g - end if - ! Tallies are ordered in increasing groups, group indices - ! however are the opposite, so switch - matching_bins(i) = energy_groups - matching_bins(i) + 1 - else - ! make sure the correct energy is used - if (t % estimator == ESTIMATOR_TRACKLENGTH) then - E = p % E - else - E = p % last_E - end if - n = t % filters(i) % n_bins - - ! check if energy of the particle is within energy bins - if (E < t % filters(i) % real_bins(1) .or. & - E > t % filters(i) % real_bins(n + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find incoming energy bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - n + 1, E) - end if - end if - - case (FILTER_ENERGYOUT) - if (t % energyout_matches_groups) then - ! Since all groups are filters, the filter bin is the group - matching_bins(i) = p % g - - ! Tallies are ordered in increasing groups, group indices - ! however are the opposite, so switch - matching_bins(i) = energy_groups - matching_bins(i) + 1 - else - ! determine outgoing energy bin - n = t % filters(i) % n_bins - - ! check if energy of the particle is within energy bins - if (p % E < t % filters(i) % real_bins(1) .or. & - p % E > t % filters(i) % real_bins(n + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find incoming energy bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - n + 1, p % E) - end if - end if - - case (FILTER_MU) - ! determine mu bin - n = t % filters(i) % n_bins - - ! check if particle is within mu bins - if (p % mu < t % filters(i) % real_bins(1) .or. & - p % mu > t % filters(i) % real_bins(n + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find mu bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - n + 1, p % mu) - end if - - case (FILTER_POLAR) - ! make sure the correct direction vector is used - if (t % estimator == ESTIMATOR_TRACKLENGTH) then - theta = acos(p % coord(1) % uvw(3)) - else - theta = acos(p % last_uvw(3)) - end if - - ! determine polar angle bin - n = t % filters(i) % n_bins - - ! check if particle is within polar angle bins - if (theta < t % filters(i) % real_bins(1) .or. & - theta > t % filters(i) % real_bins(n + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find polar angle bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - n + 1, theta) - end if - - case (FILTER_AZIMUTHAL) - ! make sure the correct direction vector is used - if (t % 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 - ! determine mu bin - n = t % filters(i) % n_bins - - ! check if particle is within azimuthal angle bins - if (phi < t % filters(i) % real_bins(1) .or. & - phi > t % filters(i) % real_bins(n + 1)) then - matching_bins(i) = NO_BIN_FOUND - else - ! search to find azimuthal angle bin - matching_bins(i) = binary_search(t % filters(i) % real_bins, & - n + 1, phi) - end if - - end select - - ! If the current filter didn't match, exit this subroutine - if (matching_bins(i) == NO_BIN_FOUND) then - found_bin = .false. - return - end if - - end do FILTER_LOOP - - end subroutine get_scoring_bins_mg - !=============================================================================== ! SCORE_SURFACE_CURRENT tallies surface crossings in a mesh tally by manually ! determining which mesh surfaces were crossed @@ -2743,7 +2228,6 @@ contains integer :: ijk0(3) ! indices of starting coordinates integer :: ijk1(3) ! indices of ending coordinates integer :: n_cross ! number of surface crossings - integer :: n ! number of incoming energy bins integer :: filter_index ! index of scoring bin integer :: i_filter_mesh ! index of mesh filter in filters array integer :: i_filter_surf ! index of surface filter in filters @@ -2753,6 +2237,7 @@ contains real(8) :: xyz_cross(3) ! coordinates of bounding surfaces real(8) :: d(3) ! distance to each bounding surface real(8) :: distance ! actual distance traveled + real(8) :: filt_score ! score applied by filters logical :: start_in_mesh ! particle's starting xyz in mesh? logical :: end_in_mesh ! particle's ending xyz in mesh? logical :: x_same ! same starting/ending x index (i) @@ -2763,7 +2248,7 @@ contains TALLY_LOOP: do i = 1, active_current_tallies % size() ! Copy starting and ending location of particle - xyz0 = p % last_xyz + xyz0 = p % last_xyz_current xyz1 = p % coord(1) % xyz ! Get pointer to tally @@ -2774,8 +2259,13 @@ contains i_filter_mesh = t % find_filter(FILTER_MESH) i_filter_surf = t % find_filter(FILTER_SURFACE) + ! Get pointer to mesh + select type(filt => t % filters(i_filter_mesh) % obj) + type is (MeshFilter) + m => meshes(filt % mesh) + end select + ! Determine indices for starting and ending location - m => meshes(t % filters(i_filter_mesh) % int_bins(1)) call get_mesh_indices(m, xyz0, ijk0(:m % n_dimension), start_in_mesh) call get_mesh_indices(m, xyz1, ijk1(:m % n_dimension), end_in_mesh) @@ -2798,19 +2288,13 @@ contains ! Copy particle's direction uvw = p % coord(1) % uvw - ! determine incoming energy bin + ! Determine incoming energy bin. We need to tell the energy filter this + ! is a tracklength tally so it uses the pre-collision energy. j = t % find_filter(FILTER_ENERGYIN) if (j > 0) then - n = t % filters(j) % n_bins - ! check if energy of the particle is within energy bins - if (p % E < t % filters(j) % real_bins(1) .or. & - p % E > t % filters(j) % real_bins(n + 1)) then - cycle - end if - - ! search to find incoming energy bin - matching_bins(j) = binary_search(t % filters(j) % real_bins, & - n + 1, p % E) + call t % filters(i) % obj % get_next_bin(p, ESTIMATOR_TRACKLENGTH, & + & NO_BIN_FOUND, matching_bins(j), filt_score) + if (matching_bins(j) == NO_BIN_FOUND) cycle end if ! ======================================================================= @@ -2829,7 +2313,8 @@ contains matching_bins(i_filter_surf) = OUT_TOP matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, ijk0 + 1, .true.) - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 !$omp atomic t % results(1, filter_index) % value = & t % results(1, filter_index) % value + p % wgt @@ -2842,7 +2327,8 @@ contains matching_bins(i_filter_surf) = IN_TOP matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, ijk0 + 1, .true.) - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 !$omp atomic t % results(1, filter_index) % value = & t % results(1, filter_index) % value + p % wgt @@ -2859,7 +2345,8 @@ contains matching_bins(i_filter_surf) = OUT_FRONT matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, ijk0 + 1, .true.) - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 !$omp atomic t % results(1, filter_index) % value = & t % results(1, filter_index) % value + p % wgt @@ -2872,7 +2359,8 @@ contains matching_bins(i_filter_surf) = IN_FRONT matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, ijk0 + 1, .true.) - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 !$omp atomic t % results(1, filter_index) % value = & t % results(1, filter_index) % value + p % wgt @@ -2889,7 +2377,8 @@ contains matching_bins(i_filter_surf) = OUT_RIGHT matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, ijk0 + 1, .true.) - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 !$omp atomic t % results(1, filter_index) % value = & t % results(1, filter_index) % value + p % wgt @@ -2902,7 +2391,8 @@ contains matching_bins(i_filter_surf) = IN_RIGHT matching_bins(i_filter_mesh) = & mesh_indices_to_bin(m, ijk0 + 1, .true.) - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 !$omp atomic t % results(1, filter_index) % value = & t % results(1, filter_index) % value + p % wgt @@ -3018,7 +2508,8 @@ contains ! Determine scoring index if (matching_bins(i_filter_surf) > 0) then - filter_index = sum((matching_bins(1:t%n_filters) - 1) * t % stride) + 1 + filter_index = sum((matching_bins(1:size(t % filters)) - 1) & + * t % stride) + 1 ! Check for errors if (filter_index <= 0 .or. filter_index > & @@ -3040,61 +2531,6 @@ contains end subroutine score_surface_current -!=============================================================================== -! GET_NEXT_BIN determines the next scoring bin for a particular filter variable -!=============================================================================== - - function get_next_bin(filter_type, filter_value, i_tally) result(bin) - - integer, intent(in) :: filter_type ! e.g. FILTER_MATERIAL - integer, intent(in) :: filter_value ! value of filter, e.g. material 3 - integer, intent(in) :: i_tally ! index of tally - integer :: bin ! index of filter - - integer :: i_tally_check - integer :: n - - ! If there are no scoring bins for this item, then return immediately - if (.not. allocated(tally_maps(filter_type) % items(filter_value) % elements)) then - bin = NO_BIN_FOUND - return - end if - - ! Check how many elements there are for this item - n = size(tally_maps(filter_type) % items(filter_value) % elements) - - do - ! Increment position in elements - position(filter_type) = position(filter_type) + 1 - - ! If we've reached the end of the array, there is no more bin to score to - if (position(filter_type) > n) then - position(filter_type) = 0 - bin = NO_BIN_FOUND - return - end if - - i_tally_check = tally_maps(filter_type) % items(filter_value) % & - elements(position(filter_type)) % index_tally - - if (i_tally_check > i_tally) then - ! Since the index being checked against is greater than the index we - ! need (and the tally indices were added to elements sequentially), we - ! know that no more bins will be scoring bins for this tally - position(filter_type) = 0 - bin = NO_BIN_FOUND - return - elseif (i_tally_check == i_tally) then - ! Found a match - bin = tally_maps(filter_type) % items(filter_value) % & - elements(position(filter_type)) % index_bin - return - end if - - end do - - end function get_next_bin - !=============================================================================== ! SYNCHRONIZE_TALLIES accumulates the sum of the contributions from each history ! within the batch to a new random variable diff --git a/src/tally_filter.F90 b/src/tally_filter.F90 new file mode 100644 index 0000000000..c0e1c88534 --- /dev/null +++ b/src/tally_filter.F90 @@ -0,0 +1,1491 @@ +module tally_filter + + use constants, only: ONE, NO_BIN_FOUND, FP_PRECISION + use dict_header, only: DictIntInt + use geometry_header, only: BASE_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_2d, mesh_intersects_3d + use particle_header, only: Particle + use search, only: binary_search + use string, only: to_str + use tally_filter_header, only: TallyFilter, TallyFilterContainer + + 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_next_bin => get_next_bin_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_next_bin => get_next_bin_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_next_bin => get_next_bin_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_next_bin => get_next_bin_cell + procedure :: to_statepoint => to_statepoint_cell + procedure :: text_label => text_label_cell + procedure :: initialize => initialize_cell + end type CellFilter + +!=============================================================================== +! DISTRIBCELLFILTER specifies which distributed geometric cells tally events +! reside in. +!=============================================================================== + type, extends(TallyFilter) :: DistribcellFilter + integer :: cell + contains + procedure :: get_next_bin => get_next_bin_distribcell + procedure :: to_statepoint => to_statepoint_distribcell + procedure :: to_summary => to_summary_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_next_bin => get_next_bin_cellborn + procedure :: to_statepoint => to_statepoint_cellborn + procedure :: text_label => text_label_cellborn + procedure :: initialize => initialize_cellborn + end type CellbornFilter + +!=============================================================================== +! SURFACEFILTER is currently not implemented for usual geometric surfaces, but +! it is used as a placeholder for mesh surfaces used in current tallies. +!=============================================================================== + type, extends(TallyFilter) :: SurfaceFilter + integer, allocatable :: surfaces(:) + contains + procedure :: get_next_bin => get_next_bin_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_next_bin => get_next_bin_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_next_bin 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_next_bin => get_next_bin_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_next_bin 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_next_bin => get_next_bin_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_next_bin => get_next_bin_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_next_bin => get_next_bin_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_next_bin => get_next_bin_azimuthal + procedure :: to_statepoint => to_statepoint_azimuthal + procedure :: text_label => text_label_azimuthal + end type AzimuthalFilter + +contains + +!=============================================================================== +! METHODS: for a description of these methods, see their counterparts bound to +! the abstract TallyFilter class. +!=============================================================================== + +!=============================================================================== +! MeshFilter methods +!=============================================================================== + subroutine get_next_bin_mesh(this, p, estimator, current_bin, next_bin, & + weight) + class(MeshFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + 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 :: ijk0(3) ! indices of starting coordinates + integer :: ijk1(3) ! indices of ending coordinates + integer :: search_iter ! loop count for intersection search + 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 + + ! Get a pointer to the mesh. + m => meshes(this % mesh) + + if (estimator /= ESTIMATOR_TRACKLENGTH) then + ! If this is an analog or collision tally, then there can only be one + ! valid mesh bin. + if (current_bin == NO_BIN_FOUND) then + call get_mesh_bin(m, p % coord(1) % xyz, next_bin) + else + next_bin = NO_BIN_FOUND + end if + weight = ONE + + else + ! A track can span multiple mesh bins so we need to handle a lot of + ! intersection logic for tracklength tallies. + + ! 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(:m % n_dimension), start_in_mesh) + call get_mesh_indices(m, xyz1, ijk1(:m % n_dimension), end_in_mesh) + + ! If this is the first iteration of the filter loop, check if the track + ! intersects any part of the mesh. + if (current_bin == NO_BIN_FOUND) then + if ((.not. start_in_mesh) .and. (.not. end_in_mesh)) then + if (m % n_dimension == 2) then + if (.not. mesh_intersects_2d(m, xyz0, xyz1)) then + next_bin = NO_BIN_FOUND + return + end if + else + if (.not. mesh_intersects_3d(m, xyz0, xyz1)) then + next_bin = NO_BIN_FOUND + return + end if + end if + end if + end if + + ! 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)) + + ! If we're looking for the first valid bin, check to see if the particle + ! starts inside the mesh. + if (current_bin == NO_BIN_FOUND) then + if (any(ijk0(:m % n_dimension) < 1) & + .or. any(ijk0(:m % n_dimension) > m % dimension)) then + + ! 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(:m % n_dimension) < 1) & + .or. any(ijk0(:m % n_dimension) > m % dimension)) + if (search_iter == MAX_SEARCH_ITER) call fatal_error("Failed to & + &find a mesh intersection on a tally mesh filter.") + + do j = 1, m % n_dimension + 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(:m % n_dimension), 1) + if (uvw(j) > ZERO) then + ijk0(j) = ijk0(j) + 1 + else + ijk0(j) = ijk0(j) - 1 + end if + end do + distance = d(j) + xyz0 = xyz0 + distance * uvw + + end if + end if + + ! ======================================================================== + ! If we've already scored some mesh bins, figure out which mesh cell is + ! next and where the particle enters that cell. + + if (current_bin /= NO_BIN_FOUND) then + ! Get the indices to the last bin. + call bin_to_mesh_indices(m, current_bin, ijk0(:m % n_dimension)) + + ! If the particle track ends in that bin, then we are done. + if (all(ijk0(:m % n_dimension) == ijk1(:m % n_dimension))) then + next_bin = NO_BIN_FOUND + return + end if + + ! Figure out which face of the previous mesh cell our track exits, i.e. + ! the closest surface of that cell for which + ! dot(p % uvw, face_normal) > 0. + do j = 1, m % n_dimension + 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(:m % n_dimension), 1) + + ! 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. + distance = d(j) + 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(:m % n_dimension) < 1) & + .or. any(ijk0(:m % n_dimension) > m % dimension)) then + next_bin = NO_BIN_FOUND + return + end if + end if + + ! Compute the length of the track segment in this mesh cell. + if (all(ijk0(:m % n_dimension) == ijk1(:m % n_dimension))) 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. Use the distance to the mesh surface. + do j = 1, m % n_dimension + 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 + distance = minval(d(:m % n_dimension)) + end if + + ! Assign the next tally bin and the score + next_bin = mesh_indices_to_bin(m, ijk0(:m % n_dimension)) + weight = distance / total_distance + endif + end subroutine get_next_bin_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", this % mesh ) + 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 == 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_next_bin_universe(this, p, estimator, current_bin, next_bin, & + weight) + class(UniverseFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + integer :: i, start + + ! Find the coordinate level of the last bin we found. + if (current_bin == NO_BIN_FOUND) then + start = 1 + else + do i = 1, p % n_coord + if (p % coord(i) % universe == this % universes(current_bin)) then + start = i + 1 + exit + end if + end do + end if + + ! Starting one coordinate level deeper, find the next bin. + next_bin = NO_BIN_FOUND + do i = start, p % n_coord + if (this % map % has_key(p % coord(i) % universe)) then + next_bin = this % map % get_key(p % coord(i) % universe) + exit + end if + end do + weight = ONE + end subroutine get_next_bin_universe + + subroutine to_statepoint_universe(this, filter_group) + class(UniverseFilter), intent(in) :: this + integer(HID_T), intent(in) :: filter_group + + call write_dataset(filter_group, "type", "universe") + call write_dataset(filter_group, "n_bins", this % n_bins) + call write_dataset(filter_group, "bins", this % universes ) + 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_next_bin_material(this, p, estimator, current_bin, next_bin, & + weight) + class(MaterialFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + next_bin = NO_BIN_FOUND + if (current_bin == NO_BIN_FOUND) then + if (this % map % has_key(p % material)) then + next_bin = this % map % get_key(p % material) + end if + end if + weight = ONE + end subroutine get_next_bin_material + + subroutine to_statepoint_material(this, filter_group) + class(MaterialFilter), intent(in) :: this + integer(HID_T), intent(in) :: filter_group + + call write_dataset(filter_group, "type", "material") + call write_dataset(filter_group, "n_bins", this % n_bins) + call write_dataset(filter_group, "bins", this % materials ) + 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_next_bin_cell(this, p, estimator, current_bin, next_bin, & + weight) + class(CellFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + integer :: i, start + + ! Find the coordinate level of the last bin we found. + if (current_bin == NO_BIN_FOUND) then + start = 1 + else + do i = 1, p % n_coord + if (p % coord(i) % cell == this % cells(current_bin)) then + start = i + 1 + exit + end if + end do + end if + + ! Starting one coordinate level deeper, find the next bin. + next_bin = NO_BIN_FOUND + do i = start, p % n_coord + if (this % map % has_key(p % coord(i) % cell)) then + next_bin = this % map % get_key(p % coord(i) % cell) + exit + end if + end do + weight = ONE + end subroutine get_next_bin_cell + + subroutine to_statepoint_cell(this, filter_group) + class(CellFilter), intent(in) :: this + integer(HID_T), intent(in) :: filter_group + + call write_dataset(filter_group, "type", "cell") + call write_dataset(filter_group, "n_bins", this % n_bins) + call write_dataset(filter_group, "bins", this % cells ) + 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 + +!=============================================================================== +! DistribcellFilter methods +!=============================================================================== + subroutine get_next_bin_distribcell(this, p, estimator, current_bin, & + next_bin, weight) + class(DistribcellFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + logical :: cell_found + integer :: distribcell_index, offset, i + + cell_found = .false. + if (current_bin == NO_BIN_FOUND) then + distribcell_index = cells(this % cell) % distribcell_index + offset = 0 + do i = 1, p % n_coord + if (cells(p % coord(i) % cell) % type == CELL_FILL) then + offset = offset + cells(p % coord(i) % cell) % & + offset(distribcell_index) + elseif (cells(p % coord(i) % cell) % type == CELL_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 + next_bin = offset + 1 + cell_found = .true. + exit + end if + end do + else + next_bin = NO_BIN_FOUND + end if + if (.not. cell_found) next_bin = NO_BIN_FOUND + weight = ONE + end subroutine get_next_bin_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", this % cell ) + end subroutine to_statepoint_distribcell + + subroutine to_summary_distribcell(this, filter_group) + class(DistribcellFilter), intent(in) :: this + integer(HID_T), intent(in) :: filter_group + + integer :: offset, k + character(MAX_LINE_LEN), allocatable :: paths(:) + character(MAX_LINE_LEN) :: path + + call write_dataset(filter_group, "type", "distribcell") + call write_dataset(filter_group, "n_bins", this % n_bins) + call write_dataset(filter_group, "bins", this % cell ) + + ! Write paths to reach each distribcell instance + + ! Allocate array of strings for each distribcell path + allocate(paths(this % n_bins)) + + ! Store path for each distribcell instance + do k = 1, this % n_bins + path = '' + offset = 1 + call find_offset(this % cell, universes(BASE_UNIVERSE), k, offset, path) + paths(k) = path + end do + + ! Write array of distribcell paths to summary file + call write_dataset(filter_group, "paths", paths) + deallocate(paths) + end subroutine to_summary_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(BASE_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_next_bin_cellborn(this, p, estimator, current_bin, next_bin, & + weight) + class(CellbornFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + next_bin = NO_BIN_FOUND + if (current_bin == NO_BIN_FOUND) then + if (this % map % has_key(p % cell_born)) then + next_bin = this % map % get_key(p % cell_born) + end if + end if + weight = ONE + end subroutine get_next_bin_cellborn + + subroutine to_statepoint_cellborn(this, filter_group) + class(CellbornFilter), intent(in) :: this + integer(HID_T), intent(in) :: filter_group + + call write_dataset(filter_group, "type", "cellborn") + call write_dataset(filter_group, "n_bins", this % n_bins) + call write_dataset(filter_group, "bins", this % cells ) + 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_next_bin_surface(this, p, estimator, current_bin, next_bin, & + weight) + class(SurfaceFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + integer :: i + + next_bin = NO_BIN_FOUND + if (current_bin == NO_BIN_FOUND) then + do i = 1, this % n_bins + if (p % surface == this % surfaces(i)) then + next_bin = i + exit + end if + end do + end if + weight = ONE + end subroutine get_next_bin_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_next_bin_energy(this, p, estimator, current_bin, next_bin, & + weight) + class(EnergyFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + integer :: n + real(8) :: E + + if (current_bin == NO_BIN_FOUND) then + n = this % n_bins + + if ((.not. run_CE) .and. this % matches_transport_groups) then + if (estimator == ESTIMATOR_TRACKLENGTH) then + next_bin = p % g + else + next_bin = p % last_g + end if + + ! Tallies are ordered in increasing groups, group indices + ! however are the opposite, so switch + next_bin = energy_groups - next_bin + 1 + + else + ! Make sure the correct energy is used. + if (estimator == ESTIMATOR_TRACKLENGTH) then + E = p % E + else + E = p % last_E + end if + + ! Check if energy of the particle is within energy bins. + if (E < this % bins(1) .or. E > this % bins(n + 1)) then + next_bin = NO_BIN_FOUND + else + ! Search to find incoming energy bin. + next_bin = binary_search(this % bins, n + 1, E) + end if + end if + + else + next_bin = NO_BIN_FOUND + end if + weight = ONE + end subroutine get_next_bin_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_next_bin_energyout(this, p, estimator, current_bin, next_bin, & + weight) + class(EnergyoutFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + integer :: n + + if (current_bin == NO_BIN_FOUND) then + n = this % n_bins + + if ((.not. run_CE) .and. this % matches_transport_groups) then + next_bin = p % g + + ! Tallies are ordered in increasing groups, group indices + ! however are the opposite, so switch + next_bin = energy_groups - next_bin + 1 + + else + ! Check if energy of the particle is within energy bins. + if (p % E < this % bins(1) .or. p % E > this % bins(n + 1)) then + next_bin = NO_BIN_FOUND + else + ! Search to find incoming energy bin. + next_bin = binary_search(this % bins, n + 1, p % E) + end if + end if + + else + next_bin = NO_BIN_FOUND + end if + weight = ONE + end subroutine get_next_bin_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_next_bin_dg(this, p, estimator, current_bin, next_bin, weight) + class(DelayedGroupFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + if (current_bin == NO_BIN_FOUND) then + next_bin = 1 + else + next_bin = NO_BIN_FOUND + end if + weight = ONE + end subroutine get_next_bin_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_next_bin_mu(this, p, estimator, current_bin, next_bin, weight) + class(MuFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + integer :: n + + if (current_bin == NO_BIN_FOUND) then + n = this % n_bins + + ! Check if energy of the particle is within energy bins. + if (p % mu < this % bins(1) .or. p % mu > this % bins(n + 1)) then + next_bin = NO_BIN_FOUND + else + ! Search to find incoming energy bin. + next_bin = binary_search(this % bins, n + 1, p % mu) + end if + + else + next_bin = NO_BIN_FOUND + end if + weight = ONE + end subroutine get_next_bin_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_next_bin_polar(this, p, estimator, current_bin, next_bin, & + weight) + class(PolarFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + integer :: n + real(8) :: theta + + if (current_bin == NO_BIN_FOUND) then + 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 + + ! Check if particle is within polar angle bins. + if (theta < this % bins(1) .or. theta > this % bins(n + 1)) then + next_bin = NO_BIN_FOUND + else + ! Search to find polar angle bin. + next_bin = binary_search(this % bins, n + 1, theta) + end if + + else + next_bin = NO_BIN_FOUND + end if + weight = ONE + end subroutine get_next_bin_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_next_bin_azimuthal(this, p, estimator, current_bin, next_bin, & + weight) + class(AzimuthalFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + + integer :: n + real(8) :: phi + + if (current_bin == NO_BIN_FOUND) then + 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 + + ! Check if particle is within azimuthal angle bins. + if (phi < this % bins(1) .or. phi > this % bins(n + 1)) then + next_bin = NO_BIN_FOUND + else + ! Search to find azimuthal angle bin. + next_bin = binary_search(this % bins, n + 1, phi) + end if + + else + next_bin = NO_BIN_FOUND + end if + weight = ONE + end subroutine get_next_bin_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 + +!=============================================================================== +! 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(goal, univ, final, offset, path) + + integer, intent(in) :: goal ! The target cell index + type(Universe), intent(in) :: univ ! Universe to begin search + integer, intent(in) :: final ! 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 + 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(goal) % distribcell_index + + n = univ % n_cells + + ! Write to the geometry stack + if (univ%id == 0) then + path = trim(path) // to_str(univ%id) + else + path = trim(path) // "->" // 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) == goal .and. offset == final) then + c => cells(univ % cells(i)) + path = trim(path) // "->" // 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. + + cell_index = univ % cells(i) + c => cells(cell_index) + + 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 + + cell_index = univ % cells(j) + c => cells(cell_index) + + ! Skip normal cells which do not have offsets + if (c % type == CELL_NORMAL) then + cycle + end if + + ! 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 /= CELL_NORMAL) 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 == CELL_FILL) 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 (final < temp_offset + offset) then + this_cell = .true. + end if + end if + end if + + if (n == 1 .and. c % type /= CELL_NORMAL) 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) // "->" // to_str(c%id) + + ! ==================================================================== + ! CELL CONTAINS LOWER UNIVERSE, RECURSIVELY FIND CELL + if (c % type == CELL_FILL) then + + ! Enter this cell to update the current offset + offset = c % offset(map) + offset + + next_univ => universes(c % fill) + call find_offset(goal, next_univ, final, offset, path) + return + + ! ==================================================================== + ! CELL CONTAINS LATTICE, RECURSIVELY FIND CELL + elseif (c % type == CELL_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) // "->" // 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 (final >= 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)) + path = trim(path) // "(" // trim(to_str(k)) // & + "," // trim(to_str(l)) // "," // & + trim(to_str(m)) // ")" + call find_offset(goal, next_univ, final, 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)) + path = trim(path) // "(" // trim(to_str(old_k)) // & + "," // trim(to_str(old_l)) // "," // & + trim(to_str(old_m)) // ")" + call find_offset(goal, next_univ, final, offset, path) + return + end if + + end do + end do + end do + + ! ================================================================== + ! HEXAGONAL LATTICES + type is (HexLattice) + + ! Write to the geometry stack + path = trim(path) // "->" // 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 (final >= 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)) + path = trim(path) // "(" // & + trim(to_str(k - lat % n_rings)) // "," // & + trim(to_str(l - lat % n_rings)) // "," // & + trim(to_str(m)) // ")" + call find_offset(goal, next_univ, final, 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)) + path = trim(path) // "(" // & + trim(to_str(old_k - lat % n_rings)) // "," // & + trim(to_str(old_l - lat % n_rings)) // "," // & + trim(to_str(old_m)) // ")" + call find_offset(goal, next_univ, final, 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 diff --git a/src/tally_filter_header.F90 b/src/tally_filter_header.F90 new file mode 100644 index 0000000000..43ef846e3e --- /dev/null +++ b/src/tally_filter_header.F90 @@ -0,0 +1,105 @@ +module tally_filter_header + + use constants, only: MAX_LINE_LEN + use particle_header, only: Particle + + use hdf5 + + implicit none + +!=============================================================================== +! 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 :: n_bins = 0 + contains + procedure(get_next_bin_), deferred :: get_next_bin + procedure(to_statepoint_), deferred :: to_statepoint + procedure :: to_summary => filter_to_summary + 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_next_bin_(this, p, estimator, current_bin, next_bin, weight) + import TallyFilter + import Particle + class(TallyFilter), intent(in) :: this + type(Particle), intent(in) :: p + integer, intent(in) :: estimator + integer, value, intent(in) :: current_bin + integer, intent(out) :: next_bin + real(8), intent(out) :: weight + end subroutine get_next_bin_ + +!=============================================================================== +! 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 + +!=============================================================================== +! TO_SUMMARY writes all the information needed to reconstruct the filter to the +! given filter_group. If this procedure is not overridden by the derived class, +! then it will call to_statepoint by default. + + subroutine filter_to_summary(this, filter_group) + class(TallyFilter), intent(in) :: this + integer(HID_T), intent(in) :: filter_group + + call this % to_statepoint(filter_group) + end subroutine filter_to_summary + +!=============================================================================== +! 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 index 8db9ab0e1b..fe385458b2 100644 --- a/src/tally_header.F90 +++ b/src/tally_header.F90 @@ -1,41 +1,13 @@ module tally_header - use constants, only: NONE, N_FILTER_TYPES - use trigger_header, only: TriggerObject + use constants, only: NONE, N_FILTER_TYPES + use tally_filter_header, only: TallyFilterContainer + use trigger_header, only: TriggerObject + use, intrinsic :: ISO_C_BINDING implicit none -!=============================================================================== -! TALLYMAPELEMENT gives an index to a tally which is to be scored and the -! corresponding bin for the filter variable -!=============================================================================== - - type TallyMapElement - integer :: index_tally - integer :: index_bin - end type TallyMapElement - -!=============================================================================== -! TALLYMAPITEM contains a list of tally/bin combinations for each mappable -! filter bin specified. -!=============================================================================== - - type TallyMapItem - type(TallyMapElement), allocatable :: elements(:) - end type TallyMapItem - -!=============================================================================== -! TALLYMAP contains a list of pairs of indices to tallies and the corresponding -! bin for a given filter. There is one TallyMap for each mappable filter -! type. The items array is as long as the corresponding array for that filter, -! e.g. for tally_maps(FILTER_CELL), items is n_cells long. -!=============================================================================== - - type TallyMap - type(TallyMapItem), allocatable :: items(:) - end type TallyMap - !=============================================================================== ! TALLYRESULT provides accumulation of results in a particular tally bin !=============================================================================== @@ -46,19 +18,6 @@ module tally_header real(C_DOUBLE) :: sum_sq = 0. end type TallyResult -!=============================================================================== -! 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 TallyFilter - integer :: type = NONE - integer :: n_bins = 0 - integer, allocatable :: int_bins(:) - real(8), allocatable :: real_bins(:) ! Only used for energy filters - end type TallyFilter - !=============================================================================== ! 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 @@ -73,11 +32,7 @@ module tally_header integer :: type ! volume, surface current integer :: estimator ! collision, track-length real(8) :: volume ! volume of region - - ! Information about what filters should be used - - integer :: n_filters ! Number of filters - type(TallyFilter), allocatable :: filters(:) ! Filter data (type/bins) + type(TallyFilterContainer), allocatable :: filters(:) ! The stride attribute is used for determining the index in the results ! array for a matching_bin combination. Since multiple dimensions are @@ -124,10 +79,6 @@ module tally_header ! Tally precision triggers integer :: n_triggers = 0 ! # of triggers type(TriggerObject), allocatable :: triggers(:) ! Array of triggers - - ! Multi-Group Specific Information To Enable Rapid Tallying - logical :: energy_matches_groups = .false. - logical :: energyout_matches_groups = .false. end type TallyObject end module tally_header diff --git a/src/tally_initialize.F90 b/src/tally_initialize.F90 index 73aa18c60c..1ae403bd65 100644 --- a/src/tally_initialize.F90 +++ b/src/tally_initialize.F90 @@ -2,7 +2,7 @@ module tally_initialize use constants use global - use tally_header, only: TallyObject, TallyMapElement, TallyMapItem + use tally_header, only: TallyObject implicit none private @@ -23,7 +23,6 @@ contains allocate(global_tallies(N_GLOBAL_TALLIES)) call setup_tally_arrays() - call setup_tally_maps() end subroutine configure_tallies @@ -45,17 +44,17 @@ contains t => tallies(i) ! Allocate stride and matching_bins arrays - allocate(t % stride(t % n_filters)) - max_n_filters = max(max_n_filters, t % n_filters) + allocate(t % stride(size(t % filters))) + max_n_filters = max(max_n_filters, size(t % filters)) ! 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 = t % n_filters, 1, -1 + STRIDE: do j = size(t % filters), 1, -1 t % stride(j) = n - n = n * t % filters(j) % n_bins + n = n * t % filters(j) % obj % n_bins end do STRIDE ! Set total number of filter and scoring bins @@ -70,101 +69,11 @@ contains ! Allocate array for matching filter bins !$omp parallel allocate(matching_bins(max_n_filters)) + allocate(filter_weights(max_n_filters)) !$omp end parallel end subroutine setup_tally_arrays -!=============================================================================== -! SETUP_TALLY_MAPS creates a map that allows a quick determination of which -! tallies and bins need to be scored to when a particle makes a collision. This -! subroutine also sets the stride attribute for each tally as well as allocating -! storage for the results array. -!=============================================================================== - - subroutine setup_tally_maps() - - integer :: i ! loop index for tallies - integer :: j ! loop index for filters - integer :: k ! loop index for bins - integer :: bin ! filter bin entries - integer :: type ! type of tally filter - type(TallyObject), pointer :: t - - ! allocate tally map array -- note that we don't need a tally map for the - ! energy_in and energy_out filters - allocate(tally_maps(N_FILTER_TYPES - 3)) - - ! allocate list of items for each different filter type - allocate(tally_maps(FILTER_UNIVERSE) % items(n_universes)) - allocate(tally_maps(FILTER_MATERIAL) % items(n_materials)) - allocate(tally_maps(FILTER_CELL) % items(n_cells)) - allocate(tally_maps(FILTER_CELLBORN) % items(n_cells)) - allocate(tally_maps(FILTER_SURFACE) % items(n_surfaces)) - - TALLY_LOOP: do i = 1, n_tallies - ! Get pointer to tally - t => tallies(i) - - ! No need to set up tally maps for surface current tallies - if (t % type == TALLY_SURFACE_CURRENT) cycle - - FILTER_LOOP: do j = 1, t % n_filters - ! Determine type of filter - type = t % filters(j) % type - - if (type == FILTER_CELL .or. type == FILTER_SURFACE .or. & - type == FILTER_MATERIAL .or. type == FILTER_UNIVERSE .or. & - type == FILTER_CELLBORN) then - - ! Add map elements - BIN_LOOP: do k = 1, t % filters(j) % n_bins - bin = t % filters(j) % int_bins(k) - call add_map_element(tally_maps(type) % items(bin), i, k) - end do BIN_LOOP - end if - - end do FILTER_LOOP - - end do TALLY_LOOP - - end subroutine setup_tally_maps - -!=============================================================================== -! ADD_MAP_ELEMENT adds a pair of tally and bin indices to the list for a given -! cell/surface/etc. -!=============================================================================== - - subroutine add_map_element(item, index_tally, index_bin) - - type(TallyMapItem), intent(inout) :: item - integer, intent(in) :: index_tally ! index in tallies array - integer, intent(in) :: index_bin ! index in bins array - - integer :: n ! size of elements array - type(TallyMapElement), allocatable :: temp(:) - - if (.not. allocated(item % elements)) then - allocate(item % elements(1)) - item % elements(1) % index_tally = index_tally - item % elements(1) % index_bin = index_bin - else - ! determine size of elements array - n = size(item % elements) - - ! allocate temporary storage and copy elements - allocate(temp(n+1)) - temp(1:n) = item % elements - - ! move allocation back to main array - call move_alloc(FROM=temp, TO=item%elements) - - ! set new element - item % elements(n+1) % index_tally = index_tally - item % elements(n+1) % index_bin = index_bin - end if - - end subroutine add_map_element - !=============================================================================== ! 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 diff --git a/src/tracking.F90 b/src/tracking.F90 index d52b09a75d..69fb78c354 100644 --- a/src/tracking.F90 +++ b/src/tracking.F90 @@ -191,7 +191,7 @@ contains p % fission = .false. ! Save coordinates for tallying purposes - p % last_xyz = p % coord(1) % xyz + p % last_xyz_current = p % coord(1) % xyz ! Set last material to none since cross sections will need to be ! re-evaluated @@ -211,6 +211,9 @@ contains end do end if + ! Save coordinates for tallying purposes + p % last_xyz = p % coord(1) % xyz + ! If particle has too many events, display warning and kill it n_event = n_event + 1 if (n_event == MAX_EVENTS) then diff --git a/src/trigger.F90 b/src/trigger.F90 index ed362154b4..2fd0e2a121 100644 --- a/src/trigger.F90 +++ b/src/trigger.F90 @@ -12,6 +12,7 @@ module trigger use mesh_header, only: RegularMesh use trigger_header, only: TriggerObject use tally, only: TallyObject + use tally_filter, only: MeshFilter implicit none @@ -165,7 +166,7 @@ contains else ! Initialize bins, filter level - matching_bins(1:t % n_filters) = 0 + matching_bins(1:size(t % filters)) = 0 FILTER_LOOP: do filter_index = 1, t % total_filter_bins @@ -265,7 +266,7 @@ contains end if end if end do NUCLIDE_LOOP - if (t % n_filters == 0) exit FILTER_LOOP + if (size(t % filters) == 0) exit FILTER_LOOP end do FILTER_LOOP end if end do TRIGGER_LOOP @@ -300,16 +301,19 @@ contains ! Get pointer to mesh i_filter_mesh = t % find_filter(FILTER_MESH) i_filter_surf = t % find_filter(FILTER_SURFACE) - m => meshes(t % filters(i_filter_mesh) % int_bins(1)) + select type(filt => t % filters(i_filter_mesh) % obj) + type is (MeshFilter) + m => meshes(filt % mesh) + end select ! initialize bins array - matching_bins(1:t % n_filters) = 1 + matching_bins(1:size(t % filters)) = 1 ! determine how many energyin bins there are i_filter_ein = t % find_filter(FILTER_ENERGYIN) if (i_filter_ein > 0) then print_ebin = .true. - n = t % filters(i_filter_ein) % n_bins + n = t % filters(i_filter_ein) % obj % n_bins else print_ebin = .false. n = 1 @@ -329,7 +333,7 @@ contains mesh_indices_to_bin(m, (/ i-1, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_RIGHT filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev @@ -341,7 +345,7 @@ contains matching_bins(i_filter_surf) = OUT_RIGHT filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev @@ -356,7 +360,7 @@ contains mesh_indices_to_bin(m, (/ i, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_RIGHT filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev @@ -368,7 +372,7 @@ contains matching_bins(i_filter_surf) = OUT_RIGHT filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev @@ -383,7 +387,7 @@ contains mesh_indices_to_bin(m, (/ i, j-1, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_FRONT filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev @@ -396,7 +400,7 @@ contains matching_bins(i_filter_surf) = OUT_FRONT filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev @@ -411,7 +415,7 @@ contains mesh_indices_to_bin(m, (/ i, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_FRONT filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev @@ -423,7 +427,7 @@ contains matching_bins(i_filter_surf) = OUT_FRONT filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev @@ -438,7 +442,7 @@ contains mesh_indices_to_bin(m, (/ i, j, k-1 /) + 1, .true.) matching_bins(i_filter_surf) = IN_TOP filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev @@ -450,7 +454,7 @@ contains matching_bins(i_filter_surf) = OUT_TOP filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev @@ -465,7 +469,7 @@ contains mesh_indices_to_bin(m, (/ i, j, k /) + 1, .true.) matching_bins(i_filter_surf) = IN_TOP filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev @@ -477,7 +481,7 @@ contains matching_bins(i_filter_surf) = OUT_TOP filter_index = & - sum((matching_bins(1:t % n_filters) - 1) * t % stride) + 1 + sum((matching_bins(1:size(t % filters)) - 1) * t % stride) + 1 call get_trigger_uncertainty(std_dev, rel_err, 1, filter_index, t) if (trigger % std_dev < std_dev) then trigger % std_dev = std_dev diff --git a/tests/test_score_current/results_true.dat b/tests/test_score_current/results_true.dat index d3ac03a709..5d26226ae2 100644 --- a/tests/test_score_current/results_true.dat +++ b/tests/test_score_current/results_true.dat @@ -1 +1 @@ -a9310752363eb059ff40f16ac9716b41ccab6ec6607d29f498069318745e485d18d784264304cc2586865bd58cef7587203cc22a1d485c58ddd63c14c0defdb9 \ No newline at end of file +bafab1921a12146abb2bb29603b52b9cc28a5a950a7a6bb1e3f012c05891c310fad643760d4f148b04d0fef3d1f3e141d146e3a278d81cc6fc8187c37717c5e7 \ No newline at end of file diff --git a/tests/test_tallies/inputs_true.dat b/tests/test_tallies/inputs_true.dat index 17f04238c2..9d67bc0d03 100644 --- a/tests/test_tallies/inputs_true.dat +++ b/tests/test_tallies/inputs_true.dat @@ -1 +1 @@ -ca47172a42f6c13b244a763c990cbe4811662708ee03307d810a4542ee34bb5db7cc29d66aea313dad95b9f38a4ff7943ded527cfd0c7c8825372fec40cfc0d0 \ No newline at end of file +930af242a043f2676a000dbc5a2db6b148edcb31ed8c87dbaa35a8efb37a3be8cff30cdf4dc03f9c5c7eb4021f7e4c3327e64681cdd8fd8722c95c69db850227 \ No newline at end of file diff --git a/tests/test_tallies/results_true.dat b/tests/test_tallies/results_true.dat index 76ad489ca1..7aa65e1c19 100644 --- a/tests/test_tallies/results_true.dat +++ b/tests/test_tallies/results_true.dat @@ -1 +1 @@ -7d085e38f331083a8c3f7814eb6025f9457a1a8e3899e7d9a65af1ba92ea75c0182fcc605d4eadd3eb7edfc0949df688d39a3f45683e10cbdcfb6d7954f34129 \ No newline at end of file +a51db2a4efc681805f85968e04411dc33beee0532c202f5179b9a82880ab60a75e53fa9141c81045ea1d2842372f2d8da900326f09382ea61dd80a3c9b43bba1 \ No newline at end of file diff --git a/tests/test_tallies/test_tallies.py b/tests/test_tallies/test_tallies.py index 0e8d622680..ba0098513c 100644 --- a/tests/test_tallies/test_tallies.py +++ b/tests/test_tallies/test_tallies.py @@ -113,10 +113,11 @@ class TalliesTestHarness(PyAPITestHarness): polar_tally4.estimator = 'tracklength' universe_tally = Tally() - universe_tally.filters = [Filter(type='universe', bins=(1, 2, 3, 4))] + universe_tally.filters = [ + Filter(type='universe', bins=(1, 2, 3, 4, 6, 8))] universe_tally.scores = ['total'] - cell_filter = Filter(type='cell', bins=(10, 21, 22, 23)) + cell_filter = Filter(type='cell', bins=(10, 21, 22, 23, 60)) score_tallies = [Tally(), Tally(), Tally()] for t in score_tallies: t.filters = [cell_filter] @@ -128,7 +129,7 @@ class TalliesTestHarness(PyAPITestHarness): score_tallies[1].estimator = 'analog' score_tallies[2].estimator = 'collision' - cell_filter2 = Filter(type='cell', bins=(21, 22, 23, 27, 28, 29)) + cell_filter2 = Filter(type='cell', bins=(21, 22, 23, 27, 28, 29, 60)) flux_tallies = [Tally() for i in range(4)] for t in flux_tallies: t.filters = [cell_filter2]