From 1d73c6d5093fffb55cb6d655ae417c324f09ca17 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sat, 12 Nov 2011 10:37:57 -0800 Subject: [PATCH 01/70] Added ability to treat multiple interpolation regions in interpolate_tab1 functions. --- src/DEPENDENCIES | 1 + src/interpolation.f90 | 25 +++++++++++++++++++++---- 2 files changed, 22 insertions(+), 4 deletions(-) diff --git a/src/DEPENDENCIES b/src/DEPENDENCIES index 68195cc50..83a718fef 100644 --- a/src/DEPENDENCIES +++ b/src/DEPENDENCIES @@ -100,6 +100,7 @@ interpolation.o: endf_header.o interpolation.o: error.o interpolation.o: global.o interpolation.o: search.o +interpolation.o: string.o logging.o: constants.o logging.o: global.o diff --git a/src/interpolation.f90 b/src/interpolation.f90 index f32e1367d..9027adb00 100644 --- a/src/interpolation.f90 +++ b/src/interpolation.f90 @@ -5,6 +5,7 @@ module interpolation use error, only: fatal_error use global, only: message use search, only: binary_search + use string, only: int_to_str implicit none @@ -29,6 +30,7 @@ contains real(8) :: y ! y(x) integer :: i ! bin in which to interpolate + integer :: j ! index for interpolation region integer :: loc_0 ! starting location integer :: n_regions ! number of interpolation regions integer :: n_points ! number of tabulated values @@ -81,8 +83,12 @@ contains elseif (n_regions == 1) then interp = data(loc_interp + 1) elseif (n_regions > 1) then - message = "Multiple interpolation regions not yet supported." - call fatal_error() + do j = 1, n_regions + if (i < data(loc_breakpoints + j)) then + interp = data(loc_interp + j) + exit + end if + end do end if ! handle special case of histogram interpolation @@ -111,6 +117,9 @@ contains case (LOG_LOG) r = (log(x) - log(x0))/(log(x1) - log(x0)) y = exp((1-r)*log(y0) + r*log(y1)) + case default + message = "Unsupported interpolation scheme: " // int_to_str(interp) + call fatal_error() end select end function interpolate_tab1_array @@ -129,6 +138,7 @@ contains real(8) :: y ! y(x) integer :: i ! bin in which to interpolate + integer :: j ! index for interpolation region integer :: n_regions ! number of interpolation regions integer :: n_pairs ! number of tabulated values integer :: interp ! ENDF interpolation scheme @@ -159,8 +169,12 @@ contains elseif (n_regions == 1) then interp = obj % int(1) elseif (n_regions > 1) then - message = "Multiple interpolation regions not yet supported." - call fatal_error() + do j = 1, n_regions + if (i < obj % nbt(j)) then + interp = obj % int(j) + exit + end if + end do end if ! handle special case of histogram interpolation @@ -189,6 +203,9 @@ contains case (LOG_LOG) r = (log(x) - log(x0))/(log(x1) - log(x0)) y = exp((1-r)*log(y0) + r*log(y1)) + case default + message = "Unsupported interpolation scheme: " // int_to_str(interp) + call fatal_error() end select end function interpolate_tab1_object From a74a41e443b702ec6d1508323d39d7eb39ad4730 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sat, 12 Nov 2011 11:05:35 -0800 Subject: [PATCH 02/70] Used interpolate_tab1 for delayed neutron precursor yields. --- src/physics.f90 | 32 +++++--------------------------- 1 file changed, 5 insertions(+), 27 deletions(-) diff --git a/src/physics.f90 b/src/physics.f90 index 3998c8e8c..0cf2f4159 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -1006,7 +1006,6 @@ contains integer :: i ! loop index integer :: j ! index on nu energy grid / precursor group - integer :: k ! index on precursor yield grid integer :: loc ! index before start of energies/nu values integer :: NR ! number of interpolation regions integer :: NE ! number of energies tabulated @@ -1014,7 +1013,6 @@ contains integer :: law ! energy distribution law real(8) :: E ! incoming energy of neutron real(8) :: E_out ! outgoing energy of fission neutron - real(8) :: f ! interpolation factor real(8) :: nu_t ! total nu real(8) :: nu_p ! prompt nu real(8) :: nu_d ! delayed nu @@ -1096,37 +1094,17 @@ contains ! determine number of interpolation regions and energies NR = nuc % nu_d_precursor_data(loc + 1) NE = nuc % nu_d_precursor_data(loc + 2 + 2*NR) - if (NR > 0) then - message = "Multiple interpolation regions not supported while & - &sampling delayed neutron precursor yield." - call fatal_error() - end if - - ! interpolate on energy grid - loc = loc + 2 + 2*NR - if (E < nuc%nu_d_precursor_data(loc+1)) then - k = 1 - f = ZERO - elseif (E > nuc%nu_d_precursor_data(loc+NE)) then - k = NE - 1 - f = ONE - else - k = binary_search(nuc%nu_d_precursor_data(loc+1), NE, E) - f = (E - nuc%nu_d_precursor_data(loc+k)) / & - & (nuc%nu_d_precursor_data(loc+k+1) - & - & nuc%nu_d_precursor_data(loc+k)) - end if ! determine delayed neutron precursor yield for group j - loc = loc + NE - yield = nuc%nu_d_precursor_data(loc+k) + f * & - (nuc%nu_d_precursor_data(loc+k+1) - & - & nuc%nu_d_precursor_data(loc+k)) + yield = interpolate_tab1(nuc % nu_d_precursor_data( & + loc+1:loc+2+2*NR+2*NE), E) + + ! Check if this group is sampled prob = prob + yield if (xi < prob) exit ! advance pointer - loc = loc + NE + 1 + loc = loc + 2 + 2*NR + 2*NE + 1 end do ! sample from energy distribution for group j From 445aa3b9dc7edf1738241b76004f540441375cfe Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Wed, 16 Nov 2011 17:26:49 -0800 Subject: [PATCH 03/70] Changed uids to ids in documentation. --- docs/source/usersguide/input.rst | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/docs/source/usersguide/input.rst b/docs/source/usersguide/input.rst index 4f32815c9..95b08b6fa 100644 --- a/docs/source/usersguide/input.rst +++ b/docs/source/usersguide/input.rst @@ -64,14 +64,14 @@ number of cells, surfaces, and lattices. Let us look at the following example:: - 1 + 1 sphere 0.0 0.0 0.0 5.0 vacuum - 1 + 1 0 1 -1 @@ -89,14 +89,14 @@ could be written as:: - - + + Each ``surface`` element can have the following attributes or sub-elements: - :uid: + :id: A unique integer that can be used to identify the surface. *Default*: None @@ -120,32 +120,32 @@ Each ``surface`` element can have the following attributes or sub-elements: Each ``cell`` element can have the following attributes or sub-elements: - :uid: + :id: A unique integer that can be used to identify the surface. *Default*: None :universe: - The ``uid`` of the universe that this cell is contained in. + The ``id`` of the universe that this cell is contained in. *Default*: 0 :fill: - The ``uid`` of the universe that fills this cell. + The ``id`` of the universe that fills this cell. .. note:: If a fill is specified, no material should be given. *Default*: None :material: - The ``uid`` of the material that this cell contains. + The ``id`` of the material that this cell contains. .. note:: If a material is specified, no fill should be given. *Default*: None :surfaces: - A list of the ``uids`` for surfaces that bound this cell, e.g. if the cell + A list of the ``ids`` for surfaces that bound this cell, e.g. if the cell is on the negative side of surface 3 and the positive side of surface 5, the bounding surfaces would be given as "-3 5". From 01c21a535e81dc000ede9078e110977d1a2395b6 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Wed, 16 Nov 2011 17:38:25 -0800 Subject: [PATCH 04/70] Updated description for settings.xml in documentation. --- docs/source/usersguide/input.rst | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/docs/source/usersguide/input.rst b/docs/source/usersguide/input.rst index 95b08b6fa..b0f2d820d 100644 --- a/docs/source/usersguide/input.rst +++ b/docs/source/usersguide/input.rst @@ -232,18 +232,18 @@ Settings Specification -- settings.xml All simulation parameters and miscellaneous options are specified in the settings.xml file. The following elements can be specified: -- ``xslibrary`` +- ``cross_sections`` - ``criticality`` - ``verbosity`` - ``source`` +- ``survival_biasing`` +- ``cutoff`` -The ``xslibrary`` element has the following attributes: - - :path: - The absolute or relative path of the xsdata file which lists cross sections - to be used in the simulation. - - *Default*: None +The ``cross_sections`` element has no attributes and simply indicates the path +to an XML cross section listing file (usually named ``cross_sections.xml``. If +this element is absent from the ``settings.xml`` file, the environment variable +``CROSS_SECTIONS`` will be used to find the path to the XML cross section +listing. The ``criticality`` element indicates that a criticality calculation should be performed. It has the following attributes/sub-elements: @@ -288,6 +288,17 @@ criticality calculations. It takes the following attributes: and the last three of which specify the upper-right corner. Source sites are sampled uniformly through that parallelepiped. +The ``survival_biasing`` element as no attributes and assumes wither the +value ``on`` or ``off``. If turned on, this option will enable the use of +survival biasing, otherwise known as implicit capture or absorption. + + *Default*: off + +The ``cutoff`` element has no attributes and indicates the weight cutoff used +below which particles undergo Russian roulette. + + *Default*: 0.25 + ------------------------------------ Tallies Specification -- tallies.xml ------------------------------------ From 8551213d22cd0de0cb0d94de12d9a266317aa7ef Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sun, 20 Nov 2011 17:06:47 -0500 Subject: [PATCH 05/70] Ability to use incoming energy filter on surface current tallies. --- src/constants.f90 | 6 + src/input_xml.f90 | 10 +- src/tally.f90 | 353 +++++++++++++++++++++++++++++----------------- 3 files changed, 233 insertions(+), 136 deletions(-) diff --git a/src/constants.f90 b/src/constants.f90 index 7fec731d6..c44f979b3 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -208,6 +208,12 @@ module constants T_MESH = 6, & T_ENERGYIN = 7, & T_ENERGYOUT = 8 + integer, parameter :: & + TS_MESH_X = 1, & + TS_MESH_Y = 2, & + TS_MESH_Z = 3, & + TS_ENERGYIN = 4, & + TS_SURFACE = 5 ! Tally surface current directions integer, parameter :: & diff --git a/src/input_xml.f90 b/src/input_xml.f90 index ef59d895a..5403e59b2 100644 --- a/src/input_xml.f90 +++ b/src/input_xml.f90 @@ -863,11 +863,11 @@ contains end if ! Check to make sure that only the mesh filter was specified - if (t % mesh == 0 .or. t % n_bins(T_MESH) /= & - product(t % n_bins, t % n_bins > 0)) then - message = "Surface currents must be used with a mesh filter only." - call fatal_error() - end if +!!$ if (t % mesh == 0 .or. t % n_bins(T_MESH) /= & +!!$ product(t % n_bins, t % n_bins > 0)) then +!!$ message = "Surface currents must be used with a mesh filter only." +!!$ call fatal_error() +!!$ end if ! Since the number of bins for the mesh filter was already set ! assuming it was a flux tally, we need to adjust the number of diff --git a/src/tally.f90 b/src/tally.f90 index b89299bb8..464a35739 100644 --- a/src/tally.f90 +++ b/src/tally.f90 @@ -95,12 +95,12 @@ contains subroutine create_tally_map() - integer :: i ! loop index for tallies - integer :: j ! loop index for filter arrays - integer :: index ! filter bin entries - integer :: n ! number of bins - integer :: filter_bins ! running total of number of filter bins - integer :: score_bins ! number of scoring bins + integer :: i ! loop index for tallies + integer :: j ! loop index for filter arrays + integer :: index ! filter bin entries + integer :: n ! number of bins + integer :: filter_bins ! running total of number of filter bins + integer :: score_bins ! number of scoring bins type(TallyObject), pointer :: t => null() type(StructuredMesh), pointer :: m => null() @@ -129,23 +129,31 @@ contains if (t % surface_current) then m => meshes(t % mesh) + t % stride(TS_SURFACE) = filter_bins ! Set stride for surface/direction if (m % n_dimension == 2) then filter_bins = filter_bins * 4 elseif (m % n_dimension == 3) then filter_bins = filter_bins * 6 end if + + ! Add filter for incoming energy + n = t % n_bins(T_ENERGYIN) + t % stride(TS_ENERGYIN) = filter_bins + if (n > 0) then + filter_bins = filter_bins * n + end if ! account for z direction - t % stride(3) = filter_bins + t % stride(TS_MESH_Z) = filter_bins filter_bins = filter_bins * (m % dimension(3) + 1) ! account for y direction - t % stride(2) = filter_bins + t % stride(TS_MESH_Y) = filter_bins filter_bins = filter_bins * (m % dimension(2) + 1) ! account for z direction - t % stride(1) = filter_bins + t % stride(TS_MESH_X) = filter_bins filter_bins = filter_bins * (m % dimension(1) + 1) ! Finally add scoring bins for the macro tallies and allocate scores @@ -578,27 +586,31 @@ contains type(Particle), pointer :: p - integer :: i ! loop indices - integer :: j ! loop indices - integer :: k ! loop indices - integer :: ijk0(3) ! indices of starting coordinates - integer :: ijk1(3) ! indices of ending coordinates - integer :: n_cross ! number of surface crossings - integer :: score_index ! index of scoring bin - 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 bounding surfaces - real(8) :: d(3) ! distance to each bounding surface - real(8) :: distance ! actual distance traveled - 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) - logical :: y_same ! same starting/ending y index (j) - logical :: z_same ! same starting/ending z index (k) + integer :: i ! loop indices + integer :: j ! loop indices + integer :: k ! loop indices + 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 :: bins(TALLY_TYPES) ! scoring bin combination + integer :: score_index ! index of scoring bin + 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 bounding surfaces + real(8) :: d(3) ! distance to each bounding surface + real(8) :: distance ! actual distance traveled + 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) + logical :: y_same ! same starting/ending y index (j) + logical :: z_same ! same starting/ending z index (k) type(TallyObject), pointer :: t => null() type(StructuredMesh), pointer :: m => null() + bins = 1 + do i = 1, n_tallies ! Copy starting and ending location of particle xyz0 = p % last_xyz @@ -625,6 +637,19 @@ contains ! Copy particle's direction uvw = p % uvw + ! determine incoming energy bin + n = t % n_bins(T_ENERGYIN) + if (n > 0) then + ! check if energy of the particle is within energy bins + if (p % last_E < t % energy_in(1) .or. & + p % last_E > t % energy_in(n + 1)) cycle + + ! search to find incoming energy bin + bins(TS_ENERGYIN) = binary_search(t % energy_in, n + 1, p % last_E) + else + bins(TS_ENERGYIN) = 1 + end if + ! ======================================================================= ! SPECIAL CASES WHERE TWO INDICES ARE THE SAME @@ -638,7 +663,9 @@ contains do j = ijk0(3), ijk1(3) - 1 ijk0(3) = j if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + OUT_TOP + bins(TS_SURFACE) = OUT_TOP + bins(1:3) = ijk0 + 1 + score_index = sum((bins - 1) * t % stride) + 1 call add_to_score(t % scores(score_index, 1), p % last_wgt) end if end do @@ -646,7 +673,9 @@ contains do j = ijk0(3) - 1, ijk1(3), -1 ijk0(3) = j if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + IN_TOP + bins(TS_SURFACE) = IN_TOP + bins(1:3) = ijk0 + 1 + score_index = sum((bins - 1) * t % stride) + 1 call add_to_score(t % scores(score_index, 1), p % last_wgt) end if end do @@ -658,7 +687,9 @@ contains do j = ijk0(2), ijk1(2) - 1 ijk0(2) = j if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + OUT_FRONT + bins(TS_SURFACE) = OUT_FRONT + bins(1:3) = ijk0 + 1 + score_index = sum((bins - 1) * t % stride) + 1 call add_to_score(t % scores(score_index, 1), p % last_wgt) end if end do @@ -666,7 +697,9 @@ contains do j = ijk0(2) - 1, ijk1(2), -1 ijk0(2) = j if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + IN_FRONT + bins(TS_SURFACE) = IN_FRONT + bins(1:3) = ijk0 + 1 + score_index = sum((bins - 1) * t % stride) + 1 call add_to_score(t % scores(score_index, 1), p % last_wgt) end if end do @@ -678,7 +711,9 @@ contains do j = ijk0(1), ijk1(1) - 1 ijk0(1) = j if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + OUT_RIGHT + bins(TS_SURFACE) = OUT_RIGHT + bins(1:3) = ijk0 + 1 + score_index = sum((bins - 1) * t % stride) + 1 call add_to_score(t % scores(score_index, 1), p % last_wgt) end if end do @@ -686,7 +721,9 @@ contains do j = ijk0(1) - 1, ijk1(1), -1 ijk0(1) = j if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + IN_RIGHT + bins(TS_SURFACE) = IN_RIGHT + bins(1:3) = ijk0 + 1 + score_index = sum((bins - 1) * t % stride) + 1 call add_to_score(t % scores(score_index, 1), p % last_wgt) end if end do @@ -708,7 +745,7 @@ contains do k = 1, n_cross ! Reset scoring bin index - score_index = 0 + bins(TS_SURFACE) = 0 ! Calculate distance to each bounding surface. We need to treat ! special case where the cosine of the angle is zero since this would @@ -735,7 +772,8 @@ contains ! Crossing into right mesh cell -- this is treated as outgoing ! current from (i,j,k) if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + OUT_RIGHT + bins(TS_SURFACE) = OUT_RIGHT + bins(1:3) = ijk0 + 1 end if ijk0(1) = ijk0(1) + 1 xyz_cross(1) = xyz_cross(1) + m % width(1) @@ -745,7 +783,8 @@ contains ijk0(1) = ijk0(1) - 1 xyz_cross(1) = xyz_cross(1) - m % width(1) if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + IN_RIGHT + bins(TS_SURFACE) = IN_RIGHT + bins(1:3) = ijk0 + 1 end if end if elseif (distance == d(2)) then @@ -753,7 +792,8 @@ contains ! Crossing into front mesh cell -- this is treated as outgoing ! current in (i,j,k) if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + OUT_FRONT + bins(TS_SURFACE) = OUT_FRONT + bins(1:3) = ijk0 + 1 end if ijk0(2) = ijk0(2) + 1 xyz_cross(2) = xyz_cross(2) + m % width(2) @@ -763,7 +803,8 @@ contains ijk0(2) = ijk0(2) - 1 xyz_cross(2) = xyz_cross(2) - m % width(2) if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + IN_FRONT + bins(TS_SURFACE) = IN_FRONT + bins(1:3) = ijk0 + 1 end if end if else if (distance == d(3)) then @@ -771,7 +812,8 @@ contains ! Crossing into top mesh cell -- this is treated as outgoing ! current in (i,j,k) if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + OUT_TOP + bins(TS_SURFACE) = OUT_TOP + bins(1:3) = ijk0 + 1 end if ijk0(3) = ijk0(3) + 1 xyz_cross(3) = xyz_cross(3) + m % width(3) @@ -781,19 +823,23 @@ contains ijk0(3) = ijk0(3) - 1 xyz_cross(3) = xyz_cross(3) - m % width(3) if (all(ijk0 >= 0) .and. all(ijk0 <= m % dimension)) then - score_index = sum(t % stride(1:3) * ijk0) + IN_TOP + bins(TS_SURFACE) = IN_TOP + bins(1:3) = ijk0 + 1 end if end if end if - ! Check for errors - if (score_index < 0 .or. score_index > t % n_total_bins) then - message = "Score index outside range." - call fatal_error() - end if + ! Determine scoring index + if (bins(TS_SURFACE) > 0) then + score_index = sum((bins - 1) * t % stride) + 1 - ! Add to surface current tally - if (score_index > 0) then + ! Check for errors + if (score_index <= 0 .or. score_index > t % n_total_bins) then + message = "Score index outside range." + call fatal_error() + end if + + ! Add to surface current tally call add_to_score(t % scores(score_index, 1), p % last_wgt) end if @@ -1093,19 +1139,34 @@ contains type(TallyObject), pointer :: t - integer :: i ! mesh index for x - integer :: j ! mesh index for y - integer :: k ! mesh index for z - integer :: ijk(3) ! indices in mesh - integer :: len1 ! length of string - integer :: len2 ! length of string - integer :: score_index ! index in scores array for filters + integer :: i ! mesh index for x + integer :: j ! mesh index for y + integer :: k ! mesh index for z + integer :: l ! mesh index for energy + integer :: bins(TALLY_TYPES) ! bin combination + integer :: n ! number of incoming energy bins + integer :: len1 ! length of string + integer :: len2 ! length of string + integer :: score_index ! index in scores array for filters + logical :: print_ebin ! should incoming energy bin be displayed? character(MAX_LINE_LEN) :: string type(StructuredMesh), pointer :: m => null() ! Get pointer to mesh m => meshes(t % mesh) + ! initialize bins array + bins = 1 + + ! determine how many energy in bins there are + n = t % n_bins(T_ENERGYIN) + if (n > 0) then + print_ebin = .true. + else + print_ebin = .false. + n = 1 + end if + do i = 1, m % dimension(1) string = "Mesh Index (" // trim(int_to_str(i)) // ", " len1 = len_trim(string) @@ -1117,83 +1178,113 @@ contains string = string(1:len2+1) // trim(int_to_str(k)) // ")" write(UNIT=UNIT_TALLY, FMT='(1X,A)') trim(string) - ! Left Surface - ijk = (/ i-1, j, k /) - score_index = sum(t % stride(1:3) * ijk) + IN_RIGHT - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Outgoing Current to Left", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) - score_index = sum(t % stride(1:3) * ijk) + OUT_RIGHT - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Incoming Current from Left", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) - - ! Right Surface - ijk = (/ i, j, k /) - score_index = sum(t % stride(1:3) * ijk) + IN_RIGHT - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Incoming Current from Right", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) - score_index = sum(t % stride(1:3) * ijk) + OUT_RIGHT - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Outgoing Current to Right", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) - - ! Back Surface - ijk = (/ i, j-1, k /) - score_index = sum(t % stride(1:3) * ijk) + IN_FRONT - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Outgoing Current to Back", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) - score_index = sum(t % stride(1:3) * ijk) + OUT_FRONT - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Incoming Current from Back", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) - - ! Front Surface - ijk = (/ i, j, k /) - score_index = sum(t % stride(1:3) * ijk) + IN_FRONT - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Incoming Current from Front", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) - score_index = sum(t % stride(1:3) * ijk) + OUT_FRONT - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Outgoing Current to Front", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) - - ! Bottom Surface - ijk = (/ i, j, k-1 /) - score_index = sum(t % stride(1:3) * ijk) + IN_TOP - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Outgoing Current to Bottom", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) - score_index = sum(t % stride(1:3) * ijk) + OUT_TOP - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Incoming Current from Bottom", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) - - ! Top Surface - ijk = (/ i, j, k /) - score_index = sum(t % stride(1:3) * ijk) + IN_TOP - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Incoming Current from Top", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) - score_index = sum(t % stride(1:3) * ijk) + OUT_TOP - write(UNIT=UNIT_TALLY, FMT='(3X,A,T35,A,"+/- ",A)') & - "Outgoing Current to Top", & - real_to_str(t % scores(score_index,1) % val), & - trim(real_to_str(t % scores(score_index,1) % val_sq)) + do l = 1, n + ! Write incoming energy bin + if (print_ebin) then + write(UNIT=UNIT_TALLY, FMT='(3X,A,1X,A)') & + "Incoming Energy", trim(get_label(t, T_ENERGYIN, l)) + end if + + ! Set incoming energy bin + bins(TS_ENERGYIN) = l + + ! Left Surface + bins(1:3) = (/ i-1, j, k /) + 1 + bins(TS_SURFACE) = IN_RIGHT + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Outgoing Current to Left", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + + bins(TS_SURFACE) = OUT_RIGHT + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Incoming Current from Left", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + + ! Right Surface + bins(1:3) = (/ i, j, k /) + 1 + bins(TS_SURFACE) = IN_RIGHT + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Incoming Current from Right", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + + bins(TS_SURFACE) = OUT_RIGHT + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Outgoing Current to Right", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + + ! Back Surface + bins(1:3) = (/ i, j-1, k /) + 1 + bins(TS_SURFACE) = IN_FRONT + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Outgoing Current to Back", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + + bins(TS_SURFACE) = OUT_FRONT + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Incoming Current from Back", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + + ! Front Surface + bins(1:3) = (/ i, j, k /) + 1 + bins(TS_SURFACE) = IN_FRONT + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Incoming Current from Front", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + + bins(TS_SURFACE) = OUT_FRONT + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Outgoing Current to Front", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + + ! Bottom Surface + bins(1:3) = (/ i, j, k-1 /) + 1 + bins(TS_SURFACE) = IN_TOP + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Outgoing Current to Bottom", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + + bins(TS_SURFACE) = OUT_TOP + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Incoming Current from Bottom", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + + ! Top Surface + bins(1:3) = (/ i, j, k /) + 1 + bins(TS_SURFACE) = IN_TOP + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Incoming Current from Top", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + + bins(TS_SURFACE) = OUT_TOP + score_index = sum((bins - 1) * t % stride) + 1 + write(UNIT=UNIT_TALLY, FMT='(5X,A,T35,A,"+/- ",A)') & + "Outgoing Current to Top", & + real_to_str(t % scores(score_index,1) % val), & + trim(real_to_str(t % scores(score_index,1) % val_sq)) + end do + end do end do end do From 0fc74917304c8ebf90bf544f1ecbb6fb1f168e43 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sun, 20 Nov 2011 17:33:15 -0500 Subject: [PATCH 06/70] Changed behavior of Intel compiler to assume bytes for record length. gfortran and ifort thus have same behavior for reading binary files. --- src/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Makefile b/src/Makefile index e685c03df..14b0d9909 100644 --- a/src/Makefile +++ b/src/Makefile @@ -31,7 +31,7 @@ USE_COARRAY = no ifeq ($(COMPILER),intel) F90 = ifort - F90FLAGS := -fpp -warn + F90FLAGS := -fpp -warn -assume byterecl LDFLAGS = endif From ca1d53fbc839ee9b6e0e2c0c4f7f351b253117de Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sun, 20 Nov 2011 19:05:54 -0500 Subject: [PATCH 07/70] Rewrote random number generator. --- src/DEPENDENCIES | 10 +- src/OBJECTS | 2 +- src/initialize.f90 | 8 +- src/main.f90 | 7 +- src/mcnp_random.f90 | 627 ------------------------------------------- src/mpi_routines.f90 | 8 +- src/physics.f90 | 128 ++++----- src/random_lcg.f90 | 147 ++++++++++ src/source.f90 | 10 +- 9 files changed, 232 insertions(+), 715 deletions(-) delete mode 100644 src/mcnp_random.f90 create mode 100644 src/random_lcg.f90 diff --git a/src/DEPENDENCIES b/src/DEPENDENCIES index 83a718fef..9e526688a 100644 --- a/src/DEPENDENCIES +++ b/src/DEPENDENCIES @@ -72,9 +72,9 @@ initialize.o: geometry_header.o initialize.o: global.o initialize.o: input_xml.o initialize.o: logging.o -initialize.o: mcnp_random.o initialize.o: mpi_routines.o initialize.o: output.o +initialize.o: random_lcg.o initialize.o: source.o initialize.o: string.o initialize.o: tally.o @@ -108,12 +108,12 @@ logging.o: global.o main.o: constants.o main.o: global.o main.o: initialize.o -main.o: mcnp_random.o main.o: mpi_routines.o main.o: output.o main.o: particle_header.o main.o: physics.o main.o: plot.o +main.o: random_lcg.o main.o: source.o main.o: string.o main.o: tally.o @@ -124,9 +124,9 @@ mesh.o: mesh_header.o mpi_routines.o: constants.o mpi_routines.o: error.o mpi_routines.o: global.o -mpi_routines.o: mcnp_random.o mpi_routines.o: output.o mpi_routines.o: particle_header.o +mpi_routines.o: random_lcg.o mpi_routines.o: tally_header.o output.o: constants.o @@ -149,9 +149,9 @@ physics.o: geometry.o physics.o: geometry_header.o physics.o: global.o physics.o: interpolation.o -physics.o: mcnp_random.o physics.o: output.o physics.o: particle_header.o +physics.o: random_lcg.o physics.o: search.o physics.o: string.o physics.o: tally.o @@ -171,8 +171,8 @@ source.o: bank_header.o source.o: constants.o source.o: cross_section_header.o source.o: global.o -source.o: mcnp_random.o source.o: output.o +source.o: random_lcg.o source.o: particle_header.o source.o: physics.o diff --git a/src/OBJECTS b/src/OBJECTS index a80d12418..6ce0dcafc 100644 --- a/src/OBJECTS +++ b/src/OBJECTS @@ -20,7 +20,6 @@ input_xml.o \ logging.o \ main.o \ material_header.o \ -mcnp_random.o \ mesh_header.o \ mesh.o \ mpi_routines.o \ @@ -28,6 +27,7 @@ output.o \ particle_header.o \ physics.o \ plot.o \ +random_lcg.o \ search.o \ source.o \ source_header.o \ diff --git a/src/initialize.f90 b/src/initialize.f90 index 15fa8bdc8..8c84c2d7b 100644 --- a/src/initialize.f90 +++ b/src/initialize.f90 @@ -13,10 +13,10 @@ module initialize use input_xml, only: read_input_xml, read_cross_sections_xml, & cells_in_univ_dict use logging, only: create_log - use mcnp_random, only: RN_init_problem use mpi_routines, only: setup_mpi use output, only: title, echo_input, message, print_summary, & print_particle, header, print_plot + use random_lcg, only: initialize_prng use source, only: initialize_source use string, only: int_to_str, starts_with, ends_with, lower_case use tally, only: create_tally_map, TallyObject @@ -51,10 +51,8 @@ contains ! Print initialization header block if (master) call header("INITIALIZATION", 1) - ! Initialize random number generator. The first argument corresponds to - ! which random number generator to use- in this case one of the L'Ecuyer - ! 63-bit RNGs. - call RN_init_problem(3, 0_8, 0_8, 0_8, 0) + ! Initialize random number generator + call initialize_prng() ! set up dictionaries call create_dictionaries() diff --git a/src/main.f90 b/src/main.f90 index 2dfdcce77..de1c473fc 100644 --- a/src/main.f90 +++ b/src/main.f90 @@ -3,17 +3,16 @@ program main use constants use global use initialize, only: initialize_run - use mcnp_random, only: RN_init_particle use mpi_routines, only: synchronize_bank use output, only: write_message, header, print_runtime use particle_header, only: Particle use plot, only: run_plot use physics, only: transport - use tally, only: calculate_keff + use random_lcg, only: set_particle_seed use source, only: get_source_particle use string, only: int_to_str use tally, only: synchronize_tallies, write_tallies, & - tally_statistics + tally_statistics, calculate_keff use timing, only: timer_start, timer_stop #ifdef MPI @@ -87,7 +86,7 @@ contains ! set random number seed i_particle = (i_cycle-1)*n_particles + p % id - call RN_init_particle(i_particle) + call set_particle_seed(i_particle) ! transport particle call transport(p) diff --git a/src/mcnp_random.f90 b/src/mcnp_random.f90 deleted file mode 100644 index 1f7e2550e..000000000 --- a/src/mcnp_random.f90 +++ /dev/null @@ -1,627 +0,0 @@ - -module mcnp_random - !======================================================================= - ! Description: - ! mcnp_random.F90 -- random number generation routines - !======================================================================= - ! This module contains: - ! - ! * Constants for the RN generator, including initial RN seed for the - ! problem & the current RN seed - ! - ! * MCNP interface routines: - ! - random number function: rang() - ! - RN initialization for problem: RN_init_problem - ! - RN initialization for particle: RN_init_particle - ! - get info on RN parameters: RN_query - ! - get RN seed for n-th history: RN_query_first - ! - set new RN parameters: RN_set - ! - skip-ahead in the RN sequence: RN_skip_ahead - ! - Unit tests: RN_test_basic, RN_test_skip, RN_test_mixed - ! - ! * For interfacing with the rest of MCNP, arguments to/from these - ! routines will have types of I8 or I4. - ! Any args which are to hold random seeds, multipliers, - ! skip-distance will be type I8, so that 63 bits can be held without - ! truncation. - ! - ! Revisions: - ! * 10-04-2001 - F Brown, initial mcnp version - ! * 06-06-2002 - F Brown, mods for extended generators - ! * 12-21-2004 - F Brown, added 3 of LeCuyer's 63-bit mult. RNGs - ! * 01-29-2005 - J Sweezy, Modify to use mcnp modules prior to automatic - ! io unit numbers. - ! * 12-02-2005 - F Brown, mods for consistency with C version - !======================================================================= - - !------------------- - ! MCNP output units - !------------------- - integer, parameter :: iuo = 6 - integer, parameter :: jtty = 6 - - PRIVATE - !--------------------------------------------------- - ! Kinds for LONG INTEGERS (64-bit) & REAL*8 (64-bit) - !--------------------------------------------------- - integer, parameter :: R8 = selected_real_kind(15,307) - integer, parameter :: I8 = selected_int_kind(18) - - !----------------------------------- - ! Public functions and subroutines for this module - !----------------------------------- - PUBLIC :: rang - PUBLIC :: RN_init_problem - PUBLIC :: RN_init_particle - PUBLIC :: RN_set - PUBLIC :: RN_query - PUBLIC :: RN_query_first - PUBLIC :: RN_update_stats - PUBLIC :: RN_test_basic - PUBLIC :: RN_test_skip - PUBLIC :: RN_test_mixed - PUBLIC :: RN_skip - - !------------------------------------- - ! Constants for standard RN generators - !------------------------------------- - type :: RN_GEN - integer :: index - integer(I8) :: mult ! generator (multiplier) - integer(I8) :: add ! additive constant - integer :: log2mod ! log2 of modulus, must be <64 - integer(I8) :: stride ! stride for particle skip-ahead - integer(I8) :: initseed ! default seed for problem - character(len=8) :: name - end type RN_GEN - - ! parameters for standard generators - integer, parameter :: n_RN_GEN = 7 - type(RN_GEN), SAVE :: standard_generator(n_RN_GEN) - data standard_generator / & - & RN_GEN( 1, 19073486328125_I8, 0_I8, 48, 152917_I8, 19073486328125_I8 , 'mcnp std' ), & - & RN_GEN( 2, 9219741426499971445_I8, 1_I8, 63, 152917_I8, 1_I8, 'LEcuyer1' ), & - & RN_GEN( 3, 2806196910506780709_I8, 1_I8, 63, 152917_I8, 1_I8, 'LEcuyer2' ), & - & RN_GEN( 4, 3249286849523012805_I8, 1_I8, 63, 152917_I8, 1_I8, 'LEcuyer3' ), & - & RN_GEN( 5, 3512401965023503517_I8, 0_I8, 63, 152917_I8, 1_I8, 'LEcuyer4' ), & - & RN_GEN( 6, 2444805353187672469_I8, 0_I8, 63, 152917_I8, 1_I8, 'LEcuyer5' ), & - & RN_GEN( 7, 1987591058829310733_I8, 0_I8, 63, 152917_I8, 1_I8, 'LEcuyer6' ) & - & / - - !----------------------------------------------------------------- - ! * Linear multiplicative congruential RN algorithm: - ! - ! RN_SEED = RN_SEED*RN_MULT + RN_ADD mod RN_MOD - ! - ! * Default values listed below will be used, unless overridden - !----------------------------------------------------------------- - integer, SAVE :: RN_INDEX = 1 - integer(I8), SAVE :: RN_MULT = 19073486328125_I8 - integer(I8), SAVE :: RN_ADD = 0_I8 - integer, SAVE :: RN_BITS = 48 - integer(I8), SAVE :: RN_STRIDE = 152917_I8 - integer(I8), SAVE :: RN_SEED0 = 19073486328125_I8 - integer(I8), SAVE :: RN_MOD = 281474976710656_I8 - integer(I8), SAVE :: RN_MASK = 281474976710655_I8 - integer(I8), SAVE :: RN_PERIOD = 70368744177664_I8 - real(R8), SAVE :: RN_NORM = 1._R8 / 281474976710656._R8 - - !------------------------------------ - ! Private data for a single particle - !------------------------------------ - integer(I8), save :: RN_SEED = 19073486328125_I8 ! current seed - integer(I8), save :: RN_COUNT = 0_I8 ! current counter - integer(I8), save :: RN_NPS = 0_I8 ! current particle number - - !$OMP THREADPRIVATE (RN_SEED, RN_COUNT, RN_NPS) - - !------------------------------------------ - ! Shared data, to collect info on RN usage - !------------------------------------------ - integer(I8), SAVE :: RN_COUNT_TOTAL = 0 ! total RN count all particles - integer(I8), SAVE :: RN_COUNT_STRIDE = 0 ! count for stride exceeded - integer(I8), SAVE :: RN_COUNT_MAX = 0 ! max RN count all particles - integer(I8), SAVE :: RN_COUNT_MAX_NPS = 0 ! part index for max count - - !--------------------------------------------------------------------- - ! Reference data: Seeds for case of init.seed = 1, - ! Seed numbers for index 1-5, 123456-123460 - !--------------------------------------------------------------------- - integer(I8), dimension(10,n_RN_GEN) :: RN_CHECK - data RN_CHECK / & - ! ***** 1 ***** mcnp standard gen ***** - & 19073486328125_I8, 29763723208841_I8, 187205367447973_I8, & - & 131230026111313_I8, 264374031214925_I8, 260251000190209_I8, & - & 106001385730621_I8, 232883458246025_I8, 97934850615973_I8, & - & 163056893025873_I8, & - ! ***** 2 ***** - & 9219741426499971446_I8, 666764808255707375_I8, 4935109208453540924_I8, & - & 7076815037777023853_I8, 5594070487082964434_I8, 7069484152921594561_I8, & - & 8424485724631982902_I8, 19322398608391599_I8, 8639759691969673212_I8, & - & 8181315819375227437_I8, & - ! ***** 3 ***** - & 2806196910506780710_I8, 6924308458965941631_I8, 7093833571386932060_I8, & - & 4133560638274335821_I8, 678653069250352930_I8, 6431942287813238977_I8, & - & 4489310252323546086_I8, 2001863356968247359_I8, 966581798125502748_I8, & - & 1984113134431471885_I8, & - ! ***** 4 ***** - & 3249286849523012806_I8, 4366192626284999775_I8, 4334967208229239068_I8, & - & 6386614828577350285_I8, 6651454004113087106_I8, 2732760390316414145_I8, & - & 2067727651689204870_I8, 2707840203503213343_I8, 6009142246302485212_I8, & - & 6678916955629521741_I8, & - ! ***** 5 ***** - & 3512401965023503517_I8, 5461769869401032777_I8, 1468184805722937541_I8, & - & 5160872062372652241_I8, 6637647758174943277_I8, 794206257475890433_I8, & - & 4662153896835267997_I8, 6075201270501039433_I8, 889694366662031813_I8, & - & 7299299962545529297_I8, & - ! ***** 6 ***** - & 2444805353187672469_I8, 316616515307798713_I8, 4805819485453690029_I8, & - & 7073529708596135345_I8, 3727902566206144773_I8, 1142015043749161729_I8, & - & 8632479219692570773_I8, 2795453530630165433_I8, 5678973088636679085_I8, & - & 3491041423396061361_I8, & - ! ***** 7 ***** - & 1987591058829310733_I8, 5032889449041854121_I8, 4423612208294109589_I8, & - & 3020985922691845009_I8, 5159892747138367837_I8, 8387642107983542529_I8, & - & 8488178996095934477_I8, 708540881389133737_I8, 3643160883363532437_I8, & - & 4752976516470772881_I8 / - !--------------------------------------------------------------------- - -CONTAINS - - !------------------------------------------------------------------- - - function rang() - ! MCNP random number generator - ! - ! *************************************** - ! ***** modifies RN_SEED & RN_COUNT ***** - ! *************************************** - implicit none - real(R8) :: rang - - RN_SEED = iand( iand( RN_MULT*RN_SEED, RN_MASK) + RN_ADD, RN_MASK) - rang = RN_SEED * RN_NORM - RN_COUNT = RN_COUNT + 1 - - return - end function rang - - !------------------------------------------------------------------- - - subroutine RN_skip( skip ) - ! initialize MCNP random number parameters for particle "nps" - ! - ! * generate a new particle seed from the base seed - ! & particle index - ! * set the RN count to zero - implicit none - integer(I8), intent(in) :: skip - - RN_SEED = RN_skip_ahead( RN_SEED, skip ) - - end subroutine RN_skip - - !------------------------------------------------------------------- - - function RN_skip_ahead( seed, skip ) - ! advance the seed "skip" RNs: seed*RN_MULT^n mod RN_MOD - implicit none - integer(I8) :: RN_skip_ahead - integer(I8), intent(in) :: seed, skip - integer(I8) :: nskip, gen, g, inc, c, gp, rn, seed_old - - seed_old = seed - ! add period till nskip>0 - nskip = skip - do while( nskip<0_I8 ) - if( RN_PERIOD>0_I8 ) then - nskip = nskip + RN_PERIOD - else - nskip = nskip + RN_MASK - nskip = nskip + 1_I8 - endif - enddo - - ! get gen=RN_MULT^n, in log2(n) ops, not n ops ! - nskip = iand( nskip, RN_MASK ) - gen = 1 - g = RN_MULT - inc = 0 - c = RN_ADD - do while( nskip>0_I8 ) - if( btest(nskip,0) ) then - gen = iand( gen*g, RN_MASK ) - inc = iand( inc*g, RN_MASK ) - inc = iand( inc+c, RN_MASK ) - endif - gp = iand( g+1, RN_MASK ) - g = iand( g*g, RN_MASK ) - c = iand( gp*c, RN_MASK ) - nskip = ishft( nskip, -1 ) - enddo - rn = iand( gen*seed_old, RN_MASK ) - rn = iand( rn + inc, RN_MASK ) - RN_skip_ahead = rn - return - end function RN_skip_ahead - - !------------------------------------------------------------------- - - subroutine RN_init_problem( new_standard_gen, new_seed, & - & new_stride, new_part1, print_info ) - ! * initialize MCNP random number parameters for problem, - ! based on user input. This routine should be called - ! only from the main thread, if OMP threading is being used. - ! - ! * for initial & continue runs, these args should be set: - ! new_standard_gen - index of built-in standard RN generator, - ! from RAND gen= (or dbcn(14) - ! new_seed - from RAND seed= (or dbcn(1)) - ! output - logical, print RN seed & mult if true - ! - ! new_stride - from RAND stride= (or dbcn(13)) - ! new_part1 - from RAND hist= (or dbcn(8)) - ! - ! * for continue runs only, these should also be set: - ! new_count_total - from "rnr" at end of previous run - ! new_count_stride - from nrnh(1) at end of previous run - ! new_count_max - from nrnh(2) at end of previous run - ! new_count_max_nps - from nrnh(3) at end of previous run - ! - ! * check on size of long-ints & long-int arithmetic - ! * check the multiplier - ! * advance the base seed for the problem - ! * set the initial particle seed - ! * initialize the counters for RN stats - implicit none - integer, intent(in) :: new_standard_gen - integer(I8), intent(in) :: new_seed - integer(I8), intent(in) :: new_stride - integer(I8), intent(in) :: new_part1 - integer, intent(in) :: print_info - character(len=20) :: printseed - integer(I8) :: itemp1, itemp2, itemp3, itemp4 - - if( new_standard_gen<1 .or. new_standard_gen>n_RN_GEN ) then - call expire( 'RN_init_problem', & - & ' ***** ERROR: illegal index for built-in RN generator') - endif - - ! set defaults, override if input supplied: seed, mult, stride - RN_INDEX = new_standard_gen - RN_MULT = standard_generator(RN_INDEX)%mult - RN_ADD = standard_generator(RN_INDEX)%add - RN_STRIDE = standard_generator(RN_INDEX)%stride - RN_SEED0 = standard_generator(RN_INDEX)%initseed - RN_BITS = standard_generator(RN_INDEX)%log2mod - RN_MOD = ishft( 1_I8, RN_BITS ) - RN_MASK = ishft( not(0_I8), RN_BITS-64 ) - RN_NORM = 2._R8**(-RN_BITS) - if( RN_ADD==0_I8) then - RN_PERIOD = ishft( 1_I8, RN_BITS-2 ) - else - RN_PERIOD = ishft( 1_I8, RN_BITS ) - endif - if( new_seed>0_I8 ) then - RN_SEED0 = new_seed - endif - if( new_stride>0_I8 ) then - RN_STRIDE = new_stride - endif - RN_COUNT_TOTAL = 0 - RN_COUNT_STRIDE = 0 - RN_COUNT_MAX = 0 - RN_COUNT_MAX_NPS = 0 - - if( print_info /= 0 ) then - write(printseed,'(i20)') RN_SEED0 - write( iuo,1) RN_INDEX, RN_SEED0, RN_MULT, RN_ADD, RN_BITS, RN_STRIDE - write(jtty,2) RN_INDEX, adjustl(printseed) -1 format( & - & /,' ***************************************************', & - & /,' * Random Number Generator = ',i20, ' *', & - & /,' * Random Number Seed = ',i20, ' *', & - & /,' * Random Number Multiplier = ',i20, ' *', & - & /,' * Random Number Adder = ',i20, ' *', & - & /,' * Random Number Bits Used = ',i20, ' *', & - & /,' * Random Number Stride = ',i20, ' *', & - & /,' ***************************************************',/) -2 format(' comment. using random number generator ',i2, & - & ', initial seed = ',a20) - endif - - ! double-check on number of bits in a long int - if( bit_size(RN_SEED)<64 ) then - call expire( 'RN_init_problem', & - & ' ***** ERROR: <64 bits in long-int, can-t generate RN-s') - endif - itemp1 = 5_I8**25 - itemp2 = 5_I8**19 - itemp3 = ishft(2_I8**62-1_I8,1) + 1_I8 - itemp4 = itemp1*itemp2 - if( iand(itemp4,itemp3)/=8443747864978395601_I8 ) then - call expire( 'RN_init_problem', & - & ' ***** ERROR: can-t do 64-bit integer ops for RN-s') - endif - - if( new_part1>1_I8 ) then - ! advance the problem seed to that for part1 - RN_SEED0 = RN_skip_ahead( RN_SEED0, (new_part1-1_I8)*RN_STRIDE ) - itemp1 = RN_skip_ahead( RN_SEED0, RN_STRIDE ) - if( print_info /= 0 ) then - write(printseed,'(i20)') itemp1 - write( iuo,3) new_part1, RN_SEED0, itemp1 - write(jtty,4) new_part1, adjustl(printseed) -3 format( & - & /,' ***************************************************', & - & /,' * Random Number Seed will be advanced to that for *', & - & /,' * previous particle number = ',i20, ' *', & - & /,' * New RN Seed for problem = ',i20, ' *', & - & /,' * Next Random Number Seed = ',i20, ' *', & - & /,' ***************************************************',/) -4 format(' comment. advancing random number to particle ',i12, & - & ', initial seed = ',a20) - endif - endif - - ! set the initial particle seed - RN_SEED = RN_SEED0 - RN_COUNT = 0 - RN_NPS = 0 - - return - end subroutine RN_init_problem - - !------------------------------------------------------------------- - - subroutine RN_init_particle( nps ) - ! initialize MCNP random number parameters for particle "nps" - ! - ! * generate a new particle seed from the base seed - ! & particle index - ! * set the RN count to zero - implicit none - integer(I8), intent(in) :: nps - - RN_SEED = RN_skip_ahead( RN_SEED0, nps*RN_STRIDE ) - RN_COUNT = 0 - RN_NPS = nps - - return - end subroutine RN_init_particle - - !------------------------------------------------------------------- - - subroutine RN_set( key, value ) - implicit none - character(len=*), intent(in) :: key - integer(I8), intent(in) :: value - character(len=20) :: printseed - integer(I8) :: itemp1 - - if( key == "stride" ) then - if( value>0_I8 ) then - RN_STRIDE = value - endif - endif - if( key == "count_total" ) RN_COUNT_TOTAL = value - if( key == "count_stride" ) RN_COUNT_STRIDE = value - if( key == "count_max" ) RN_COUNT_MAX = value - if( key == "count_max_nps" ) RN_COUNT_MAX_NPS = value - if( key == "seed" ) then - if( value>0_I8 ) then - RN_SEED0 = value - RN_SEED = RN_SEED0 - RN_COUNT = 0 - RN_NPS = 0 - endif - endif - if( key == "part1" ) then - if( value>1_I8 ) then - ! advance the problem seed to that for part1 - RN_SEED0 = RN_skip_ahead( RN_SEED0, (value-1_I8)*RN_STRIDE ) - itemp1 = RN_skip_ahead( RN_SEED0, RN_STRIDE ) - write(printseed,'(i20)') itemp1 - write( iuo,3) value, RN_SEED0, itemp1 - write(jtty,4) value, adjustl(printseed) -3 format( & - & /,' ***************************************************', & - & /,' * Random Number Seed will be advanced to that for *', & - & /,' * previous particle number = ',i20, ' *', & - & /,' * New RN Seed for problem = ',i20, ' *', & - & /,' * Next Random Number Seed = ',i20, ' *', & - & /,' ***************************************************',/) -4 format(' comment. advancing random number to particle ',i12, & - & ', initial seed = ',a20) - RN_SEED = RN_SEED0 - RN_COUNT = 0 - RN_NPS = 0 - endif - endif - return - end subroutine RN_set - - !------------------------------------------------------------------- - - function RN_query( key ) - implicit none - integer(I8) :: RN_query - character(len=*), intent(in) :: key - RN_query = 0_I8 - if( key == "seed" ) RN_query = RN_SEED - if( key == "stride" ) RN_query = RN_STRIDE - if( key == "mult" ) RN_query = RN_MULT - if( key == "add" ) RN_query = RN_ADD - if( key == "count" ) RN_query = RN_COUNT - if( key == "period" ) RN_query = RN_PERIOD - if( key == "count_total" ) RN_query = RN_COUNT_TOTAL - if( key == "count_stride" ) RN_query = RN_COUNT_STRIDE - if( key == "count_max" ) RN_query = RN_COUNT_MAX - if( key == "count_max_nps" ) RN_query = RN_COUNT_MAX_NPS - if( key == "first" ) RN_query = RN_SEED0 - return - end function RN_query - !------------------------------------------------------------------- - - function RN_query_first( nps ) - implicit none - integer(I8) :: RN_query_first - integer(I8), intent(in) :: nps - RN_query_first = RN_skip_ahead( RN_SEED0, nps*RN_STRIDE ) - return - end function RN_query_first - - !------------------------------------------------------------------- - - subroutine RN_update_stats() - ! update overall RN count info - implicit none - - !$OMP CRITICAL (RN_STATS) - - RN_COUNT_TOTAL = RN_COUNT_TOTAL + RN_COUNT - - if( RN_COUNT>RN_COUNT_MAX ) then - RN_COUNT_MAX = RN_COUNT - RN_COUNT_MAX_NPS = RN_NPS - endif - - if( RN_COUNT>RN_STRIDE ) then - RN_COUNT_STRIDE = RN_COUNT_STRIDE + 1 - endif - - !$OMP END CRITICAL (RN_STATS) - - RN_COUNT = 0 - RN_NPS = 0 - - return - end subroutine RN_update_stats - - !------------------------------------------------------------------- - - subroutine expire( c1, c2 ) - character(len=*), intent(in) :: c1, c2 - write(*,*) ' ********** error: ',c1 - write(*,*) ' ********** error: ',c2 - stop '**error**' - end subroutine expire - - !------------------------------------------------------------------- - !################################################################### - !# - !# Unit tests - !# - !################################################################### - - subroutine RN_test_basic( new_gen ) - ! test routine for basic random number generator - implicit none - integer, intent(in) :: new_gen - real(R8) :: s - integer(I8) :: seeds(10) - integer :: i, j - - write(jtty,"(/,a)") " ***** random number - basic test *****" - - ! set the seed - call RN_init_problem( new_gen, 1_I8, 0_I8, 0_I8, 1 ) - - ! get the first 5 seeds, then skip a few, get 5 more - directly - s = 0.0_R8 - do i = 1,5 - s = s + rang() - seeds(i) = RN_query( "seed" ) - enddo - do i = 6,123455 - s = s + rang() - enddo - do i = 6,10 - s = s + rang() - seeds(i) = RN_query( "seed" ) - enddo - - ! compare - do i = 1,10 - j = i - if( i>5 ) j = i + 123450 - write(jtty,"(1x,i6,a,i20,a,i20)") & - & j, " reference: ", RN_CHECK(i,new_gen), " computed: ", seeds(i) - if( seeds(i)/=RN_CHECK(i,new_gen) ) then - write(jtty,"(a)") " ***** basic_test of RN generator failed:" - endif - enddo - return - end subroutine RN_test_basic - - !------------------------------------------------------------------- - - subroutine RN_test_skip( new_gen ) - ! test routine for basic random number generation & skip-ahead - implicit none - integer, intent(in) :: new_gen - integer(I8) :: seeds(10) - integer :: i, j - - ! set the seed - call RN_init_problem( new_gen, 1_I8, 0_I8, 0_I8, 0 ) - - ! use the skip-ahead function to get first 5 seeds, then 5 more - do i = 1,10 - j = i - if( i>5 ) j = i + 123450 - seeds(i) = RN_skip_ahead( 1_I8, int(j,I8) ) - enddo - - ! compare - write(jtty,"(/,a)") " ***** random number - skip test *****" - do i = 1,10 - j = i - if( i>5 ) j = i + 123450 - write(jtty,"(1x,i6,a,i20,a,i20)") & - & j, " reference: ", RN_CHECK(i,new_gen), " computed: ", seeds(i) - if( seeds(i)/=RN_CHECK(i,new_gen) ) then - write(jtty,"(a)") " ***** skip_test of RN generator failed:" - endif - enddo - return - end subroutine RN_test_skip - - !------------------------------------------------------------------- - - subroutine RN_test_mixed( new_gen ) - ! test routine -- print RN's 1-5 & 123456-123460, - ! with reference vals - implicit none - integer, intent(in) :: new_gen - integer(I8) :: r - integer :: i, j - - write(jtty,"(/,a)") " ***** random number - mixed test *****" - ! set the seed & set the stride to 1 - call RN_init_problem( new_gen, 1_I8, 1_I8, 0_I8, 0 ) - - write(jtty,"(a,i20,z20)") " RN_MULT = ", RN_MULT, RN_MULT - write(jtty,"(a,i20,z20)") " RN_ADD = ", RN_ADD, RN_ADD - write(jtty,"(a,i20,z20)") " RN_MOD = ", RN_MOD, RN_MOD - write(jtty,"(a,i20,z20)") " RN_MASK = ", RN_MASK, RN_MASK - write(jtty,"(a,i20)") " RN_BITS = ", RN_BITS - write(jtty,"(a,i20)") " RN_PERIOD = ", RN_PERIOD - write(jtty,"(a,es20.13)") " RN_NORM = ", RN_NORM - write(jtty,"(a)") " " - do i = 1,10 - j = i - if( i>5 ) j = i + 123450 - call RN_init_particle( int(j,I8) ) - r = RN_query( "seed" ) - write(jtty,"(1x,i6,a,i20,a,i20)") & - & j, " reference: ", RN_CHECK(i,new_gen)," computed: ", r - if( r/=RN_CHECK(i,new_gen) ) then - write(jtty,"(a)") " ***** mixed test of RN generator failed:" - endif - enddo - return - end subroutine RN_test_mixed - - !------------------------------------------------------------------- -end module mcnp_random diff --git a/src/mpi_routines.f90 b/src/mpi_routines.f90 index dc13f04f7..d1cdd82bc 100644 --- a/src/mpi_routines.f90 +++ b/src/mpi_routines.f90 @@ -3,9 +3,9 @@ module mpi_routines use constants, only: MAX_LINE_LEN use error, only: fatal_error use global - use mcnp_random, only: rang, RN_init_particle, RN_skip use output, only: write_message use particle_header, only: Particle, initialize_particle + use random_lcg, only: prn, set_particle_seed, prn_skip use tally_header, only: TallyObject #ifdef MPI @@ -162,10 +162,10 @@ contains end if ! Make sure all processors start at the same point for random sampling - call RN_init_particle(int(i_cycle,8)) + call set_particle_seed(int(i_cycle,8)) ! Skip ahead however many random numbers are needed - call RN_skip(start) + call prn_skip(start) allocate(temp_sites(2*work)) count = 0_8 ! Index for local source_bank @@ -198,7 +198,7 @@ contains end if ! Randomly sample sites needed - if (rang() < p_sample) then + if (prn() < p_sample) then count = count + 1 temp_sites(count) = fission_bank(i) end if diff --git a/src/physics.f90 b/src/physics.f90 index 0cf2f4159..4e896bfb9 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -10,12 +10,12 @@ module physics use geometry_header, only: Universe, BASE_UNIVERSE use global use interpolation, only: interpolate_tab1 - use mcnp_random, only: rang use output, only: write_message, print_particle use particle_header, only: Particle - use tally, only: score_tally, score_surface_current + use random_lcg, only: prn use search, only: binary_search use string, only: int_to_str + use tally, only: score_tally, score_surface_current implicit none @@ -73,7 +73,7 @@ contains call dist_to_boundary(p, d_to_boundary, surf, in_lattice) ! Sample a distance to collision - d_to_collision = -log(rang()) / material_xs % total + d_to_collision = -log(prn()) / material_xs % total ! Select smaller of the two distances distance = min(d_to_boundary, d_to_collision) @@ -454,7 +454,7 @@ contains ! ========================================================================== ! SAMPLE NUCLIDE WITHIN THE MATERIAL - cutoff = rang() * material_xs % total + cutoff = prn() * material_xs % total prob = ZERO i = 0 @@ -491,7 +491,7 @@ contains else ! set cutoff variable for analog cases - cutoff = rang() * micro_xs(index_nuclide) % total + cutoff = prn() * micro_xs(index_nuclide) % total prob = ZERO ! Add disappearance cross-section to prob @@ -518,7 +518,7 @@ contains ! created. if (nuc % has_partial_fission) then - cutoff = rang() * micro_xs(index_nuclide) % fission + cutoff = prn() * micro_xs(index_nuclide) % fission prob = ZERO i = 0 @@ -586,7 +586,7 @@ contains if (survival_biasing) then if (p % wgt < weight_cutoff) then - if (rang() < p % wgt / weight_survive) then + if (prn() < p % wgt / weight_survive) then p % wgt = weight_survive else p % wgt = ZERO @@ -598,7 +598,7 @@ contains ! survival biasing. The cutoff will be a random number times the ! scattering cross section - cutoff = rang() * (micro_xs(index_nuclide) % total - & + cutoff = prn() * (micro_xs(index_nuclide) % total - & micro_xs(index_nuclide) % absorption) prob = ZERO end if @@ -772,7 +772,7 @@ contains sab => sab_tables(index_sab) ! Determine whether inelastic or elastic scattering will occur - if (rang() < micro_xs(index_nuclide) % elastic_sab / & + if (prn() < micro_xs(index_nuclide) % elastic_sab / & micro_xs(index_nuclide) % elastic) then ! elastic scattering @@ -793,7 +793,7 @@ contains ! data derived in the incoherent approximation ! Sample outgoing cosine bin - k = 1 + rang() * sab % n_elastic_mu + k = 1 + prn() * sab % n_elastic_mu ! Determine outgoing cosine corresponding to E_in(i) and E_in(i+1) mu_ijk = sab % elastic_mu(k,i) @@ -808,7 +808,7 @@ contains ! edges. ! Sample a Bragg edge between 1 and i - prob = rang() * sab % elastic_P(i+1) + prob = prn() * sab % elastic_P(i+1) k = binary_search(sab % elastic_P(1:i+1), i+1, prob) ! Characteristic scattering cosine for this Bragg egg @@ -843,9 +843,9 @@ contains if (sab % secondary_mode == SAB_SECONDARY_EQUAL) then ! All bins equally likely - j = 1 + rang() * n_energy_out + j = 1 + prn() * n_energy_out elseif (sab % secondary_mode == SAB_SECONDARY_SKEWED) then - r = rang() * (n_energy_out - 3) + r = prn() * (n_energy_out - 3) if (r > ONE) then ! equally likely N-4 middle bins j = r + 2 @@ -875,7 +875,7 @@ contains E = (1 - f)*E_ij + f*E_i1j ! Sample outgoing cosine bin - k = 1 + rang() * sab % n_inelastic_mu + k = 1 + prn() * sab % n_inelastic_mu ! Determine outgoing cosine corresponding to E_in(i) and E_in(i+1) mu_ijk = sab % inelastic_mu(k,j,i) @@ -942,10 +942,10 @@ contains do ! Sample two random numbers - r1 = rang() - r2 = rang() + r1 = prn() + r2 = prn() - if (rang() < alpha) then + if (prn() < alpha) then ! With probability alpha, we sample the distribution p(y) = ! y*e^(-y). This can be done with sampling scheme C45 frmo the Monte ! Carlo sampler @@ -957,7 +957,7 @@ contains ! e^(-y^2). This can be done with sampling scheme C61 from the Monte ! Carlo sampler - c = cos(PI/2.0 * rang()) + c = cos(PI/2.0 * prn()) beta_vt_sq = -log(r1) - log(r2)*c*c end if @@ -965,14 +965,14 @@ contains beta_vt = sqrt(beta_vt_sq) ! Sample cosine of angle between neutron and target velocity - mu = 2.0*rang() - ONE + mu = 2.0*prn() - ONE ! Determine rejection probability accept_prob = sqrt(beta_vn*beta_vn + beta_vt_sq - 2*beta_vn*beta_vt*mu) & /(beta_vn + beta_vt) ! Perform rejection sampling on vt and mu - if (rang() < accept_prob) exit + if (prn() < accept_prob) exit end do ! determine direction of target velocity based on the neutron's velocity @@ -1065,7 +1065,7 @@ contains nu_t = p % last_wgt * micro_xs(index_nuclide) % fission / (keff * & micro_xs(index_nuclide) % total) * nu_t end if - if (rang() > nu_t - int(nu_t)) then + if (prn() > nu_t - int(nu_t)) then nu = int(nu_t) else nu = int(nu_t) + 1 @@ -1082,12 +1082,12 @@ contains mu = sample_angle(rxn, E) ! sample between delayed and prompt neutrons - if (rang() < beta) then + if (prn() < beta) then ! ==================================================================== ! DELAYED NEUTRON SAMPLED ! sampled delayed precursor group - xi = rang() + xi = prn() loc = 1 prob = ZERO do j = 1, nuc % n_precursor @@ -1139,7 +1139,7 @@ contains end if ! Sample azimuthal angle uniformly in [0,2*pi) - phi = TWO*PI*rang() + phi = TWO*PI*prn() fission_bank(i) % uvw(1) = mu fission_bank(i) % uvw(2) = sqrt(ONE - mu*mu) * cos(phi) fission_bank(i) % uvw(3) = sqrt(ONE - mu*mu) * sin(phi) @@ -1262,7 +1262,7 @@ contains ! check if reaction has angular distribution -- if not, sample outgoing ! angle isotropically if (.not. rxn % has_angle_dist) then - mu = TWO * rang() - ONE + mu = TWO * prn() - ONE return end if @@ -1284,16 +1284,16 @@ contains end if ! Sample between the ith and (i+1)th bin - if (r > rang()) i = i + 1 + if (r > prn()) i = i + 1 ! check whether this is a 32-equiprobable bin or a tabular distribution loc = rxn % adist % location(i) type = rxn % adist % type(i) if (type == ANGLE_ISOTROPIC) then - mu = TWO * rang() - ONE + mu = TWO * prn() - ONE elseif (type == ANGLE_32_EQUI) then ! sample cosine bin - xi = rang() + xi = prn() k = 1 + int(32.0_8*xi) ! calculate cosine @@ -1306,7 +1306,7 @@ contains NP = rxn % adist % data(loc + 2) ! determine outgoing cosine bin - xi = rang() + xi = prn() loc = loc + 2 c_k = rxn % adist % data(loc + 2*NP + 1) do k = 1, NP-1 @@ -1376,7 +1376,7 @@ contains w0 = w ! Sample azimuthal angle in [0,2pi) - phi = TWO * PI * rang() + phi = TWO * PI * prn() ! Precompute factors to save flops sinphi = sin(phi) @@ -1466,7 +1466,7 @@ contains if (edist % p_valid % n_regions > 0) then p_valid = interpolate_tab1(edist % p_valid, E_in) - if (rang() > p_valid) then + if (prn() > p_valid) then if (edist % law == 44 .or. edist % law == 61) then call sample_energy(edist%next, E_in, E_out, mu_out) elseif (edist % law == 66) then @@ -1503,7 +1503,7 @@ contains & (edist%data(loc+i+1) - edist%data(loc+i)) ! Sample outgoing energy bin - r1 = rang() + r1 = prn() k = 1 + int(NET * r1) ! Determine E_1 and E_K @@ -1520,7 +1520,7 @@ contains ! Randomly select between the outgoing table for incoming energy E_i and ! E_(i+1) - if (rang() < r) then + if (prn() < r) then l = i + 1 else l = i @@ -1532,7 +1532,7 @@ contains E_l_k1 = edist % data(loc+k+1) ! Determine E' (denoted here as E_out) - r2 = rang() + r2 = prn() E_out = E_l_k + r2*(E_l_k1 - E_l_k) ! Now interpolate between incident energy bins i and i + 1 @@ -1580,7 +1580,7 @@ contains end if ! Sample between the ith and (i+1)th bin - r2 = rang() + r2 = prn() if (r > r2) then l = i + 1 else @@ -1623,7 +1623,7 @@ contains end if ! determine outgoing energy bin - r1 = rang() + r1 = prn() loc = loc + 2 ! start of EOUT c_k = edist % data(loc + 2*NP + 1) do k = 1, NP-1 @@ -1697,8 +1697,8 @@ contains ! sample outgoing energy based on evaporation spectrum probability ! density function do - r1 = rang() - r2 = rang() + r1 = prn() + r2 = prn() E_out = -T * log(r1*r2) if (E_out <= E_in - U) exit end do @@ -1759,7 +1759,7 @@ contains end if ! Sample between the ith and (i+1)th bin - r2 = rang() + r2 = prn() if (r > r2) then l = i + 1 else @@ -1803,7 +1803,7 @@ contains end if ! determine outgoing energy bin - r1 = rang() + r1 = prn() loc = loc + 2 ! start of EOUT c_k = edist % data(loc + 2*NP + 1) do k = 1, NP-1 @@ -1858,8 +1858,8 @@ contains end if ! Sampled correlated angle from Kalbach-Mann parameters - r3 = rang() - r4 = rang() + r3 = prn() + r4 = prn() T = (TWO*r4 - ONE) * sinh(KM_A) if (r3 > KM_R) then mu_out = log(T + sqrt(T*T + ONE))/KM_A @@ -1902,7 +1902,7 @@ contains end if ! Sample between the ith and (i+1)th bin - r2 = rang() + r2 = prn() if (r > r2) then l = i + 1 else @@ -1946,7 +1946,7 @@ contains end if ! determine outgoing energy bin - r1 = rang() + r1 = prn() loc = loc + 2 ! start of EOUT c_k = edist % data(loc + 2*NP + 1) do k = 1, NP-1 @@ -1992,7 +1992,7 @@ contains ! Check if angular distribution is isotropic if (loc == 0) then - mu_out = TWO * rang() - ONE + mu_out = TWO * prn() - ONE return end if @@ -2001,7 +2001,7 @@ contains NP = edist % data(loc + 2) ! determine outgoing cosine bin - r3 = rang() + r3 = prn() loc = loc + 2 c_k = edist % data(loc + 2*NP + 1) do k = 1, NP-1 @@ -2051,17 +2051,17 @@ contains case (3) y = maxwell_spectrum(ONE) case (4) - r1 = rang() - r2 = rang() - r3 = rang() + r1 = prn() + r2 = prn() + r3 = prn() y = -log(r1*r2*r3) case (5) - r1 = rang() - r2 = rang() - r3 = rang() - r4 = rang() - r5 = rang() - r6 = rang() + r1 = prn() + r2 = prn() + r3 = prn() + r4 = prn() + r5 = prn() + r6 = prn() y = -log(r1*r2*r3*r4) - log(r5) * cos(PI/2.*r6)**2 end select @@ -2092,9 +2092,9 @@ contains real(8) :: r1, r2, r3 ! random numbers real(8) :: c ! cosine of pi/2*r3 - r1 = rang() - r2 = rang() - r3 = rang() + r1 = prn() + r2 = prn() + r3 = prn() ! determine cosine of pi/2*r c = cos(PI/2.*r3) @@ -2121,7 +2121,7 @@ contains real(8) :: w ! sampled from Maxwellian w = maxwell_spectrum(a) - E_out = w + a*a*b/4. + (2.*rang() - ONE)*sqrt(a*a*b*w) + E_out = w + a*a*b/4. + (2.*prn() - ONE)*sqrt(a*a*b*w) end function watt_spectrum @@ -2137,7 +2137,7 @@ contains real(8) :: c - c = -4.*D_avg*D_avg/PI * log(rang()) + c = -4.*D_avg*D_avg/PI * log(prn()) D = sqrt(c) end function wigner @@ -2166,7 +2166,7 @@ contains ! sample x as -2/n*log(product(r_i, i = 1 to n/2)) x = ONE do i = 1, n/2 - x = x * rang() + x = x * prn() end do x = -2./n * log(x) @@ -2178,11 +2178,11 @@ contains ! Note that we take advantage of integer division on n/2 y = ONE do i = 1, n/2 - y = y * rang() + y = y * prn() end do - r1 = rang() - r2 = rang() + r1 = prn() + r2 = prn() c = cos(PI/2.*r2) x = -2./n * (log(y) + log(r1)*c*c) end select diff --git a/src/random_lcg.f90 b/src/random_lcg.f90 new file mode 100644 index 000000000..8b7225c7f --- /dev/null +++ b/src/random_lcg.f90 @@ -0,0 +1,147 @@ +module random_lcg + + implicit none + + private + save + + integer(8) :: prn_seed0 ! original seed + integer(8) :: prn_seed ! current seed + integer(8) :: prn_mult ! multiplication factor, g + integer(8) :: prn_add ! additive factor, c + integer :: prn_bits ! number of bits, M + integer(8) :: prn_mod ! 2^M + integer(8) :: prn_mask ! 2^M - 1 + integer(8) :: prn_stride ! stride between particles + real(8) :: prn_norm ! 2^(-M) + + public :: prn + public :: initialize_prng + public :: set_particle_seed + public :: prn_skip + +contains + +!=============================================================================== +! PRN generates a pseudo-random number using a linean congruential generator +!=============================================================================== + + function prn() result(pseudo_rn) + + real(8) :: pseudo_rn + + ! This algorithm uses bit-masking to find the next integer(8) value to be + ! used to calculate the random number + + prn_seed = iand(prn_mult*prn_seed + prn_add, prn_mask) + + ! Once the integer is calculated, we just need to divide by 2**m, + ! represented here as multiplying by a pre-calculated factor + + pseudo_rn = prn_seed * prn_norm + + end function prn + +!=============================================================================== +! INITIALIZE_PRNG sets up the random number generator, determining the seed and +! values for g, c, and m. +!=============================================================================== + + subroutine initialize_prng() + + prn_seed0 = 1_8 + prn_seed = prn_seed + prn_mult = 2806196910506780709_8 + prn_add = 1_8 + prn_bits = 63 + prn_mod = ibset(0_8, prn_bits) ! clever way of calculating 2**bits + prn_mask = prn_mod - 1_8 + prn_stride = 152917_8 + prn_norm = 2._8**(-prn_bits) + + end subroutine initialize_prng + +!=============================================================================== +! SET_PARTICLE_SEED sets the seed to a unique value based on the ID of the +! particle +!=============================================================================== + + subroutine set_particle_seed(id) + + integer(8), intent(in) :: id + + prn_seed = prn_skip_ahead(id*prn_stride, prn_seed0) + + end subroutine set_particle_seed + +!=============================================================================== +! PRN_SKIP advances the random number seed 'n' times from the current seed +!=============================================================================== + + subroutine prn_skip(n) + + integer(8), intent(in) :: n ! number of seeds to skip + + prn_seed = prn_skip_ahead(n, prn_seed) + + end subroutine prn_skip + +!=============================================================================== +! PRN_SKIP_AHEAD advances the random number seed 'skip' times. This is usually +! used to skip a fixed number of random numbers (the stride) so that a given +! particle always has the same starting seed regardless of how many processors +! are used +!=============================================================================== + + function prn_skip_ahead(n, seed) result(new_seed) + + integer(8), intent(in) :: n ! number of seeds to skip + integer(8), intent(in) :: seed ! original seed + integer(8) :: new_seed ! new seed + + integer(8) :: nskip + integer(8) :: gen + integer(8) :: g + integer(8) :: inc + integer(8) :: c + integer(8) :: gp + + ! In cases where we want to skip backwards, we add the period of the random + ! number generator until the number of PRNs to skip is positive since + ! skipping ahead that much is the same as skipping backwards by the original + ! amount + + nskip = n + do while (nskip < 0_8) + nskip = nskip + prn_mod + enddo + + ! The algorithm here to determine the parameters used to skip ahead is + ! described in F. Brown, "Random Number Generation with Arbitrary Stride," + ! Trans. Am. Nucl. Soc. (Nov. 1994). This algorithm is able to skip ahead in + ! O(log2(N)) operations instead of O(N). Basically, it computes parameters G + ! and C which can then be used to find x_N = G*x_0 + C mod 2^M. + + nskip = iand(nskip, prn_mask) + gen = 1 + g = prn_mult + inc = 0 + c = prn_add + do while (nskip > 0_8) + if (btest(nskip,0)) then + gen = iand(gen*g, prn_mask) + inc = iand(inc*g, prn_mask) + inc = iand(inc+c, prn_mask) + endif + gp = iand(g+1, prn_mask) + g = iand(g*g, prn_mask) + c = iand(gp*c, prn_mask) + nskip = ishft(nskip, -1) + enddo + + ! With G and C, we can now find the new seed + new_seed = iand(gen*seed + inc, prn_mask) + + end function prn_skip_ahead + +end module random_lcg diff --git a/src/source.f90 b/src/source.f90 index 1da0ea2e6..30e60da35 100644 --- a/src/source.f90 +++ b/src/source.f90 @@ -4,10 +4,10 @@ module source use constants, only: ONE, MAX_LINE_LEN use cross_section_header, only: Nuclide use global - use mcnp_random, only: rang, RN_init_particle use output, only: write_message use particle_header, only: Particle, initialize_particle use physics, only: watt_spectrum + use random_lcg, only: prn, set_particle_seed implicit none @@ -61,18 +61,18 @@ contains p => source_bank(j - bank_first + 1) ! initialize random number seed - call RN_init_particle(int(j,8)) + call set_particle_seed(int(j,8)) ! sample position - r = (/ (rang(), k = 1,3) /) + r = (/ (prn(), k = 1,3) /) p % id = j p % xyz = p_min + r*(p_max - p_min) p % xyz_local = p % xyz p % last_xyz = p % xyz ! sample angle - phi = TWO*PI*rang() - mu = TWO*rang() - ONE + phi = TWO*PI*prn() + mu = TWO*prn() - ONE p % uvw(1) = mu p % uvw(2) = sqrt(ONE - mu*mu) * cos(phi) p % uvw(3) = sqrt(ONE - mu*mu) * sin(phi) From 6217177791ad363a017539875a3c9de39ea036ef Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sun, 20 Nov 2011 21:00:25 -0500 Subject: [PATCH 08/70] Added comments in various modules. --- src/constants.f90 | 2 + src/cross_section.f90 | 2 +- src/cross_section_header.f90 | 95 ++++++++++++++++++------------------ src/energy_grid.f90 | 13 +++-- src/fileio.f90 | 2 +- src/physics.f90 | 2 +- 6 files changed, 58 insertions(+), 58 deletions(-) diff --git a/src/constants.f90 b/src/constants.f90 index c44f979b3..a1ee88cf8 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -208,6 +208,8 @@ module constants T_MESH = 6, & T_ENERGYIN = 7, & T_ENERGYOUT = 8 + + ! Filter types for surface current tallies integer, parameter :: & TS_MESH_X = 1, & TS_MESH_Y = 2, & diff --git a/src/cross_section.f90 b/src/cross_section.f90 index 452eaba09..c0db7c8b3 100644 --- a/src/cross_section.f90 +++ b/src/cross_section.f90 @@ -800,7 +800,7 @@ contains integer :: LED ! location of energy distribution locators integer :: LOCC ! location of energy distributions for given MT integer :: i ! loop index - type(Reaction), pointer :: rxn => null() + type(Reaction), pointer :: rxn => null() LED = JXS(10) diff --git a/src/cross_section_header.f90 b/src/cross_section_header.f90 index aed755c51..e630ce772 100644 --- a/src/cross_section_header.f90 +++ b/src/cross_section_header.f90 @@ -67,28 +67,28 @@ module cross_section_header !=============================================================================== type Nuclide - character(20) :: name - integer :: zaid - real(8) :: awr - real(8) :: kT + character(10) :: name ! name of nuclide, e.g. 92235.03c + integer :: zaid ! Z and A identifier, e.g. 92235 + real(8) :: awr ! weight of nucleus in neutron masses + real(8) :: kT ! temperature in MeV (k*T) ! Energy grid information - integer :: n_grid - integer, allocatable :: grid_index(:) - real(8), allocatable :: energy(:) + integer :: n_grid ! # of nuclide grid points + integer, allocatable :: grid_index(:) ! pointers to union grid + real(8), allocatable :: energy(:) ! energy values corresponding to xs - ! Cross sections - real(8), allocatable :: total(:) - real(8), allocatable :: elastic(:) - real(8), allocatable :: fission(:) - real(8), allocatable :: absorption(:) - real(8), allocatable :: heating(:) + ! Microscopic cross sections + real(8), allocatable :: total(:) ! total cross section + real(8), allocatable :: elastic(:) ! elastic scattering + real(8), allocatable :: fission(:) ! fission + real(8), allocatable :: absorption(:) ! absorption (MT > 100) + real(8), allocatable :: heating(:) ! heating ! Fission information - logical :: fissionable - logical :: has_partial_fission - integer :: n_fission - integer, allocatable :: index_fission(:) + logical :: fissionable ! nuclide is fissionable? + logical :: has_partial_fission ! nuclide has partial fission reactions? + integer :: n_fission ! # of fission reactions + integer, allocatable :: index_fission(:) ! indices in reactions ! Total fission neutron emission integer :: nu_t_type @@ -100,7 +100,7 @@ module cross_section_header ! Delayed fission neutron emission integer :: nu_d_type - integer :: n_precursor + integer :: n_precursor ! # of delayed neutron precursors real(8), allocatable :: nu_d_data(:) real(8), allocatable :: nu_d_precursor_data(:) type(DistEnergy), pointer :: nu_d_edist(:) => null() @@ -110,7 +110,7 @@ module cross_section_header type(UrrData), pointer :: urr_data => null() ! Reactions - integer :: n_reaction + integer :: n_reaction ! # of reactions type(Reaction), pointer :: reactions(:) => null() end type Nuclide @@ -121,29 +121,29 @@ module cross_section_header !=============================================================================== type SAB_Table - character(20) :: name - integer :: zaid - real(8) :: awr - real(8) :: kT + character(10) :: name ! name of table, e.g. lwtr.10t + integer :: zaid ! Z and A identifier, e.g. 6012 for Carbon-12 + real(8) :: awr ! weight of nucleus in neutron masses + real(8) :: kT ! temperature in MeV (k*T) ! threshold for S(a,b) treatment (usually ~4 eV) real(8) :: threshold_inelastic real(8) :: threshold_elastic = 0.0 ! Inelastic scattering data - integer :: n_inelastic_e_in - integer :: n_inelastic_e_out - integer :: n_inelastic_mu - integer :: secondary_mode + integer :: n_inelastic_e_in ! # of incoming E for inelastic + integer :: n_inelastic_e_out ! # of outgoing E for inelastic + integer :: n_inelastic_mu ! # of outgoing angles for inelastic + integer :: secondary_mode ! secondary mode (equal/skewed) real(8), allocatable :: inelastic_e_in(:) real(8), allocatable :: inelastic_sigma(:) real(8), allocatable :: inelastic_e_out(:,:) real(8), allocatable :: inelastic_mu(:,:,:) ! Elastic scattering data - integer :: elastic_mode - integer :: n_elastic_e_in - integer :: n_elastic_mu + integer :: elastic_mode ! elastic mode (discrete/exact) + integer :: n_elastic_e_in ! # of incoming E for elastic + integer :: n_elastic_mu ! # of outgoing angles for elastic real(8), allocatable :: elastic_e_in(:) real(8), allocatable :: elastic_P(:) real(8), allocatable :: elastic_mu(:,:) @@ -174,20 +174,20 @@ module cross_section_header !=============================================================================== type NuclideMicroXS - integer :: index_grid - integer :: index_temp - integer :: last_index_grid - integer :: last_index_temp - real(8) :: interp_factor - real(8) :: total - real(8) :: elastic - real(8) :: absorption - real(8) :: fission - real(8) :: nu_fission + integer :: index_grid ! index on nuclide energy grid + integer :: index_temp ! temperature index for nuclide + integer :: last_index_grid ! previous index on nuclide energy grid + integer :: last_index_temp ! previous temperature index for nuclide + real(8) :: interp_factor ! interpolation factor on nuc. energy grid + real(8) :: total ! microscropic total xs + real(8) :: elastic ! microscopic elastic scattering xs + real(8) :: absorption ! microscopic absorption xs + real(8) :: fission ! microscopic fission xs + real(8) :: nu_fission ! microscopic production xs ! Information for S(a,b) use - logical :: use_sab - real(8) :: elastic_sab + logical :: use_sab ! in S(a,b) energy range? + real(8) :: elastic_sab ! microscopic elastic scattering on S(a,b) table end type NuclideMicroXS !=============================================================================== @@ -196,12 +196,11 @@ module cross_section_header !=============================================================================== type MaterialMacroXS - real(8) :: total - real(8) :: scatter - real(8) :: elastic - real(8) :: absorption - real(8) :: fission - real(8) :: nu_fission + real(8) :: total ! macroscopic total xs + real(8) :: elastic ! macroscopic elastic scattering xs + real(8) :: absorption ! macroscopic absorption xs + real(8) :: fission ! macroscopic fission xs + real(8) :: nu_fission ! macroscopic production xs end type MaterialMacroXS end module cross_section_header diff --git a/src/energy_grid.f90 b/src/energy_grid.f90 index 04c50bbb0..891b8c57c 100644 --- a/src/energy_grid.f90 +++ b/src/energy_grid.f90 @@ -18,11 +18,12 @@ contains subroutine unionized_grid() + integer :: i ! index over materials + integer :: j ! index over nuclides type(ListReal), pointer :: list => null() type(ListReal), pointer :: current => null() type(Material), pointer :: mat => null() type(Nuclide), pointer :: nuc => null() - integer :: i, j message = "Creating unionized energy grid..." call write_message(5) @@ -31,7 +32,7 @@ contains do i = 1, n_materials mat => materials(i) - ! loop over all isotopes + ! loop over all nuclides do j = 1, mat % n_nuclides nuc => nuclides(mat % nuclide(j)) @@ -152,14 +153,13 @@ contains subroutine original_indices() - integer :: i, j + integer :: i + integer :: j integer :: index integer :: n_grid_nuclide - type(Nuclide), pointer :: nuc - real(8) :: union_energy real(8) :: energy - + type(Nuclide), pointer :: nuc do i = 1, n_nuclides_total nuc => nuclides(i) @@ -177,7 +177,6 @@ contains end if nuc % grid_index(j) = index-1 end do - end do end subroutine original_indices diff --git a/src/fileio.f90 b/src/fileio.f90 index 48205a3f8..928b0eb95 100644 --- a/src/fileio.f90 +++ b/src/fileio.f90 @@ -79,7 +79,7 @@ contains integer, intent(in) :: n_lines ! number of lines to skip integer, intent(out) :: ioError ! error status - integer :: i ! index for number of lines + integer :: i ! index for number of lines do i = 1, n_lines read(UNIT=unit, FMT=*, IOSTAT=ioError) diff --git a/src/physics.f90 b/src/physics.f90 index 4e896bfb9..be49d3d9c 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -324,7 +324,7 @@ contains + inelastic + elastic micro_xs(i) % elastic = inelastic + elastic - ! Store ratio of elastic to elastic+inelastic for sampling later + ! Store S(a,b) elastic cross section for sampling later micro_xs(i) % elastic_sab = elastic end if From af33e02e1caa81a1637118f03a20ce8c4167d05e Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sun, 20 Nov 2011 21:10:35 -0500 Subject: [PATCH 09/70] Changed creation of unionized energy grid so if a nuclide appears on multiple materials, it's not added twice. --- src/energy_grid.f90 | 55 ++++++++++++++++++++++++++++++++------------- 1 file changed, 39 insertions(+), 16 deletions(-) diff --git a/src/energy_grid.f90 b/src/energy_grid.f90 index 891b8c57c..c57e12f0d 100644 --- a/src/energy_grid.f90 +++ b/src/energy_grid.f90 @@ -1,8 +1,10 @@ module energy_grid use constants, only: MAX_LINE_LEN - use datatypes, only: list_insert, list_size, list_delete - use datatypes_header, only: ListReal + use datatypes, only: list_insert, list_size, list_delete, & + dict_create, dict_get_key, dict_has_key, & + dict_add_key, dict_delete + use datatypes_header, only: ListReal, DictionaryCI use global use output, only: write_message @@ -18,26 +20,46 @@ contains subroutine unionized_grid() - integer :: i ! index over materials - integer :: j ! index over nuclides - type(ListReal), pointer :: list => null() - type(ListReal), pointer :: current => null() - type(Material), pointer :: mat => null() - type(Nuclide), pointer :: nuc => null() + integer :: i ! index in materials array + integer :: j ! index over nuclides in material + integer :: index ! index in xs_listings array + integer :: index_nuclides ! index in nuclides + character(10) :: name ! name of isotope, e.g. 92235.03c + character(10) :: alias ! alias of nuclide, e.g. U-235.03c + type(ListReal), pointer :: list => null() + type(ListReal), pointer :: current => null() + type(Material), pointer :: mat => null() + type(Nuclide), pointer :: nuc => null() + type(DictionaryCI), pointer :: already_added => null() message = "Creating unionized energy grid..." call write_message(5) - ! loop over all materials + ! Create dictionary for keeping track of cross sections already added + call dict_create(already_added) + + ! Loop over all files do i = 1, n_materials mat => materials(i) - - ! loop over all nuclides - do j = 1, mat % n_nuclides - nuc => nuclides(mat % nuclide(j)) - ! loop over energy points - call add_grid_points(list, nuc % energy) + do j = 1, mat % n_nuclides + name = mat % names(j) + + if (.not. dict_has_key(already_added, name)) then + ! loop over energy points + nuc => nuclides(mat % nuclide(j)) + call add_grid_points(list, nuc % energy) + + ! determine name and alias from xs_listings + index = dict_get_key(xs_listing_dict, name) + index_nuclides = dict_get_key(nuclide_dict, name) + name = xs_listings(index) % name + alias = xs_listings(index) % alias + + ! add name and alias to dictionary + call dict_add_key(already_added, name, 0) + call dict_add_key(already_added, alias, 0) + end if end do end do @@ -50,8 +72,9 @@ contains current => current % next end do - ! delete linked list + ! delete linked list and dictionary call list_delete(list) + call dict_delete(already_added) end subroutine unionized_grid From 643faa9fb18cba3c4516eefba62d3b0431ad80a6 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sun, 20 Nov 2011 21:57:01 -0500 Subject: [PATCH 10/70] Rearranged Makefile. --- src/Makefile | 81 ++++++++++++++++++++++++---------------------------- 1 file changed, 37 insertions(+), 44 deletions(-) diff --git a/src/Makefile b/src/Makefile index 14b0d9909..cc5782e0a 100644 --- a/src/Makefile +++ b/src/Makefile @@ -20,58 +20,64 @@ DEBUG = no PROFILE = no OPTIMIZE = no USE_MPI = no -USE_OPENMP = no -USE_COARRAY = no #=============================================================================== -# Compiler Options -#=============================================================================== - # Intel Fortran compiler options +#=============================================================================== ifeq ($(COMPILER),intel) F90 = ifort F90FLAGS := -fpp -warn -assume byterecl LDFLAGS = + + # Debugging options + ifeq ($(DEBUG),yes) + F90FLAGS += -g -traceback -ftrapuv -fp-stack-check -check all + LDFLAGS += -g + endif + + # Profiling options + ifeq ($(PROFILE),yes) + F90FLAGS += -pg + LDFLAGS += -pg + endif + + # Optimization + ifeq ($(OPTIMIZE),yes) + F90FLAGS += -O3 # -ipo + endif endif +#=============================================================================== # GNU Fortran compiler options +#=============================================================================== ifeq ($(COMPILER),gfortran) F90 = gfortran F90FLAGS := -cpp -Wall LDFLAGS = -endif -# Set compiler flags for debugging - -ifeq ($(DEBUG),yes) - F90FLAGS += -g - LDFLAGS += -g - ifeq ($(COMPILER),intel) - F90FLAGS += -traceback -ftrapuv -fp-stack-check -check all - endif - ifeq ($(COMPILER),gfortran) - F90FLAGS += -pedantic -std=f2008 -fbacktrace -fbounds-check \ + # Debugging options + ifeq ($(DEBUG),yes) + F90FLAGS += -g -pedantic -std=f2008 -fbacktrace -fbounds-check \ -ffpe-trap=invalid,zero,overflow,underflow + LDFLAGS += -g + endif + + # Profiling options + ifeq ($(PROFILE),yes) + F90FLAGS += -pg + LDFLAGS += -pg + endif + + ifeq ($(OPTIMIZE),yes) + F90FLAGS += -O3 endif endif -# Set compiler flags for profiling - -ifeq ($(PROFILE),yes) - F90FLAGS += -pg - LDFLAGS += -pg -endif - -# Set compiler flags for high optimization - -ifeq ($(OPTIMIZE),yes) - F90FLAGS += -O3 - ifeq ($(COMPILER),intel) - F90FLAGS += -ipo - endif -endif +#=============================================================================== +# Miscellaneous compiler options +#=============================================================================== # Use MPI for parallelism @@ -81,19 +87,6 @@ ifeq ($(USE_MPI),yes) F90FLAGS += -DMPI endif -# Use OpenMP for shared-memory parallelism - -ifeq ($(USE_OPENMP),yes) - F90FLAGS += -openmp - LDFLAGS += -openmp -endif - -# Use Fortran 2008 Coarrays for parallelism - -ifeq ($(USE_COARRAY),yes) - F90FLAGS += -coarray -endif - #=============================================================================== # Targets #=============================================================================== From 5017f9d24269bd36716d421bf2b5360720c5b5e0 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sun, 20 Nov 2011 19:20:55 -0800 Subject: [PATCH 11/70] Added PGI options in Makefile. --- src/Makefile | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/src/Makefile b/src/Makefile index cc5782e0a..f93c54f05 100644 --- a/src/Makefile +++ b/src/Makefile @@ -75,6 +75,37 @@ ifeq ($(COMPILER),gfortran) endif endif +#=============================================================================== +# PGI compiler options +#=============================================================================== + +ifeq ($(COMPILER),pgi) + F90 = pgf90 + F90FLAGS := -Mpreprocess -Minform=inform + LDFLAGS = + + # Since ERFC is currently not supported in the PGI compiler and this intrinsic + # is used in the doppler module (which is not actually used yet), it is + # removed from the source objects + objects := $(subst doppler.o, ,$(objects)) + + # Debugging options + ifeq ($(DEBUG),yes) + F90FLAGS += -g -Mbounds -Mchkptr -Mchkstk -traceback + LDFLAGS += -g + endif + + # Profiling options + ifeq ($(PROFILE),yes) + F90FLAGS += -pg + LDFLAGS += -pg + endif + + ifeq ($(OPTIMIZE),yes) + F90FLAGS += -fast -Mipa + endif +endif + #=============================================================================== # Miscellaneous compiler options #=============================================================================== From 0bbf63e0a87c336bfd64dd7f8f35a56368f43e39 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 21 Nov 2011 06:56:09 -0800 Subject: [PATCH 12/70] Removed several recursive I/O calls in output module to get PGI compiler to work. --- src/output.f90 | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/output.f90 b/src/output.f90 index 4e7f0ccb0..06bb12fb5 100644 --- a/src/output.f90 +++ b/src/output.f90 @@ -69,21 +69,22 @@ contains call header("PROBLEM SUMMARY") if (problem_type == PROB_CRITICALITY) then write(ou,100) 'Problem type:', 'Criticality' - write(ou,100) 'Number of Cycles:', int_to_str(n_cycles) - write(ou,100) 'Number of Inactive Cycles:', int_to_str(n_inactive) + write(ou,101) 'Number of Cycles:', n_cycles + write(ou,101) 'Number of Inactive Cycles:', n_inactive elseif (problem_type == PROB_SOURCE) then write(ou,100) 'Problem type:', 'External Source' end if - write(ou,100) 'Number of Particles:', int_to_str(n_particles) + write(ou,101) 'Number of Particles:', n_particles ! Display geometry summary call header("GEOMETRY SUMMARY") - write(ou,100) 'Number of Cells:', int_to_str(n_cells) - write(ou,100) 'Number of Surfaces:', int_to_str(n_surfaces) - write(ou,100) 'Number of Materials:', int_to_str(n_materials) + write(ou,101) 'Number of Cells:', n_cells + write(ou,101) 'Number of Surfaces:', n_surfaces + write(ou,101) 'Number of Materials:', n_materials ! Format descriptor for columns 100 format (1X,A,T35,A) +101 format (1X,A,T35,I11) end subroutine echo_input @@ -654,6 +655,7 @@ contains type(Lattice), pointer :: l => null() type(Material), pointer :: m => null() type(TallyObject), pointer :: t => null() + character(15) :: string integer :: i ! print summary of cells @@ -709,8 +711,10 @@ contains else write(ou,100) "Survival Biasing:", "off" end if - write(ou,100) "Weight Cutoff:", trim(real_to_str(weight_cutoff)) - write(ou,100) "Survival weight:", trim(real_to_str(weight_survive)) + string = real_to_str(weight_cutoff) + write(ou,100) "Weight Cutoff:", trim(string) + string = real_to_str(weight_survive) + write(ou,100) "Survival weight:", trim(string) write(ou,*) ! Format descriptor for columns From 03f00a2259751ed1f28a3e5d07c948a4a549ae7e Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 21 Nov 2011 10:41:34 -0500 Subject: [PATCH 13/70] Fixed derived type for StructuredMesh (had int4s instead of real8s for origin and width). --- src/mesh_header.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/mesh_header.f90 b/src/mesh_header.f90 index 9ed686ec7..3d6ba48d3 100644 --- a/src/mesh_header.f90 +++ b/src/mesh_header.f90 @@ -12,8 +12,8 @@ module mesh_header integer :: type integer :: n_dimension integer, allocatable :: dimension(:) - integer, allocatable :: origin(:) - integer, allocatable :: width(:) + real(8), allocatable :: origin(:) + real(8), allocatable :: width(:) end type StructuredMesh end module mesh_header From d4fc0b7b278bfc4b6e88b102bc5089a0325b4383 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 21 Nov 2011 10:55:27 -0500 Subject: [PATCH 14/70] Explicit type casting from real8s to int4s in many modules. --- src/cross_section.f90 | 120 +++++++++++----------- src/global.f90 | 2 +- src/initialize.f90 | 4 +- src/input_xml.f90 | 12 +-- src/interpolation.f90 | 8 +- src/mpi_routines.f90 | 20 ++-- src/output.f90 | 4 +- src/physics.f90 | 98 +++++++++--------- src/xml-fortran/templates/materials_t.xml | 2 +- 9 files changed, 135 insertions(+), 135 deletions(-) diff --git a/src/cross_section.f90 b/src/cross_section.f90 index c0db7c8b3..6a89e33a0 100644 --- a/src/cross_section.f90 +++ b/src/cross_section.f90 @@ -464,21 +464,21 @@ contains ! ======================================================================= ! PROMPT AND TOTAL NU DATA -- read prompt data first KNU = JXS2 + 1 - LNU = XSS(KNU) + LNU = int(XSS(KNU)) if (LNU == 1) then ! Polynomial data nuc % nu_p_type = NU_POLYNOMIAL ! allocate determine how many coefficients for polynomial - NC = XSS(KNU+1) + NC = int(XSS(KNU+1)) length = NC + 1 elseif (LNU == 2) then ! Tabular data nuc % nu_p_type = NU_TABULAR ! determine number of interpolation regions and number of energies - NR = XSS(KNU+1) - NE = XSS(KNU+2+2*NR) + NR = int(XSS(KNU+1)) + NE = int(XSS(KNU+2+2*NR)) length = 2 + 2*NR + 2*NE end if @@ -490,8 +490,8 @@ contains nuc % nu_p_data = get_real(length) ! Now read total nu data - KNU = JXS2 + abs(XSS(JXS2)) + 1 - LNU = XSS(KNU) + KNU = JXS2 + int(abs(XSS(JXS2))) + 1 + LNU = int(XSS(KNU)) if (LNU == 1) then ! Polynomial data nuc % nu_t_type = NU_POLYNOMIAL @@ -550,7 +550,7 @@ contains ! Loop over all delayed neutron precursor groups do i = 1, NPCR ! find location of energy distribution data - LOCC = XSS(LED + i - 1) + LOCC = int(XSS(LED + i - 1)) ! read energy distribution data edist => nuc % nu_d_edist(i) @@ -564,8 +564,8 @@ contains length = 0 loc = JXS(25) do i = 1, NPCR - NR = XSS(loc + length + 1) - NE = XSS(loc + length + 2 + 2*NR) + NR = int(XSS(loc + length + 1)) + NE = int(XSS(loc + length + 2 + 2*NR)) length = length + 3 + 2*NR + 2*NE end do @@ -640,17 +640,17 @@ contains rxn => nuc % reactions(i+1) ! read MT number, Q-value, and neutrons produced - rxn % MT = XSS(LMT + i - 1) + rxn % MT = int(XSS(LMT + i - 1)) rxn % Q_value = XSS(JXS4 + i - 1) - rxn % TY = XSS(JXS5 + i - 1) + rxn % TY = int(XSS(JXS5 + i - 1)) ! read starting energy index - LOCA = XSS(LXS + i - 1) - IE = XSS(JXS7 + LOCA - 1) + LOCA = int(XSS(LXS + i - 1)) + IE = int(XSS(JXS7 + LOCA - 1)) rxn % IE = IE ! read number of energies cross section values - NE = XSS(JXS7 + LOCA) + NE = int(XSS(JXS7 + LOCA)) allocate(rxn % sigma(NE)) XSS_index = JXS7 + LOCA + 1 rxn % sigma = get_real(NE) @@ -727,7 +727,7 @@ contains rxn => nuc%reactions(i) ! find location of angular distribution - LOCB = XSS(JXS8 + i - 1) + LOCB = int(XSS(JXS8 + i - 1)) if (LOCB == -1) then ! Angular distribution data are specified through LAWi = 44 in the DLW ! block @@ -740,7 +740,7 @@ contains rxn % has_angle_dist = .true. ! allocate space for incoming energies and locations - NE = XSS(JXS9 + LOCB - 1) + NE = int(XSS(JXS9 + LOCB - 1)) rxn % adist % n_energy = NE allocate(rxn % adist % energy(NE)) allocate(rxn % adist % type(NE)) @@ -765,7 +765,7 @@ contains elseif (LC < 0) then ! tabular distribution rxn % adist % type(j) = ANGLE_TABULAR - NP = XSS(JXS9 + abs(LC)) + NP = int(XSS(JXS9 + abs(LC))) length = length + 2 + 3*NP end if end do @@ -810,7 +810,7 @@ contains rxn % has_energy_dist = .true. ! find location of energy distribution data - LOCC = XSS(LED + i - 1) + LOCC = int(XSS(LED + i - 1)) ! allocate energy distribution allocate(rxn % edist) @@ -851,10 +851,10 @@ contains end if ! locator for next law and information on this law - LNW = XSS(LDIS + loc_law - 1) - LAW = XSS(LDIS + loc_law) - IDAT = XSS(LDIS + loc_law + 1) - NR = XSS(LDIS + loc_law + 2) + LNW = int(XSS(LDIS + loc_law - 1)) + LAW = int(XSS(LDIS + loc_law)) + IDAT = int(XSS(LDIS + loc_law + 1)) + NR = int(XSS(LDIS + loc_law + 2)) edist % law = LAW edist % p_valid % n_regions = NR @@ -867,12 +867,12 @@ contains ! read ENDF interpolation parameters XSS_index = LDIS + loc_law + 3 if (NR > 0) then - edist % p_valid % nbt = get_real(NR) - edist % p_valid % int = get_real(NR) + edist % p_valid % nbt = int(get_real(NR)) + edist % p_valid % int = int(get_real(NR)) end if ! allocate space for law validity data - NE = XSS(LDIS + loc_law + 3 + 2*NR) + NE = int(XSS(LDIS + loc_law + 3 + 2*NR)) edist % p_valid % n_pairs = NE allocate(edist % p_valid % x(NE)) allocate(edist % p_valid % y(NE)) @@ -934,9 +934,9 @@ contains select case (law) case (1) ! Tabular equiprobable energy bins - NR = XSS(loc + 1) - NE = XSS(loc + 2 + 2*NR) - NP = XSS(loc + 3 + 2*NR + NE) + NR = int(XSS(loc + 1)) + NE = int(XSS(loc + 2 + 2*NR)) + NP = int(XSS(loc + 3 + 2*NR + NE)) length = 3 + 2*NR + NE + 3*NP*NE case (2) @@ -949,12 +949,12 @@ contains case (4) ! Continuous tabular distribution - NR = XSS(loc + 1) - NE = XSS(loc + 2 + 2*NR) + NR = int(XSS(loc + 1)) + NE = int(XSS(loc + 2 + 2*NR)) length = length + 2 + 2*NR + 2*NE do i = 1,NE ! determine length - NP = XSS(loc + length + 2) + NP = int(XSS(loc + length + 2)) length = length + 2 + 3*NP ! adjust location for this block @@ -964,38 +964,38 @@ contains case (5) ! General evaporation spectrum - NR = XSS(loc + 1) - NE = XSS(loc + 2 + 2*NR) - NP = XSS(loc + 3 + 2*NR + 2*NE) + NR = int(XSS(loc + 1)) + NE = int(XSS(loc + 2 + 2*NR)) + NP = int(XSS(loc + 3 + 2*NR + 2*NE)) length = 3 + 2*NR + 2*NE + NP case (7) ! Maxwell fission spectrum - NR = XSS(loc + 1) - NE = XSS(loc + 2 + 2*NR) + NR = int(XSS(loc + 1)) + NE = int(XSS(loc + 2 + 2*NR)) length = 3 + 2*NR + 2*NE case (9) ! Evaporation spectrum - NR = XSS(loc + 1) - NE = XSS(loc + 2 + 2*NR) + NR = int(XSS(loc + 1)) + NE = int(XSS(loc + 2 + 2*NR)) length = 3 + 2*NR + 2*NE case (11) ! Watt spectrum - NRa = XSS(loc + 1) - NEa = XSS(loc + 2 + 2*NRa) - NRb = XSS(loc + 3 + 2*(NRa+NEa)) - NEb = XSS(loc + 4 + 2*(NRa+NEa+NRb)) + NRa = int(XSS(loc + 1)) + NEa = int(XSS(loc + 2 + 2*NRa)) + NRb = int(XSS(loc + 3 + 2*(NRa+NEa))) + NEb = int(XSS(loc + 4 + 2*(NRa+NEa+NRb))) length = 5 + 2*(NRa + NEa + NRb + NEb) case (44) ! Kalbach-Mann correlated scattering - NR = XSS(loc + 1) - NE = XSS(loc + 2 + 2*NR) + NR = int(XSS(loc + 1)) + NE = int(XSS(loc + 2 + 2*NR)) length = length + 2 + 2*NR + 2*NE do i = 1,NE - NP = XSS(loc + length + 2) + NP = int(XSS(loc + length + 2)) length = length + 2 + 5*NP ! adjust location for this block @@ -1005,12 +1005,12 @@ contains case (61) ! Correlated energy and angle distribution - NR = XSS(loc + 1) - NE = XSS(loc + 2 + 2*NR) + NR = int(XSS(loc + 1)) + NE = int(XSS(loc + 2 + 2*NR)) length = length + 2 + 2*NR + 2*NE do i = 1,NE ! outgoing energy distribution - NP = XSS(loc + length + 2) + NP = int(XSS(loc + length + 2)) ! adjust locators for angular distribution do j = 1, NP @@ -1022,7 +1022,7 @@ contains do j = 1, NP ! outgoing angle distribution -- NMU here is actually ! referred to as NP in the MCNP documentation - NMU = XSS(loc + length + 2) + NMU = int(XSS(loc + length + 2)) length = length + 2 + 3*NMU end do @@ -1037,9 +1037,9 @@ contains case (67) ! Laboratory energy-angle law - NR = XSS(loc + 1) - NE = XSS(loc + 2 + 2*NR) - NMU = XSS(loc + 4 + 2*NR + 2*NE) + NR = int(XSS(loc + 1)) + NE = int(XSS(loc + 2 + 2*NR)) + NMU = int(XSS(loc + 4 + 2*NR + 2*NE)) length = 4 + 2*(NR + NE + NMU) end select @@ -1077,12 +1077,12 @@ contains end if ! read parameters - nuc % urr_data % params(1) = XSS(loc) ! # of incident energies - nuc % urr_data % params(2) = XSS(loc + 1) ! # of probabilities - nuc % urr_data % params(3) = XSS(loc + 2) ! interpolation parameter - nuc % urr_data % params(4) = XSS(loc + 3) ! inelastic competition flag - nuc % urr_data % params(5) = XSS(loc + 4) ! other absorption flag - nuc % urr_data % params(6) = XSS(loc + 5) ! factors flag + nuc % urr_data % params(1) = int(XSS(loc)) ! # of incident energies + nuc % urr_data % params(2) = int(XSS(loc + 1)) ! # of probabilities + nuc % urr_data % params(3) = int(XSS(loc + 2)) ! interpolation parameter + nuc % urr_data % params(4) = int(XSS(loc + 3)) ! inelastic competition flag + nuc % urr_data % params(5) = int(XSS(loc + 4)) ! other absorption flag + nuc % urr_data % params(6) = int(XSS(loc + 5)) ! factors flag ! allocate incident energies and probability tables N = nuc % urr_data % params(1) @@ -1130,7 +1130,7 @@ contains table % secondary_mode = NXS(7) ! read number of inelastic energies and allocate arrays - NE_in = XSS(JXS(1)) + NE_in = int(XSS(JXS(1))) table % n_inelastic_e_in = NE_in allocate(table % inelastic_e_in(NE_in)) allocate(table % inelastic_sigma(NE_in)) @@ -1172,7 +1172,7 @@ contains ! read number of elastic energies and allocate arrays JXS4 = JXS(4) if (JXS4 /= 0) then - NE_in = XSS(JXS4) + NE_in = int(XSS(JXS4)) table % n_elastic_e_in = NE_in allocate(table % elastic_e_in(NE_in)) allocate(table % elastic_P(NE_in)) diff --git a/src/global.f90 b/src/global.f90 index b47c8a9a6..2356e5c8d 100644 --- a/src/global.f90 +++ b/src/global.f90 @@ -147,7 +147,7 @@ module global ! ============================================================================ ! MISCELLANEOUS VARIABLES - character(MAX_WORD_LEN) :: path_input ! Path to input file + character(MAX_FILE_LEN) :: path_input ! Path to input file character(MAX_FILE_LEN) :: path_cross_sections ! Path to cross_sections.xml ! Message used in message/warning/fatal_error diff --git a/src/initialize.f90 b/src/initialize.f90 index 8c84c2d7b..bd181da2e 100644 --- a/src/initialize.f90 +++ b/src/initialize.f90 @@ -121,8 +121,8 @@ contains integer :: i ! loop index integer :: argc ! number of command line arguments integer :: last_flag ! index of last flag - character(MAX_LINE_LEN) :: pwd ! present working directory - character(MAX_WORD_LEN) :: argv(10) ! command line arguments + character(MAX_FILE_LEN) :: pwd ! present working directory + character(MAX_WORD_LEN) :: argv(10) ! command line arguments ! Get working directory call GET_ENVIRONMENT_VARIABLE("PWD", pwd) diff --git a/src/input_xml.f90 b/src/input_xml.f90 index 5403e59b2..7ed392135 100644 --- a/src/input_xml.f90 +++ b/src/input_xml.f90 @@ -425,7 +425,7 @@ contains logical :: file_exists character(3) :: default_xs character(MAX_WORD_LEN) :: units - character(MAX_WORD_LEN) :: name + character(10) :: name character(MAX_LINE_LEN) :: filename type(Material), pointer :: m => null() type(nuclide_xml), pointer :: nuc => null() @@ -712,7 +712,7 @@ contains call split_string(tally_(i) % filters % cell, words, n_words) allocate(t % cell_bins(n_words)) do j = 1, n_words - t % cell_bins(j) % scalar = str_to_int(words(j)) + t % cell_bins(j) % scalar = int(str_to_int(words(j)),4) end do t % n_bins(T_CELL) = n_words end if @@ -722,7 +722,7 @@ contains call split_string(tally_(i) % filters % surface, words, n_words) allocate(t % surface_bins(n_words)) do j = 1, n_words - t % surface_bins(j) % scalar = str_to_int(words(j)) + t % surface_bins(j) % scalar = int(str_to_int(words(j)),4) end do t % n_bins(T_SURFACE) = n_words end if @@ -732,7 +732,7 @@ contains call split_string(tally_(i) % filters % universe, words, n_words) allocate(t % universe_bins(n_words)) do j = 1, n_words - t % universe_bins(j) % scalar = str_to_int(words(j)) + t % universe_bins(j) % scalar = int(str_to_int(words(j)),4) end do t % n_bins(T_UNIVERSE) = n_words end if @@ -742,7 +742,7 @@ contains call split_string(tally_(i) % filters % material, words, n_words) allocate(t % material_bins(n_words)) do j = 1, n_words - t % material_bins(j) % scalar = str_to_int(words(j)) + t % material_bins(j) % scalar = int(str_to_int(words(j)),4) end do t % n_bins(T_MATERIAL) = n_words end if @@ -769,7 +769,7 @@ contains call split_string(tally_(i) % filters % cellborn, words, n_words) allocate(t % cellborn_bins(n_words)) do j = 1, n_words - t % cellborn_bins(j) % scalar = str_to_int(words(j)) + t % cellborn_bins(j) % scalar = int(str_to_int(words(j)),4) end do t % n_bins(T_CELLBORN) = n_words end if diff --git a/src/interpolation.f90 b/src/interpolation.f90 index 9027adb00..8e3f083ff 100644 --- a/src/interpolation.f90 +++ b/src/interpolation.f90 @@ -51,14 +51,14 @@ contains end if ! determine number of interpolation regions - n_regions = data(loc_0 + 1) + n_regions = int(data(loc_0 + 1)) ! set locations for breakpoints and interpolation schemes loc_breakpoints = loc_0 + 1 loc_interp = loc_breakpoints + n_regions ! determine number of tabulated values - n_points = data(loc_interp + n_regions + 1) + n_points = int(data(loc_interp + n_regions + 1)) ! set locations for x's and y's loc_x = loc_interp + n_regions + 1 @@ -81,11 +81,11 @@ contains if (n_regions == 0) then interp = LINEAR_LINEAR elseif (n_regions == 1) then - interp = data(loc_interp + 1) + interp = int(data(loc_interp + 1)) elseif (n_regions > 1) then do j = 1, n_regions if (i < data(loc_breakpoints + j)) then - interp = data(loc_interp + j) + interp = int(data(loc_interp + j)) exit end if end do diff --git a/src/mpi_routines.f90 b/src/mpi_routines.f90 index d1cdd82bc..594651874 100644 --- a/src/mpi_routines.f90 +++ b/src/mpi_routines.f90 @@ -183,7 +183,7 @@ contains ! ========================================================================== ! SAMPLE N_PARTICLES FROM FISSION BANK AND PLACE IN TEMP_SITES - do i = 1, n_bank + do i = 1, int(n_bank,4) ! If there are less than n_particles particles banked, automatically add ! int(n_particles/total) sites to temp_sites. For example, if you need @@ -221,8 +221,8 @@ contains #endif ! Determine how many sites to send to adjacent nodes - send_to_left = bank_first - 1 - start - send_to_right = finish - bank_last + send_to_left = int(bank_first - 1_8 - start, 4) + send_to_right = int(finish - bank_last, 4) if (rank == n_procs - 1) then if (total > n_particles) then @@ -236,7 +236,7 @@ contains ! If we have too few sites, grab sites from the very end of the ! fission bank sites_needed = n_particles - total - do i = 1, sites_needed + do i = 1, int(sites_needed,4) count = count + 1 temp_sites(count) = fission_bank(n_bank - sites_needed + i) end do @@ -285,27 +285,27 @@ contains ! ========================================================================== ! RECONSTRUCT SOURCE BANK if (send_to_left < 0 .and. send_to_right >= 0) then - i = -send_to_left ! size of first block - j = count - send_to_right ! size of second block + i = -send_to_left ! size of first block + j = int(count,4) - send_to_right ! size of second block call copy_from_bank(temp_sites, i+1, j) #ifdef MPI call MPI_WAIT(request_left, status, ierr) #endif call copy_from_bank(left_bank, 1, i) else if (send_to_left >= 0 .and. send_to_right < 0) then - i = count - send_to_left ! size of first block - j = -send_to_right ! size of second block + i = int(count,4) - send_to_left ! size of first block + j = -send_to_right ! size of second block call copy_from_bank(temp_sites(1+send_to_left), 1, i) #ifdef MPI call MPI_WAIT(request_right, status, ierr) #endif call copy_from_bank(right_bank, i+1, j) else if (send_to_left >= 0 .and. send_to_right >= 0) then - i = count - send_to_left - send_to_right + i = int(count,4) - send_to_left - send_to_right call copy_from_bank(temp_sites(1+send_to_left), 1, i) else if (send_to_left < 0 .and. send_to_right < 0) then i = -send_to_left - j = count + j = int(count,4) k = -send_to_right call copy_from_bank(temp_sites, i+1, j) #ifdef MPI diff --git a/src/output.f90 b/src/output.f90 index 06bb12fb5..6aa6a5d0d 100644 --- a/src/output.f90 +++ b/src/output.f90 @@ -763,8 +763,8 @@ contains subroutine print_runtime() - integer :: total_particles - real(8) :: speed + integer(8) :: total_particles + real(8) :: speed ! display header block call header("Time Elapsed") diff --git a/src/physics.f90 b/src/physics.f90 index be49d3d9c..a0566dc5d 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -793,7 +793,7 @@ contains ! data derived in the incoherent approximation ! Sample outgoing cosine bin - k = 1 + prn() * sab % n_elastic_mu + k = 1 + int(prn() * sab % n_elastic_mu) ! Determine outgoing cosine corresponding to E_in(i) and E_in(i+1) mu_ijk = sab % elastic_mu(k,i) @@ -843,12 +843,12 @@ contains if (sab % secondary_mode == SAB_SECONDARY_EQUAL) then ! All bins equally likely - j = 1 + prn() * n_energy_out + j = 1 + int(prn() * n_energy_out) elseif (sab % secondary_mode == SAB_SECONDARY_SKEWED) then r = prn() * (n_energy_out - 3) if (r > ONE) then ! equally likely N-4 middle bins - j = r + 2 + j = int(r) + 2 elseif (r > 0.6) then ! second to last bin has relative probability of 0.4 j = n_energy_out - 1 @@ -875,7 +875,7 @@ contains E = (1 - f)*E_ij + f*E_i1j ! Sample outgoing cosine bin - k = 1 + prn() * sab % n_inelastic_mu + k = 1 + int(prn() * sab % n_inelastic_mu) ! Determine outgoing cosine corresponding to E_in(i) and E_in(i+1) mu_ijk = sab % inelastic_mu(k,j,i) @@ -1072,8 +1072,8 @@ contains end if ! Bank source neutrons - if (nu == 0 .or. n_bank == 3*n_particles) return - do i = n_bank + 1, min(n_bank + nu, 3*n_particles) + if (nu == 0 .or. n_bank == 3*work) return + do i = int(n_bank,4) + 1, int(min(n_bank + nu, 3*work),4) ! Bank source neutrons by copying particle data fission_bank(i) % id = p % id fission_bank(i) % xyz = p % xyz @@ -1092,8 +1092,8 @@ contains prob = ZERO do j = 1, nuc % n_precursor ! determine number of interpolation regions and energies - NR = nuc % nu_d_precursor_data(loc + 1) - NE = nuc % nu_d_precursor_data(loc + 2 + 2*NR) + NR = int(nuc % nu_d_precursor_data(loc + 1)) + NE = int(nuc % nu_d_precursor_data(loc + 2 + 2*NR)) ! determine delayed neutron precursor yield for group j yield = interpolate_tab1(nuc % nu_d_precursor_data( & @@ -1149,7 +1149,7 @@ contains end do ! increment number of bank sites - n_bank = min(n_bank + nu, 3*n_particles) + n_bank = min(n_bank + nu, 3*work) p % n_bank = nu end subroutine create_fission_sites @@ -1302,8 +1302,8 @@ contains mu = mu0 + (32.0_8 * xi - k) * (mu1 - mu0) elseif (type == ANGLE_TABULAR) then - interp = rxn % adist % data(loc + 1) - NP = rxn % adist % data(loc + 2) + interp = int(rxn % adist % data(loc + 1)) + NP = int(rxn % adist % data(loc + 2)) ! determine outgoing cosine bin xi = prn() @@ -1487,9 +1487,9 @@ contains ! read number of interpolation regions, incoming energies, and outgoing ! energies - NR = edist % data(1) - NE = edist % data(2 + 2*NR) - NET = edist % data(3 + 2*NR + NE) + NR = int(edist % data(1)) + NE = int(edist % data(2 + 2*NR)) + NET = int(edist % data(3 + 2*NR + NE)) if (NR > 0) then message = "Multiple interpolation regions not supported while & &attempting to sample equiprobable energy bins." @@ -1555,8 +1555,8 @@ contains ! CONTINUOUS TABULAR DISTRIBUTION ! read number of interpolation regions and incoming energies - NR = edist % data(1) - NE = edist % data(2 + 2*NR) + NR = int(edist % data(1)) + NE = int(edist % data(2 + 2*NR)) if (NR > 0) then message = "Multiple interpolation regions not supported while & &attempting to sample continuous tabular distribution." @@ -1588,13 +1588,13 @@ contains end if ! interpolation for energy E1 and EK - loc = edist%data(2 + 2*NR + NE + i) - NP = edist%data(loc + 2) + loc = int(edist%data(2 + 2*NR + NE + i)) + NP = int(edist%data(loc + 2)) E_i_1 = edist%data(loc + 2 + 1) E_i_K = edist%data(loc + 2 + NP) - loc = edist%data(2 + 2*NR + NE + i + 1) - NP = edist%data(loc + 2) + loc = int(edist%data(2 + 2*NR + NE + i + 1)) + NP = int(edist%data(loc + 2)) E_i1_1 = edist%data(loc + 2 + 1) E_i1_K = edist%data(loc + 2 + NP) @@ -1602,11 +1602,11 @@ contains E_K = E_i_K + r*(E_i1_K - E_i_K) ! determine location of outgoing energies, pdf, cdf for E(l) - loc = edist % data(2 + 2*NR + NE + l) + loc = int(edist % data(2 + 2*NR + NE + l)) ! determine type of interpolation and number of discrete lines - INTTp = edist % data(loc + 1) - NP = edist % data(loc + 2) + INTTp = int(edist % data(loc + 1)) + NP = int(edist % data(loc + 2)) if (INTTp > 10) then INTT = mod(INTTp,10) ND = (INTTp - INTT)/10 @@ -1684,8 +1684,8 @@ contains ! EVAPORATION SPECTRUM ! read number of interpolation regions and incoming energies - NR = edist % data(1) - NE = edist % data(2 + 2*NR) + NR = int(edist % data(1)) + NE = int(edist % data(2 + 2*NR)) ! determine nuclear temperature from tabulated function T = interpolate_tab1(edist % data, E_in) @@ -1709,8 +1709,8 @@ contains ! read number of interpolation regions and incoming energies for ! parameter 'a' - NR = edist % data(1) - NE = edist % data(2 + 2*NR) + NR = int(edist % data(1)) + NE = int(edist % data(2 + 2*NR)) ! determine Watt parameter 'a' from tabulated function Watt_a = interpolate_tab1(edist % data, E_in) @@ -1734,8 +1734,8 @@ contains end if ! read number of interpolation regions and incoming energies - NR = edist % data(1) - NE = edist % data(2 + 2*NR) + NR = int(edist % data(1)) + NE = int(edist % data(2 + 2*NR)) if (NR > 0) then message = "Multiple interpolation regions not supported while & &attempting to sample Kalbach-Mann distribution." @@ -1767,14 +1767,14 @@ contains end if ! determine endpoints on grid i - loc = edist%data(2+2*NR+NE + i) ! start of LDAT for i - NP = edist%data(loc + 2) + loc = int(edist%data(2+2*NR+NE + i)) ! start of LDAT for i + NP = int(edist%data(loc + 2)) E_i_1 = edist%data(loc + 2 + 1) E_i_K = edist%data(loc + 2 + NP) ! determine endpoints on grid i+1 - loc = edist%data(2+2*NR+NE + i+1) ! start of LDAT for i+1 - NP = edist%data(loc + 2) + loc = int(edist%data(2+2*NR+NE + i+1)) ! start of LDAT for i+1 + NP = int(edist%data(loc + 2)) E_i1_1 = edist%data(loc + 2 + 1) E_i1_K = edist%data(loc + 2 + NP) @@ -1782,11 +1782,11 @@ contains E_K = E_i_K + r*(E_i1_K - E_i_K) ! determine location of outgoing energies, pdf, cdf for E(l) - loc = edist % data(2 + 2*NR + NE + l) + loc = int(edist % data(2 + 2*NR + NE + l)) ! determine type of interpolation and number of discrete lines - INTTp = edist % data(loc + 1) - NP = edist % data(loc + 2) + INTTp = int(edist % data(loc + 1)) + NP = int(edist % data(loc + 2)) if (INTTp > 10) then INTT = mod(INTTp,10) ND = (INTTp - INTT)/10 @@ -1877,8 +1877,8 @@ contains end if ! read number of interpolation regions and incoming energies - NR = edist % data(1) - NE = edist % data(2 + 2*NR) + NR = int(edist % data(1)) + NE = int(edist % data(2 + 2*NR)) if (NR > 0) then message = "Multiple interpolation regions not supported while & &attempting to sample correlated energy-angle distribution." @@ -1910,14 +1910,14 @@ contains end if ! determine endpoints on grid i - loc = edist%data(2+2*NR+NE + i) ! start of LDAT for i - NP = edist%data(loc + 2) + loc = int(edist%data(2+2*NR+NE + i)) ! start of LDAT for i + NP = int(edist%data(loc + 2)) E_i_1 = edist%data(loc + 2 + 1) E_i_K = edist%data(loc + 2 + NP) ! determine endpoints on grid i+1 - loc = edist%data(2+2*NR+NE + i+1) ! start of LDAT for i+1 - NP = edist%data(loc + 2) + loc = int(edist%data(2+2*NR+NE + i+1)) ! start of LDAT for i+1 + NP = int(edist%data(loc + 2)) E_i1_1 = edist%data(loc + 2 + 1) E_i1_K = edist%data(loc + 2 + NP) @@ -1925,11 +1925,11 @@ contains E_K = E_i_K + r*(E_i1_K - E_i_K) ! determine location of outgoing energies, pdf, cdf for E(l) - loc = edist % data(2 + 2*NR + NE + l) + loc = int(edist % data(2 + 2*NR + NE + l)) ! determine type of interpolation and number of discrete lines - INTTp = edist % data(loc + 1) - NP = edist % data(loc + 2) + INTTp = int(edist % data(loc + 1)) + NP = int(edist % data(loc + 2)) if (INTTp > 10) then INTT = mod(INTTp,10) ND = (INTTp - INTT)/10 @@ -1988,7 +1988,7 @@ contains end if ! Find location of correlated angular distribution - loc = edist % data(loc+3*NP+k) + loc = int(edist % data(loc+3*NP+k)) ! Check if angular distribution is isotropic if (loc == 0) then @@ -1997,8 +1997,8 @@ contains end if ! interpolation type and number of points in angular distribution - JJ = edist % data(loc + 1) - NP = edist % data(loc + 2) + JJ = int(edist % data(loc + 1)) + NP = int(edist % data(loc + 2)) ! determine outgoing cosine bin r3 = prn() @@ -2038,7 +2038,7 @@ contains ! N-BODY PHASE SPACE DISTRIBUTION ! read number of bodies in phase space and total mass ratio - n_bodies = edist % data(1) + n_bodies = int(edist % data(1)) Ap = edist % data(2) ! determine E_max parameter diff --git a/src/xml-fortran/templates/materials_t.xml b/src/xml-fortran/templates/materials_t.xml index 7ef52b2f1..36207aa78 100644 --- a/src/xml-fortran/templates/materials_t.xml +++ b/src/xml-fortran/templates/materials_t.xml @@ -15,7 +15,7 @@ - + From 1c4c072826256e7db53cedee2742913070c42949 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 21 Nov 2011 09:36:26 -0800 Subject: [PATCH 15/70] Fixed null pointer on rxn%MT in sample_reaction. Miscellaneous changes for PGI compiler. --- src/error.f90 | 5 ++++- src/global.f90 | 3 --- src/output.f90 | 22 ++++++++++++---------- src/physics.f90 | 9 ++++++--- 4 files changed, 22 insertions(+), 17 deletions(-) diff --git a/src/error.f90 b/src/error.f90 index 73e23c386..fab7c8dc8 100644 --- a/src/error.f90 +++ b/src/error.f90 @@ -64,9 +64,12 @@ contains write(eu,*) end if - ! All processors abort + ! Release memory from all allocatable arrays call free_memory() + ! Abort program + stop + end subroutine fatal_error end module error diff --git a/src/global.f90 b/src/global.f90 index 2356e5c8d..e5533a638 100644 --- a/src/global.f90 +++ b/src/global.f90 @@ -196,9 +196,6 @@ contains call MPI_FINALIZE(ierr) #endif - ! End program - stop - end subroutine free_memory end module global diff --git a/src/output.f90 b/src/output.f90 index 6aa6a5d0d..79fed2480 100644 --- a/src/output.f90 +++ b/src/output.f90 @@ -763,17 +763,18 @@ contains subroutine print_runtime() - integer(8) :: total_particles - real(8) :: speed + integer(8) :: total_particles + real(8) :: speed + character(15) :: string ! display header block call header("Time Elapsed") ! display time elapsed for various sections - write(ou,100) "Total time elapsed", trim(real_to_str(time_total % elapsed)) - write(ou,100) "Total time for initialization", trim(real_to_str(time_init % elapsed)) - write(ou,100) "Total time in computation", trim(real_to_str(time_compute % elapsed)) - write(ou,100) "Total time between cycles", trim(real_to_str(time_intercycle % elapsed)) + write(ou,100) "Total time elapsed", time_total % elapsed + write(ou,100) "Total time for initialization", time_init % elapsed + write(ou,100) "Total time in computation", time_compute % elapsed + write(ou,100) "Total time between cycles", time_intercycle % elapsed ! display header block call header("Run Statistics") @@ -781,14 +782,15 @@ contains ! display calculate rate and final keff total_particles = n_particles * n_cycles speed = real(total_particles) / time_compute % elapsed - write(ou,101) "Calculation Rate", trim(real_to_str(speed)) - write(ou,102) "Final Keff", trim(real_to_str(keff)), trim(real_to_str(keff_std)) + string = real_to_str(speed) + write(ou,101) "Calculation Rate", trim(string) + write(ou,102) "Final Keff", keff, keff_std write(ou,*) ! format for write statements -100 format (1X,A,T33,"= ",A," seconds") +100 format (1X,A,T33,"= ",ES11.4," seconds") 101 format (1X,A,T20,"= ",A," neutrons/second") -102 format (1X,A,T20,"= ",A," +/- ",A) +102 format (1X,A,T20,"= ",F8.5," +/- ",F8.5) end subroutine print_runtime diff --git a/src/physics.f90 b/src/physics.f90 index a0566dc5d..65bcc3a0a 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -621,8 +621,11 @@ contains ! Perform collision physics for elastic scattering call elastic_scatter(p, nuc, rxn) + end if + ! Set MT to be returned + MT = 2 else ! ======================================================================= ! INELASTIC SCATTERING @@ -662,10 +665,10 @@ contains ! Perform collision physics for inelastics scattering call inelastic_scatter(p, nuc, rxn) - end if - ! Set MT to be returned - MT = rxn % MT + ! Set MT to be returned + MT = rxn % MT + end if end subroutine sample_reaction From b78676e7c842cfc15768e5f62d02c70d1fde739f Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 21 Nov 2011 11:09:22 -0800 Subject: [PATCH 16/70] Changed variable names to not override intrinsics. --- src/cross_section.f90 | 28 +++++++++---------- src/energy_grid.f90 | 48 ++++++++++++++++----------------- src/fileio.f90 | 14 +++++----- src/geometry.f90 | 28 +++++++++---------- src/input_xml.f90 | 18 ++++++------- src/mpi_routines.f90 | 62 +++++++++++++++++++++---------------------- src/output.f90 | 24 ++++++++--------- src/search.f90 | 34 +++++++----------------- src/string.f90 | 20 +++++++------- src/tally.f90 | 44 +++++++++++++++--------------- 10 files changed, 150 insertions(+), 170 deletions(-) diff --git a/src/cross_section.f90 b/src/cross_section.f90 index 6a89e33a0..99c356422 100644 --- a/src/cross_section.f90 +++ b/src/cross_section.f90 @@ -39,7 +39,7 @@ contains integer :: i ! index in materials array integer :: j ! index over nuclides in material - integer :: index ! index in xs_listings array + integer :: index_list ! index in xs_listings array integer :: index_nuclides ! index in nuclides integer :: index_sab ! index in sab_tables character(10) :: name ! name of isotope, e.g. 92235.03c @@ -76,9 +76,9 @@ contains ! Find index in xs_listing and set the name and alias according to the ! listing - index = dict_get_key(xs_listing_dict, name) - name = xs_listings(index) % name - alias = xs_listings(index) % alias + index_list = dict_get_key(xs_listing_dict, name) + name = xs_listings(index_list) % name + alias = xs_listings(index_list) % alias ! If this nuclide hasn't been encountered yet, we need to add its name ! and alias to the nuclide_dict @@ -107,9 +107,9 @@ contains ! Find index in xs_listing and set the name and alias according to the ! listing - index = dict_get_key(xs_listing_dict, name) - name = xs_listings(index) % name - alias = xs_listings(index) % alias + index_list = dict_get_key(xs_listing_dict, name) + name = xs_listings(index_list) % name + alias = xs_listings(index_list) % alias ! If this S(a,b) table hasn't been encountered yet, we need to add its ! name and alias to the sab_dict @@ -146,12 +146,12 @@ contains name = mat % names(j) if (.not. dict_has_key(already_read, name)) then - index = dict_get_key(xs_listing_dict, name) + index_list = dict_get_key(xs_listing_dict, name) index_nuclides = dict_get_key(nuclide_dict, name) - name = xs_listings(index) % name - alias = xs_listings(index) % alias + name = xs_listings(index_list) % name + alias = xs_listings(index_list) % alias - call read_ace_table(index_nuclides, index) + call read_ace_table(index_nuclides, index_list) call dict_add_key(already_read, name, 0) call dict_add_key(already_read, alias, 0) @@ -162,10 +162,10 @@ contains name = mat % sab_name if (.not. dict_has_key(already_read, name)) then - index = dict_get_key(xs_listing_dict, name) - index_sab = dict_get_key(sab_dict, name) + index_list = dict_get_key(xs_listing_dict, name) + index_sab = dict_get_key(sab_dict, name) - call read_ace_table(index_sab, index) + call read_ace_table(index_sab, index_list) call dict_add_key(already_read, name, 0) end if diff --git a/src/energy_grid.f90 b/src/energy_grid.f90 index c57e12f0d..25adf1af2 100644 --- a/src/energy_grid.f90 +++ b/src/energy_grid.f90 @@ -22,8 +22,7 @@ contains integer :: i ! index in materials array integer :: j ! index over nuclides in material - integer :: index ! index in xs_listings array - integer :: index_nuclides ! index in nuclides + integer :: index_list ! index in xs_listings array character(10) :: name ! name of isotope, e.g. 92235.03c character(10) :: alias ! alias of nuclide, e.g. U-235.03c type(ListReal), pointer :: list => null() @@ -51,10 +50,9 @@ contains call add_grid_points(list, nuc % energy) ! determine name and alias from xs_listings - index = dict_get_key(xs_listing_dict, name) - index_nuclides = dict_get_key(nuclide_dict, name) - name = xs_listings(index) % name - alias = xs_listings(index) % alias + index_list = dict_get_key(xs_listing_dict, name) + name = xs_listings(index_list) % name + alias = xs_listings(index_list) % alias ! add name and alias to dictionary call dict_add_key(already_added, name, 0) @@ -88,7 +86,7 @@ contains type(ListReal), pointer :: list real(8), intent(in) :: energy(:) - integer :: index + integer :: i integer :: n real(8) :: E type(ListReal), pointer :: current => null() @@ -96,7 +94,7 @@ contains type(ListReal), pointer :: head => null() type(ListReal), pointer :: tmp => null() - index = 1 + i = 1 n = size(energy) ! if the original list is empty, we need to allocate the first element and @@ -104,9 +102,9 @@ contains if (list_size(list) == 0) then allocate(list) current => list - do index = 1, n - current % data = energy(index) - if (index == n) then + do i = 1, n + current % data = energy(i) + if (i == n) then current % next => null() return end if @@ -118,19 +116,19 @@ contains current => list head => list - do while (index <= n) - E = energy(index) + do while (i <= n) + E = energy(i) ! If we've reached the end of the grid energy list, add the remaining ! energy points to the end if (.not. associated(current)) then ! finish remaining energies - do while (index <= n) + do while (i <= n) allocate(previous % next) current => previous % next - current % data = energy(index) + current % data = energy(i) previous => current - index = index + 1 + i = i + 1 end do current%next => null() exit @@ -151,12 +149,12 @@ contains nullify(tmp) ! advance index - index = index + 1 + i = i + 1 elseif (E == current % data) then ! found the exact same energy, no need to store duplicates so just ! skip and move to next index - index = index + 1 + i = i + 1 else previous => current current => current % next @@ -178,7 +176,7 @@ contains integer :: i integer :: j - integer :: index + integer :: index_e integer :: n_grid_nuclide real(8) :: union_energy real(8) :: energy @@ -189,16 +187,16 @@ contains n_grid_nuclide = size(nuc % energy) allocate(nuc % grid_index(n_grid)) - index = 1 - energy = nuc % energy(index) + index_e = 1 + energy = nuc % energy(index_e) do j = 1, n_grid union_energy = e_grid(j) - if (union_energy >= energy .and. index < n_grid_nuclide) then - index = index + 1 - energy = nuc % energy(index) + if (union_energy >= energy .and. index_e < n_grid_nuclide) then + index_e = index_e + 1 + energy = nuc % energy(index_e) end if - nuc % grid_index(j) = index-1 + nuc % grid_index(j) = index_e - 1 end do end do diff --git a/src/fileio.f90 b/src/fileio.f90 index 928b0eb95..84aae2c83 100644 --- a/src/fileio.f90 +++ b/src/fileio.f90 @@ -37,9 +37,9 @@ contains character(MAX_LINE_LEN) :: line ! single line character(MAX_WORD_LEN) :: local_words(MAX_WORDS) ! words on one line - integer :: index ! index of words + integer :: index_word ! index of words - index = 0 + index_word = 0 do ! read line from file read(UNIT=unit, FMT='(A100)', IOSTAT=ioError) line @@ -55,17 +55,17 @@ contains ! Check whether there is a continuation line if (local_words(n) == '&') then - words(index+1:index+n-1) = local_words(1:n-1) - index = index + n - 1 + words(index_word+1:index_word+n-1) = local_words(1:n-1) + index_word = index_word + n - 1 else - words(index+1:index+n) = local_words(1:n) - index = index + n + words(index_word+1:index_word+n) = local_words(1:n) + index_word = index_word + n exit end if end do ! set total number of words - n = index + n = index_word end subroutine get_next_line diff --git a/src/geometry.f90 b/src/geometry.f90 index 387fea4af..0e28d3ea3 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -1129,7 +1129,7 @@ contains integer :: i ! index in cells/surfaces array integer :: j ! index of surface in cell - integer :: index ! index in count arrays + integer :: i_surface ! index in count arrays integer, allocatable :: count_positive(:) ! # of cells on positive side integer, allocatable :: count_negative(:) ! # of cells on negative side logical :: positive ! positive side specified in surface list @@ -1149,13 +1149,13 @@ contains ! loop over each surface specification do j = 1, c % n_surfaces - index = c % surfaces(j) - positive = (index > 0) - index = abs(index) + i_surface = c % surfaces(j) + positive = (i_surface > 0) + i_surface = abs(i_surface) if (positive) then - count_positive(index) = count_positive(index) + 1 + count_positive(i_surface) = count_positive(i_surface) + 1 else - count_negative(index) = count_negative(index) + 1 + count_negative(i_surface) = count_negative(i_surface) + 1 end if end do end do @@ -1180,17 +1180,17 @@ contains ! loop over each surface specification do j = 1, c % n_surfaces - index = c % surfaces(j) - positive = (index > 0) - index = abs(index) + i_surface = c % surfaces(j) + positive = (i_surface > 0) + i_surface = abs(i_surface) - surf => surfaces(index) + surf => surfaces(i_surface) if (positive) then - count_positive(index) = count_positive(index) + 1 - surf%neighbor_pos(count_positive(index)) = i + count_positive(i_surface) = count_positive(i_surface) + 1 + surf%neighbor_pos(count_positive(i_surface)) = i else - count_negative(index) = count_negative(index) + 1 - surf%neighbor_neg(count_negative(index)) = i + count_negative(i_surface) = count_negative(i_surface) + 1 + surf%neighbor_neg(count_negative(i_surface)) = i end if end do end do diff --git a/src/input_xml.f90 b/src/input_xml.f90 index 7ed392135..4009aa54d 100644 --- a/src/input_xml.f90 +++ b/src/input_xml.f90 @@ -151,7 +151,7 @@ contains integer :: n integer :: n_x, n_y integer :: universe_num - integer :: count + integer :: n_cells_in_univ integer :: coeffs_reqd logical :: file_exists character(MAX_LINE_LEN) :: filename @@ -228,12 +228,12 @@ contains universe_num = cell_(i) % universe if (.not. dict_has_key(cells_in_univ_dict, universe_num)) then n_universes = n_universes + 1 - count = 1 + n_cells_in_univ = 1 call dict_add_key(universe_dict, universe_num, n_universes) else - count = 1 + dict_get_key(cells_in_univ_dict, universe_num) + n_cells_in_univ = 1 + dict_get_key(cells_in_univ_dict, universe_num) end if - call dict_add_key(cells_in_univ_dict, universe_num, count) + call dict_add_key(cells_in_univ_dict, universe_num, n_cells_in_univ) end do @@ -575,7 +575,7 @@ contains integer :: i ! loop over user-specified tallies integer :: j ! loop over words integer :: id ! user-specified identifier - integer :: index ! index in meshes array + integer :: i_mesh ! index in meshes array integer :: n ! size of arrays in mesh specification integer :: n_words ! number of words read logical :: file_exists ! does tallies.xml file exist? @@ -753,8 +753,8 @@ contains ! Determine index in mesh array for this bin id = t % mesh if (dict_has_key(mesh_dict, id)) then - index = dict_get_key(mesh_dict, id) - m => meshes(index) + i_mesh = dict_get_key(mesh_dict, id) + m => meshes(i_mesh) else message = "Could not find mesh " // trim(int_to_str(id)) // & " specified on tally " // trim(int_to_str(t % id)) @@ -876,8 +876,8 @@ contains ! Get pointer to mesh id = t % mesh - index = dict_get_key(mesh_dict, id) - m => meshes(index) + i_mesh = dict_get_key(mesh_dict, id) + 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. diff --git a/src/mpi_routines.f90 b/src/mpi_routines.f90 index 594651874..847fbc5a5 100644 --- a/src/mpi_routines.f90 +++ b/src/mpi_routines.f90 @@ -111,8 +111,7 @@ contains integer(8) :: start ! starting index in local fission bank integer(8) :: finish ! ending index in local fission bank integer(8) :: total ! total sites in global fission bank - integer(8) :: count ! index for source bank - integer(8) :: index ! index for id -- accounts for all nodes + integer(8) :: index_local ! index for source bank integer :: send_to_left ! # of bank sites to send/recv to or from left integer :: send_to_right ! # of bank sites to send/recv to or from right integer(8) :: sites_needed ! # of sites to be sampled @@ -168,8 +167,7 @@ contains call prn_skip(start) allocate(temp_sites(2*work)) - count = 0_8 ! Index for local source_bank - index = 0_8 ! Index for global source id -- must account for all nodes + index_local = 0_8 ! Index for local source_bank if (total < n_particles) then sites_needed = mod(n_particles,total) @@ -192,15 +190,15 @@ contains if (total < n_particles) then do j = 1,int(n_particles/total) ! If index is within this node's range, add site to source - count = count + 1 - temp_sites(count) = fission_bank(i) + index_local = index_local + 1 + temp_sites(index_local) = fission_bank(i) end do end if ! Randomly sample sites needed if (prn() < p_sample) then - count = count + 1 - temp_sites(count) = fission_bank(i) + index_local = index_local + 1 + temp_sites(index_local) = fission_bank(i) end if end do @@ -208,16 +206,16 @@ contains ! the source bank #ifdef MPI start = 0_8 - call MPI_EXSCAN(count, start, 1, MPI_INTEGER8, MPI_SUM, & + call MPI_EXSCAN(index_local, start, 1, MPI_INTEGER8, MPI_SUM, & & MPI_COMM_WORLD, ierr) - finish = start + count + finish = start + index_local total = finish call MPI_BCAST(total, 1, MPI_INTEGER8, n_procs - 1, & & MPI_COMM_WORLD, ierr) #else start = 0_8 - finish = count - total = count + finish = index_local + total = index_local #endif ! Determine how many sites to send to adjacent nodes @@ -229,7 +227,7 @@ contains ! If we have extra sites sampled, we will simply discard the extra ! ones on the last processor if (rank == n_procs - 1) then - count = count - send_to_right + index_local = index_local - send_to_right end if elseif (total < n_particles) then @@ -237,8 +235,8 @@ contains ! fission bank sites_needed = n_particles - total do i = 1, int(sites_needed,4) - count = count + 1 - temp_sites(count) = fission_bank(n_bank - sites_needed + i) + index_local = index_local + 1 + temp_sites(index_local) = fission_bank(n_bank - sites_needed + i) end do end if @@ -259,7 +257,7 @@ contains allocate(right_bank(abs(send_to_right))) if (send_to_right > 0) then - i = count - send_to_right + 1 + i = index_local - send_to_right + 1 call MPI_ISEND(temp_sites(i), send_to_right, MPI_BANK, rank+1, 0, & & MPI_COMM_WORLD, request, ierr) else if (send_to_right < 0) then @@ -285,27 +283,27 @@ contains ! ========================================================================== ! RECONSTRUCT SOURCE BANK if (send_to_left < 0 .and. send_to_right >= 0) then - i = -send_to_left ! size of first block - j = int(count,4) - send_to_right ! size of second block + i = -send_to_left ! size of first block + j = int(index_local,4) - send_to_right ! size of second block call copy_from_bank(temp_sites, i+1, j) #ifdef MPI call MPI_WAIT(request_left, status, ierr) #endif call copy_from_bank(left_bank, 1, i) else if (send_to_left >= 0 .and. send_to_right < 0) then - i = int(count,4) - send_to_left ! size of first block - j = -send_to_right ! size of second block + i = int(index_local,4) - send_to_left ! size of first block + j = -send_to_right ! size of second block call copy_from_bank(temp_sites(1+send_to_left), 1, i) #ifdef MPI call MPI_WAIT(request_right, status, ierr) #endif call copy_from_bank(right_bank, i+1, j) else if (send_to_left >= 0 .and. send_to_right >= 0) then - i = int(count,4) - send_to_left - send_to_right + i = int(index_local,4) - send_to_left - send_to_right call copy_from_bank(temp_sites(1+send_to_left), 1, i) else if (send_to_left < 0 .and. send_to_right < 0) then i = -send_to_left - j = int(count,4) + j = int(index_local,4) k = -send_to_right call copy_from_bank(temp_sites, i+1, j) #ifdef MPI @@ -336,19 +334,19 @@ contains ! COPY_FROM_BANK !=============================================================================== - subroutine copy_from_bank(temp_bank, index, n_sites) + subroutine copy_from_bank(temp_bank, i_start, n_sites) integer, intent(in) :: n_sites ! # of bank sites to copy type(Bank), intent(in) :: temp_bank(n_sites) - integer, intent(in) :: index ! starting index in source_bank + integer, intent(in) :: i_start ! starting index in source_bank - integer :: i ! index in temp_bank - integer :: index_source ! index in source_bank + integer :: i ! index in temp_bank + integer :: i_source ! index in source_bank type(Particle), pointer :: p do i = 1, n_sites - index_source = index + i - 1 - p => source_bank(index_source) + i_source = i_start + i - 1 + p => source_bank(i_source) p % xyz = temp_bank(i) % xyz p % xyz_local = temp_bank(i) % xyz @@ -374,7 +372,7 @@ contains integer :: i integer :: n integer :: m - integer :: count + integer :: n_bins integer :: ierr real(8), allocatable :: tally_temp(:,:) type(TallyObject), pointer :: t @@ -384,7 +382,7 @@ contains n = t % n_total_bins m = t % n_macro_bins - count = n*m + n_bins = n*m allocate(tally_temp(n,m)) @@ -392,14 +390,14 @@ contains if (master) then ! Description of MPI_IN_PLANE - call MPI_REDUCE(MPI_IN_PLACE, tally_temp, count, MPI_REAL8, MPI_SUM, & + call MPI_REDUCE(MPI_IN_PLACE, tally_temp, n_bins, MPI_REAL8, MPI_SUM, & 0, MPI_COMM_WORLD, ierr) ! Transfer values to val_history on master t % scores(:,:) % val_history = tally_temp else ! Receive buffer not significant at other processors - call MPI_REDUCE(tally_temp, tally_temp, count, MPI_REAL8, MPI_SUM, & + call MPI_REDUCE(tally_temp, tally_temp, n_bins, MPI_REAL8, MPI_SUM, & 0, MPI_COMM_WORLD, ierr) ! Reset val_history on other processors diff --git a/src/output.f90 b/src/output.f90 index 79fed2480..860559593 100644 --- a/src/output.f90 +++ b/src/output.f90 @@ -27,8 +27,8 @@ contains subroutine title() - character(10) :: date - character(8) :: time + character(10) :: today_date + character(8) :: today_time write(ou,*) write(ou,*) ' .d88888b. 888b d888 .d8888b.' @@ -51,8 +51,8 @@ contains 100 format (6X,"Version:",9X,I1,".",I1,".",I1) ! Write the date and time - call get_today(date, time) - write(ou,101) trim(date), trim(time) + call get_today(today_date, today_time) + write(ou,101) trim(today_date), trim(today_time) 101 format (6X,"Date/Time:",7X,A,1X,A) write(ou,*) @@ -187,11 +187,11 @@ contains character(8), intent(out) :: today_time integer :: val(8) - character(8) :: date - character(10) :: time + character(8) :: date_ + character(10) :: time_ character(5) :: zone - call date_and_time(date, time, zone, val) + call date_and_time(date_, time_, zone, val) ! val(1) = year (YYYY) ! val(2) = month (MM) ! val(3) = day (DD) @@ -203,18 +203,18 @@ contains if (val(2) < 10) then if (val(3) < 10) then - today_date = date(6:6) // "/" // date(8:8) // "/" // date(1:4) + today_date = date_(6:6) // "/" // date_(8:8) // "/" // date_(1:4) else - today_date = date(6:6) // "/" // date(7:8) // "/" // date(1:4) + today_date = date_(6:6) // "/" // date_(7:8) // "/" // date_(1:4) end if else if (val(3) < 10) then - today_date = date(5:6) // "/" // date(8:8) // "/" // date(1:4) + today_date = date_(5:6) // "/" // date_(8:8) // "/" // date_(1:4) else - today_date = date(5:6) // "/" // date(7:8) // "/" // date(1:4) + today_date = date_(5:6) // "/" // date_(7:8) // "/" // date_(1:4) end if end if - today_time = time(1:2) // ":" // time(3:4) // ":" // time(5:6) + today_time = time_(1:2) // ":" // time_(3:4) // ":" // time_(5:6) end subroutine get_today diff --git a/src/search.f90 b/src/search.f90 index dd9b02c7f..67e8c8e2b 100644 --- a/src/search.f90 +++ b/src/search.f90 @@ -11,12 +11,12 @@ contains ! value lies in the array. This is used extensively for energy grid searching !=============================================================================== - function binary_search(array, n, val) result(index) + function binary_search(array, n, val) result(array_index) integer, intent(in) :: n real(8), intent(in) :: array(n) real(8), intent(in) :: val - integer :: index + integer :: array_index integer :: L integer :: R @@ -34,41 +34,25 @@ contains ! Check boundaries if (val > array(L) .and. val < array(L+1)) then - index = L + array_index = L return elseif (val > array(R-1) .and. val < array(R)) then - index = R-1 + array_index = R - 1 return end if ! Find values at midpoint - index = L + (R - L)/2 - testval = array(index) + array_index = L + (R - L)/2 + testval = array(array_index) if (val > testval) then - L = index + L = array_index elseif (val < testval) then - R = index + R = array_index end if end do - index = L + array_index = L end function binary_search -!=============================================================================== -! INTERPOLATE -!=============================================================================== - - function interpolate(array, n, index, f) result(val) - - integer, intent(in) :: n - real(8), intent(in) :: array(n) - integer, intent(in) :: index - real(8), intent(in) :: f - real(8) :: val - - val = (ONE-f) * array(index) + f * array(index+1) - - end function interpolate - end module search diff --git a/src/string.f90 b/src/string.f90 index e3ed5f11a..839abdea3 100644 --- a/src/string.f90 +++ b/src/string.f90 @@ -28,7 +28,7 @@ contains character(*), intent(out) :: words(MAX_WORDS) integer, intent(out) :: n - character(1) :: char ! current character + character(1) :: chr ! current character integer :: i ! current index integer :: i_start ! starting index of word integer :: i_end ! ending index of word @@ -37,14 +37,14 @@ contains i_end = 0 n = 0 do i = 1, len_trim(string) - char = string(i:i) + chr = string(i:i) ! Note that ACHAR(9) is a horizontal tab - if ((i_start == 0) .and. (char /= ' ') .and. (char /= achar(9))) then + if ((i_start == 0) .and. (chr /= ' ') .and. (chr /= achar(9))) then i_start = i end if if (i_start > 0) then - if ((char == ' ') .or. (char == achar(9))) i_end = i - 1 + if ((chr == ' ') .or. (chr == achar(9))) i_end = i - 1 if (i == len_trim(string)) i_end = i if (i_end > 0) then n = n + 1 @@ -80,7 +80,7 @@ contains character(*), intent(out) :: words(MAX_WORDS) integer, intent(out) :: n - character(1) :: char ! current character + character(1) :: chr ! current character integer :: i ! current index integer :: i_start ! starting index of word integer :: i_end ! ending index of word @@ -89,27 +89,27 @@ contains i_end = 0 n = 0 do i = 1, len_trim(string) - char = string(i:i) + chr = string(i:i) ! Check for special characters - if (index('():#', char) > 0) then + if (index('():#', chr) > 0) then if (i_start > 0) then i_end = i - 1 n = n + 1 words(n) = string(i_start:i_end) end if n = n + 1 - words(n) = char + words(n) = chr i_start = 0 i_end = 0 cycle end if - if ((i_start == 0) .and. (char /= ' ')) then + if ((i_start == 0) .and. (chr /= ' ')) then i_start = i end if if (i_start > 0) then - if (char == ' ') i_end = i - 1 + if (chr == ' ') i_end = i - 1 if (i == len_trim(string)) i_end = i if (i_end > 0) then n = n + 1 diff --git a/src/tally.f90 b/src/tally.f90 index 464a35739..034261940 100644 --- a/src/tally.f90 +++ b/src/tally.f90 @@ -97,7 +97,7 @@ contains integer :: i ! loop index for tallies integer :: j ! loop index for filter arrays - integer :: index ! filter bin entries + integer :: i_item ! filter bin entries integer :: n ! number of bins integer :: filter_bins ! running total of number of filter bins integer :: score_bins ! number of scoring bins @@ -193,8 +193,8 @@ contains t % stride(T_SURFACE) = filter_bins if (n > 0) then do j = 1, n - index = t % surface_bins(j) % scalar - call add_map_element(tally_maps(T_SURFACE) % items(index), i, j) + i_item = t % surface_bins(j) % scalar + call add_map_element(tally_maps(T_SURFACE) % items(i_item), i, j) end do filter_bins = filter_bins * n end if @@ -204,8 +204,8 @@ contains t % stride(T_CELLBORN) = filter_bins if (n > 0) then do j = 1, n - index = t % cellborn_bins(j) % scalar - call add_map_element(tally_maps(T_CELLBORN) % items(index), i, j) + i_item = t % cellborn_bins(j) % scalar + call add_map_element(tally_maps(T_CELLBORN) % items(i_item), i, j) end do filter_bins = filter_bins * n end if @@ -215,8 +215,8 @@ contains t % stride(T_CELL) = filter_bins if (n > 0) then do j = 1, n - index = t % cell_bins(j) % scalar - call add_map_element(tally_maps(T_CELL) % items(index), i, j) + i_item = t % cell_bins(j) % scalar + call add_map_element(tally_maps(T_CELL) % items(i_item), i, j) end do filter_bins = filter_bins * n end if @@ -226,8 +226,8 @@ contains t % stride(T_MATERIAL) = filter_bins if (n > 0) then do j = 1, n - index = t % material_bins(j) % scalar - call add_map_element(tally_maps(T_MATERIAL) % items(index), i, j) + i_item = t % material_bins(j) % scalar + call add_map_element(tally_maps(T_MATERIAL) % items(i_item), i, j) end do filter_bins = filter_bins * n end if @@ -237,8 +237,8 @@ contains t % stride(T_UNIVERSE) = filter_bins if (n > 0) then do j = 1, n - index = t % universe_bins(j) % scalar - call add_map_element(tally_maps(T_UNIVERSE) % items(index), i, j) + i_item = t % universe_bins(j) % scalar + call add_map_element(tally_maps(T_UNIVERSE) % items(i_item), i, j) end do filter_bins = filter_bins * n end if @@ -1303,7 +1303,7 @@ contains integer, intent(in) :: bin ! bin in filter array character(30) :: label ! user-specified identifier - integer :: index ! index in cells/surfaces/etc array + integer :: i ! index in cells/surfaces/etc array integer, allocatable :: ijk(:) ! indices in mesh real(8) :: E0 ! lower bound for energy bin real(8) :: E1 ! upper bound for energy bin @@ -1311,20 +1311,20 @@ contains select case(filter_type) case (T_UNIVERSE) - index = t % universe_bins(bin) % scalar - label = int_to_str(universes(index) % id) + i = t % universe_bins(bin) % scalar + label = int_to_str(universes(i) % id) case (T_MATERIAL) - index = t % material_bins(bin) % scalar - label = int_to_str(materials(index) % id) + i = t % material_bins(bin) % scalar + label = int_to_str(materials(i) % id) case (T_CELL) - index = t % cell_bins(bin) % scalar - label = int_to_str(cells(index) % id) + i = t % cell_bins(bin) % scalar + label = int_to_str(cells(i) % id) case (T_CELLBORN) - index = t % cellborn_bins(bin) % scalar - label = int_to_str(cells(index) % id) + i = t % cellborn_bins(bin) % scalar + label = int_to_str(cells(i) % id) case (T_SURFACE) - index = t % surface_bins(bin) % scalar - label = int_to_str(surfaces(index) % id) + i = t % surface_bins(bin) % scalar + label = int_to_str(surfaces(i) % id) case (T_MESH) m => meshes(t % mesh) allocate(ijk(m % n_dimension)) From 4ffd4bd1606ba6ae2dc5afdb0d45decb6eb506eb Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 21 Nov 2011 11:25:07 -0800 Subject: [PATCH 17/70] Changed more variables to non-intrinsic names. --- src/cross_section.f90 | 130 +++++++++++----------- src/initialize.f90 | 58 +++++----- src/physics.f90 | 252 +++++++++++++++++++++--------------------- 3 files changed, 220 insertions(+), 220 deletions(-) diff --git a/src/cross_section.f90 b/src/cross_section.f90 index 99c356422..271e412d9 100644 --- a/src/cross_section.f90 +++ b/src/cross_section.f90 @@ -210,10 +210,10 @@ contains ! subroutines to parse the actual data. !=============================================================================== - subroutine read_ace_table(index_table, index) + subroutine read_ace_table(index_table, index_list) integer, intent(in) :: index_table ! index in nuclides/sab_tables - integer, intent(in) :: index ! index in xs_listings + integer, intent(in) :: index_list ! index in xs_listings integer :: i ! loop index for XSS records integer :: j, j1, j2 ! indices in XSS @@ -230,7 +230,7 @@ contains logical :: file_exists ! does ACE library exist? character(7) :: readable ! is ACE library readable? character(10) :: name ! name of ACE table - character(10) :: date ! date ACE library was processed + character(10) :: date_ ! date ACE library was processed character(10) :: mat ! material identifier character(70) :: comment ! comment for ACE table character(MAX_FILE_LEN) :: filename ! path to ACE cross section library @@ -239,7 +239,7 @@ contains type(XsListing), pointer :: listing => null() ! determine path, record length, and location of table - listing => xs_listings(index) + listing => xs_listings(index_list) filename = listing % path record_length = listing % recl location = listing % location @@ -273,7 +273,7 @@ contains end do ! Read first line of header - read(UNIT=in, FMT='(A10,2E12.0,1X,A10)') name, awr, kT, date + read(UNIT=in, FMT='(A10,2E12.0,1X,A10)') name, awr, kT, date_ ! Read more header and NXS and JXS read(UNIT=in, FMT=100) comment, mat, & @@ -296,7 +296,7 @@ contains ACCESS='direct', RECL=record_length) ! Read all header information - read(UNIT=in, REC=location) name, awr, kT, date, & + read(UNIT=in, REC=location) name, awr, kT, date_, & comment, mat, (zaids(i), awrs(i), i=1,16), NXS, JXS ! determine table length @@ -414,7 +414,7 @@ contains integer :: LED ! location of energy distribution locators integer :: LDIS ! location of all energy distributions integer :: LOCC ! location of energy distributions for given MT - integer :: loc ! locator + integer :: lc ! locator integer :: length ! length of data to allocate type(DistEnergy), pointer :: edist => null() @@ -562,10 +562,10 @@ contains ! determine length of all precursor constants/yields/interp data length = 0 - loc = JXS(25) + lc = JXS(25) do i = 1, NPCR - NR = int(XSS(loc + length + 1)) - NE = int(XSS(loc + length + 2 + 2*NR)) + NR = int(XSS(lc + length + 1)) + NE = int(XSS(lc + length + 2 + 2*NR)) length = length + 3 + 2*NR + 2*NE end do @@ -573,7 +573,7 @@ contains allocate(nuc % nu_d_precursor_data(length)) ! read delayed neutron precursor data - XSS_index = loc + XSS_index = lc nuc % nu_d_precursor_data = get_real(length) else @@ -839,7 +839,7 @@ contains integer :: NR ! number of interpolation regions integer :: NE ! number of incoming energies integer :: IDAT ! location of first energy distribution for given MT - integer :: loc ! locator + integer :: lc ! locator integer :: length ! length of data to allocate integer :: length_interp_data ! length of interpolation data @@ -885,16 +885,16 @@ contains edist % p_valid % y = get_real(NE) ! Set index to beginning of IDAT array - loc = LDIS + IDAT - 2 + lc = LDIS + IDAT - 2 ! determine length of energy distribution - length = length_energy_dist(loc, LAW, loc_law, length_interp_data) + length = length_energy_dist(lc, LAW, loc_law, length_interp_data) ! allocate secondary energy distribution array allocate(edist % data(length)) ! read secondary energy distribution - XSS_index = loc + 1 + XSS_index = lc + 1 edist % data = get_real(length) ! read next energy distribution if present @@ -910,9 +910,9 @@ contains ! distribution array based on the secondary energy law and location in XSS !=============================================================================== - function length_energy_dist(loc, law, LOCC, lid) result(length) + function length_energy_dist(lc, law, LOCC, lid) result(length) - integer, intent(in) :: loc ! location in XSS array + integer, intent(in) :: lc ! location in XSS array integer, intent(in) :: law ! energy distribution law integer, intent(in) :: LOCC ! location of energy distribution integer, intent(in) :: lid ! length of interpolation data @@ -934,9 +934,9 @@ contains select case (law) case (1) ! Tabular equiprobable energy bins - NR = int(XSS(loc + 1)) - NE = int(XSS(loc + 2 + 2*NR)) - NP = int(XSS(loc + 3 + 2*NR + NE)) + NR = int(XSS(lc + 1)) + NE = int(XSS(lc + 2 + 2*NR)) + NP = int(XSS(lc + 3 + 2*NR + NE)) length = 3 + 2*NR + NE + 3*NP*NE case (2) @@ -949,72 +949,72 @@ contains case (4) ! Continuous tabular distribution - NR = int(XSS(loc + 1)) - NE = int(XSS(loc + 2 + 2*NR)) + NR = int(XSS(lc + 1)) + NE = int(XSS(lc + 2 + 2*NR)) length = length + 2 + 2*NR + 2*NE do i = 1,NE ! determine length - NP = int(XSS(loc + length + 2)) + NP = int(XSS(lc + length + 2)) length = length + 2 + 3*NP ! adjust location for this block - j = loc + 2 + 2*NR + NE + i + j = lc + 2 + 2*NR + NE + i XSS(j) = XSS(j) - LOCC - lid end do case (5) ! General evaporation spectrum - NR = int(XSS(loc + 1)) - NE = int(XSS(loc + 2 + 2*NR)) - NP = int(XSS(loc + 3 + 2*NR + 2*NE)) + NR = int(XSS(lc + 1)) + NE = int(XSS(lc + 2 + 2*NR)) + NP = int(XSS(lc + 3 + 2*NR + 2*NE)) length = 3 + 2*NR + 2*NE + NP case (7) ! Maxwell fission spectrum - NR = int(XSS(loc + 1)) - NE = int(XSS(loc + 2 + 2*NR)) + NR = int(XSS(lc + 1)) + NE = int(XSS(lc + 2 + 2*NR)) length = 3 + 2*NR + 2*NE case (9) ! Evaporation spectrum - NR = int(XSS(loc + 1)) - NE = int(XSS(loc + 2 + 2*NR)) + NR = int(XSS(lc + 1)) + NE = int(XSS(lc + 2 + 2*NR)) length = 3 + 2*NR + 2*NE case (11) ! Watt spectrum - NRa = int(XSS(loc + 1)) - NEa = int(XSS(loc + 2 + 2*NRa)) - NRb = int(XSS(loc + 3 + 2*(NRa+NEa))) - NEb = int(XSS(loc + 4 + 2*(NRa+NEa+NRb))) + NRa = int(XSS(lc + 1)) + NEa = int(XSS(lc + 2 + 2*NRa)) + NRb = int(XSS(lc + 3 + 2*(NRa+NEa))) + NEb = int(XSS(lc + 4 + 2*(NRa+NEa+NRb))) length = 5 + 2*(NRa + NEa + NRb + NEb) case (44) ! Kalbach-Mann correlated scattering - NR = int(XSS(loc + 1)) - NE = int(XSS(loc + 2 + 2*NR)) + NR = int(XSS(lc + 1)) + NE = int(XSS(lc + 2 + 2*NR)) length = length + 2 + 2*NR + 2*NE do i = 1,NE - NP = int(XSS(loc + length + 2)) + NP = int(XSS(lc + length + 2)) length = length + 2 + 5*NP ! adjust location for this block - j = loc + 2 + 2*NR + NE + i + j = lc + 2 + 2*NR + NE + i XSS(j) = XSS(j) - LOCC - lid end do case (61) ! Correlated energy and angle distribution - NR = int(XSS(loc + 1)) - NE = int(XSS(loc + 2 + 2*NR)) + NR = int(XSS(lc + 1)) + NE = int(XSS(lc + 2 + 2*NR)) length = length + 2 + 2*NR + 2*NE do i = 1,NE ! outgoing energy distribution - NP = int(XSS(loc + length + 2)) + NP = int(XSS(lc + length + 2)) ! adjust locators for angular distribution do j = 1, NP - k = loc + length + 2 + 3*NP + j + k = lc + length + 2 + 3*NP + j if (XSS(k) /= 0) XSS(k) = XSS(k) - LOCC - lid end do @@ -1022,12 +1022,12 @@ contains do j = 1, NP ! outgoing angle distribution -- NMU here is actually ! referred to as NP in the MCNP documentation - NMU = int(XSS(loc + length + 2)) + NMU = int(XSS(lc + length + 2)) length = length + 2 + 3*NMU end do ! adjust locators for energy distribution - j = loc + 2 + 2*NR + NE + i + j = lc + 2 + 2*NR + NE + i XSS(j) = XSS(j) - LOCC - lid end do @@ -1037,9 +1037,9 @@ contains case (67) ! Laboratory energy-angle law - NR = int(XSS(loc + 1)) - NE = int(XSS(loc + 2 + 2*NR)) - NMU = int(XSS(loc + 4 + 2*NR + 2*NE)) + NR = int(XSS(lc + 1)) + NE = int(XSS(lc + 2 + 2*NR)) + NMU = int(XSS(lc + 4 + 2*NR + 2*NE)) length = 4 + 2*(NR + NE + NMU) end select @@ -1055,7 +1055,7 @@ contains type(Nuclide), pointer :: nuc integer :: JXS23 ! location of URR data - integer :: loc ! locator + integer :: lc ! locator integer :: N ! # of incident energies integer :: M ! # of probabilities integer :: i ! index over incoming energies @@ -1070,19 +1070,19 @@ contains nuc % urr_present = .true. allocate(nuc % urr_data) allocate(nuc % urr_data % params(6)) - loc = JXS23 + lc = JXS23 else nuc % urr_present = .false. return end if ! read parameters - nuc % urr_data % params(1) = int(XSS(loc)) ! # of incident energies - nuc % urr_data % params(2) = int(XSS(loc + 1)) ! # of probabilities - nuc % urr_data % params(3) = int(XSS(loc + 2)) ! interpolation parameter - nuc % urr_data % params(4) = int(XSS(loc + 3)) ! inelastic competition flag - nuc % urr_data % params(5) = int(XSS(loc + 4)) ! other absorption flag - nuc % urr_data % params(6) = int(XSS(loc + 5)) ! factors flag + nuc % urr_data % params(1) = int(XSS(lc)) ! # of incident energies + nuc % urr_data % params(2) = int(XSS(lc + 1)) ! # of probabilities + nuc % urr_data % params(3) = int(XSS(lc + 2)) ! interpolation parameter + nuc % urr_data % params(4) = int(XSS(lc + 3)) ! inelastic competition flag + nuc % urr_data % params(5) = int(XSS(lc + 4)) ! other absorption flag + nuc % urr_data % params(6) = int(XSS(lc + 5)) ! factors flag ! allocate incident energies and probability tables N = nuc % urr_data % params(1) @@ -1091,7 +1091,7 @@ contains allocate(nuc % urr_data % prob(N,6,M)) ! read incident energies - XSS_index = loc + 6 + XSS_index = lc + 6 nuc % urr_data % energy = get_real(N) ! read probability tables @@ -1120,7 +1120,7 @@ contains integer :: i ! index for incoming energies integer :: j ! index for outgoing energies integer :: k ! index for outoging angles - integer :: loc ! location in XSS array + integer :: lc ! location in XSS array integer :: NE_in ! number of incoming energies integer :: NE_out ! number of outgoing energies integer :: NMU ! number of outgoing angles @@ -1153,19 +1153,19 @@ contains allocate(table % inelastic_mu(NMU, NE_out, NE_in)) ! read outgoing energy/angle distribution for inelastic scattering - loc = JXS(3) - 1 + lc = JXS(3) - 1 do i = 1, NE_in do j = 1, NE_out ! read outgoing energy - table % inelastic_e_out(j,i) = XSS(loc + 1) + table % inelastic_e_out(j,i) = XSS(lc + 1) ! read outgoing angles for this outgoing energy do k = 1, NMU - table % inelastic_mu(k,j,i) = XSS(loc + 1 + k) + table % inelastic_mu(k,j,i) = XSS(lc + 1 + k) end do ! advance pointer - loc = loc + 1 + NMU + lc = lc + 1 + NMU end do end do @@ -1202,12 +1202,12 @@ contains ! read equiprobable outgoing cosines for elastic scattering each ! incoming energy if (JXS4 /= 0 .and. NMU /= 0) then - loc = JXS(6) - 1 + lc = JXS(6) - 1 do i = 1, NE_in do j = 1, NMU - table % elastic_mu(j,i) = XSS(loc + j) + table % elastic_mu(j,i) = XSS(lc + j) end do - loc = loc + NMU + lc = lc + NMU end do end if diff --git a/src/initialize.f90 b/src/initialize.f90 index bd181da2e..0a0250f87 100644 --- a/src/initialize.f90 +++ b/src/initialize.f90 @@ -197,9 +197,9 @@ contains subroutine prepare_universes() - integer :: i ! index in cells array - integer :: index ! index in universes array - integer :: count ! number of cells in a universe + integer :: i ! index in cells array + integer :: i_univ ! index in universes array + integer :: n_cells_in_univ ! number of cells in a universe integer, allocatable :: index_cell_in_univ(:) ! the index in the univ%cells ! array for each universe type(ListKeyValueII), pointer :: key_list => null() @@ -216,19 +216,19 @@ contains key_list => dict_keys(universe_dict) do while (associated(key_list)) ! find index of universe in universes array - index = key_list%data%value - univ => universes(index) + i_univ = key_list%data%value + univ => universes(i_univ) univ % id = key_list%data%key ! check for lowest level universe - if (univ % id == 0) BASE_UNIVERSE = index + if (univ % id == 0) BASE_UNIVERSE = i_univ ! find cell count for this universe - count = dict_get_key(cells_in_univ_dict, key_list%data%key) + n_cells_in_univ = dict_get_key(cells_in_univ_dict, key_list%data%key) ! allocate cell list for universe - allocate(univ % cells(count)) - univ % n_cells = count + allocate(univ % cells(n_cells_in_univ)) + univ % n_cells = n_cells_in_univ ! move to next universe key_list => key_list%next @@ -244,13 +244,13 @@ contains c => cells(i) ! get pointer to corresponding universe - index = dict_get_key(universe_dict, c % universe) - univ => universes(index) + i_univ = dict_get_key(universe_dict, c % universe) + univ => universes(i_univ) ! increment the index for the cells array within the Universe object and ! then store the index of the Cell object in that array - index_cell_in_univ(index) = index_cell_in_univ(index) + 1 - univ % cells(index_cell_in_univ(index)) = i + index_cell_in_univ(i_univ) = index_cell_in_univ(i_univ) + 1 + univ % cells(index_cell_in_univ(i_univ)) = i end do end subroutine prepare_universes @@ -268,7 +268,7 @@ contains integer :: i ! index in cells array integer :: j ! index over surface list integer :: k - integer :: index ! index in surfaces/materials array + integer :: i_array ! index in surfaces/materials array integer :: id ! user-specified id type(Cell), pointer :: c => null() type(Lattice), pointer :: l => null() @@ -283,8 +283,8 @@ contains id = c % surfaces(j) if (id < OP_DIFFERENCE) then if (dict_has_key(surface_dict, abs(id))) then - index = dict_get_key(surface_dict, abs(id)) - c % surfaces(j) = sign(index, id) + i_array = dict_get_key(surface_dict, abs(id)) + c % surfaces(j) = sign(i_array, id) else message = "Could not find surface " // trim(int_to_str(abs(id))) // & & " specified on cell " // trim(int_to_str(c % id)) @@ -464,9 +464,9 @@ contains integer, intent(in) :: parent ! cell containing universe integer, intent(in) :: level ! level of universe - integer :: i ! index for cells in universe - integer :: x,y ! indices for lattice positions - integer :: index ! index in cells array + integer :: i ! index for cells in universe + integer :: x,y ! indices for lattice positions + integer :: i_cell ! index in cells array integer :: universe_num type(Cell), pointer :: c => null() type(Universe), pointer :: subuniverse => null() @@ -478,15 +478,15 @@ contains ! loop over all cells in the universe do i = 1, univ % n_cells - index = univ % cells(i) - c => cells(index) + i_cell = univ % cells(i) + c => cells(i_cell) c%parent = parent ! if this cell is filled with another universe, recursively ! call this subroutine if (c % type == CELL_FILL) then subuniverse => universes(c % fill) - call build_universe(subuniverse, index, level + 1) + call build_universe(subuniverse, i_cell, level + 1) end if ! if this cell is filled by a lattice, need to build the @@ -503,7 +503,7 @@ contains call dict_add_key(dict, universe_num, 0) subuniverse => universes(universe_num) - call build_universe(subuniverse, index, level + 1) + call build_universe(subuniverse, i_cell, level + 1) end if end do end do @@ -519,7 +519,7 @@ contains subroutine normalize_ao() - integer :: index ! index used for several purposes + integer :: index_list ! index in xs_listings array integer :: i ! index in materials array integer :: j ! index over nuclides in material integer :: n ! length of string @@ -562,8 +562,8 @@ contains end if if (dict_has_key(xs_listing_dict, key)) then - index = dict_get_key(xs_listing_dict, key) - mat % xs_listing(j) = index + index_list = dict_get_key(xs_listing_dict, key) + mat % xs_listing(j) = index_list else message = "Cannot find cross-section " // trim(key) // & " in specified cross_sections.xml file." @@ -571,7 +571,7 @@ contains end if ! determine atomic weight ratio - awr = xs_listings(index) % awr + awr = xs_listings(index_list) % awr ! if given weight percent, convert all values so that they are divided ! by awr. thus, when a sum is done over the values, it's actually @@ -592,8 +592,8 @@ contains if (.not. density_in_atom) then sum_percent = ZERO do j = 1, mat % n_nuclides - index = mat % xs_listing(j) - awr = xs_listings(index) % awr + index_list = mat % xs_listing(j) + awr = xs_listings(index_list) % awr x = mat % atom_percent(j) sum_percent = sum_percent + x*awr end do diff --git a/src/physics.f90 b/src/physics.f90 index 65bcc3a0a..7e9fed018 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -1009,7 +1009,7 @@ contains integer :: i ! loop index integer :: j ! index on nu energy grid / precursor group - integer :: loc ! index before start of energies/nu values + integer :: lc ! index before start of energies/nu values integer :: NR ! number of interpolation regions integer :: NE ! number of energies tabulated integer :: nu ! actual number of neutrons produced @@ -1091,23 +1091,23 @@ contains ! sampled delayed precursor group xi = prn() - loc = 1 + lc = 1 prob = ZERO do j = 1, nuc % n_precursor ! determine number of interpolation regions and energies - NR = int(nuc % nu_d_precursor_data(loc + 1)) - NE = int(nuc % nu_d_precursor_data(loc + 2 + 2*NR)) + NR = int(nuc % nu_d_precursor_data(lc + 1)) + NE = int(nuc % nu_d_precursor_data(lc + 2 + 2*NR)) ! determine delayed neutron precursor yield for group j yield = interpolate_tab1(nuc % nu_d_precursor_data( & - loc+1:loc+2+2*NR+2*NE), E) + lc+1:lc+2+2*NR+2*NE), E) ! Check if this group is sampled prob = prob + yield if (xi < prob) exit ! advance pointer - loc = loc + 2 + 2*NR + 2*NE + 1 + lc = lc + 2 + 2*NR + 2*NE + 1 end do ! sample from energy distribution for group j @@ -1250,7 +1250,7 @@ contains integer :: type ! angular distribution type integer :: i ! incoming energy bin integer :: n ! number of incoming energy bins - integer :: loc ! location in data array + integer :: lc ! location in data array integer :: NP ! number of points in cos distribution integer :: k ! index on cosine grid real(8) :: r ! interpolation factor on incoming energy @@ -1290,7 +1290,7 @@ contains if (r > prn()) i = i + 1 ! check whether this is a 32-equiprobable bin or a tabular distribution - loc = rxn % adist % location(i) + lc = rxn % adist % location(i) type = rxn % adist % type(i) if (type == ANGLE_ISOTROPIC) then mu = TWO * prn() - ONE @@ -1300,26 +1300,26 @@ contains k = 1 + int(32.0_8*xi) ! calculate cosine - mu0 = rxn % adist % data(loc + k) - mu1 = rxn % adist % data(loc + k+1) + mu0 = rxn % adist % data(lc + k) + mu1 = rxn % adist % data(lc + k+1) mu = mu0 + (32.0_8 * xi - k) * (mu1 - mu0) elseif (type == ANGLE_TABULAR) then - interp = int(rxn % adist % data(loc + 1)) - NP = int(rxn % adist % data(loc + 2)) + interp = int(rxn % adist % data(lc + 1)) + NP = int(rxn % adist % data(lc + 2)) ! determine outgoing cosine bin xi = prn() - loc = loc + 2 - c_k = rxn % adist % data(loc + 2*NP + 1) + lc = lc + 2 + c_k = rxn % adist % data(lc + 2*NP + 1) do k = 1, NP-1 - c_k1 = rxn % adist % data(loc + 2*NP + k+1) + c_k1 = rxn % adist % data(lc + 2*NP + k+1) if (xi < c_k1) exit c_k = c_k1 end do - p0 = rxn % adist % data(loc + NP + k) - mu0 = rxn % adist % data(loc + k) + p0 = rxn % adist % data(lc + NP + k) + mu0 = rxn % adist % data(lc + k) if (interp == HISTOGRAM) then ! Histogram interpolation mu = mu0 + (xi - c_k)/p0 @@ -1327,8 +1327,8 @@ contains elseif (interp == LINEAR_LINEAR) then ! Linear-linear interpolation -- not sure how you come about the ! formula given in the MCNP manual - p1 = rxn % adist % data(loc + NP + k+1) - mu1 = rxn % adist % data(loc + k+1) + p1 = rxn % adist % data(lc + NP + k+1) + mu1 = rxn % adist % data(lc + k+1) frac = (p1 - p0)/(mu1 - mu0) if (frac == ZERO) then @@ -1418,7 +1418,7 @@ contains integer :: i ! index on incoming energy grid integer :: k ! sampled index on outgoing grid integer :: l ! sampled index on incoming grid - integer :: loc ! dummy index + integer :: lc ! dummy index integer :: NR ! number of interpolation regions integer :: NE ! number of energies integer :: NET ! number of outgoing energies @@ -1500,23 +1500,23 @@ contains end if ! determine index on incoming energy grid and interpolation factor - loc = 2 + 2*NR - i = binary_search(edist % data(loc+1), NE, E_in) - r = (E_in - edist%data(loc+i)) / & - & (edist%data(loc+i+1) - edist%data(loc+i)) + lc = 2 + 2*NR + i = binary_search(edist % data(lc+1), NE, E_in) + r = (E_in - edist%data(lc+i)) / & + & (edist%data(lc+i+1) - edist%data(lc+i)) ! Sample outgoing energy bin r1 = prn() k = 1 + int(NET * r1) ! Determine E_1 and E_K - loc = 3 + 3*NR + NE + (i-1)*NET - E_i_1 = edist % data(loc + 1) - E_i_K = edist % data(loc + NET) + lc = 3 + 3*NR + NE + (i-1)*NET + E_i_1 = edist % data(lc + 1) + E_i_K = edist % data(lc + NET) - loc = 3 + 3*NR + NE + i*NET - E_i1_1 = edist % data(loc + 1) - E_i1_K = edist % data(loc + NET) + lc = 3 + 3*NR + NE + i*NET + E_i1_1 = edist % data(lc + 1) + E_i1_K = edist % data(lc + NET) E_1 = E_i_1 + r*(E_i1_1 - E_i_1) E_K = E_i_K + r*(E_i1_K - E_i_K) @@ -1530,9 +1530,9 @@ contains end if ! Determine E_l_k and E_l_k+1 - loc = 3 + 2*NR + NE + (l-1)*NET - E_l_k = edist % data(loc+k) - E_l_k1 = edist % data(loc+k+1) + lc = 3 + 2*NR + NE + (l-1)*NET + E_l_k = edist % data(lc+k) + E_l_k1 = edist % data(lc+k+1) ! Determine E' (denoted here as E_out) r2 = prn() @@ -1569,17 +1569,17 @@ contains ! find energy bin and calculate interpolation factor -- if the energy is ! outside the range of the tabulated energies, choose the first or last ! bins - loc = 2 + 2*NR - if (E_in < edist % data(loc+1)) then + lc = 2 + 2*NR + if (E_in < edist % data(lc+1)) then i = 1 r = ZERO - elseif (E_in > edist % data(loc+NE)) then + elseif (E_in > edist % data(lc+NE)) then i = NE - 1 r = ONE else - i = binary_search(edist % data(loc+1), NE, E_in) - r = (E_in - edist%data(loc+i)) / & - & (edist%data(loc+i+1) - edist%data(loc+i)) + i = binary_search(edist % data(lc+1), NE, E_in) + r = (E_in - edist%data(lc+i)) / & + & (edist%data(lc+i+1) - edist%data(lc+i)) end if ! Sample between the ith and (i+1)th bin @@ -1591,25 +1591,25 @@ contains end if ! interpolation for energy E1 and EK - loc = int(edist%data(2 + 2*NR + NE + i)) - NP = int(edist%data(loc + 2)) - E_i_1 = edist%data(loc + 2 + 1) - E_i_K = edist%data(loc + 2 + NP) + lc = int(edist%data(2 + 2*NR + NE + i)) + NP = int(edist%data(lc + 2)) + E_i_1 = edist%data(lc + 2 + 1) + E_i_K = edist%data(lc + 2 + NP) - loc = int(edist%data(2 + 2*NR + NE + i + 1)) - NP = int(edist%data(loc + 2)) - E_i1_1 = edist%data(loc + 2 + 1) - E_i1_K = edist%data(loc + 2 + NP) + lc = int(edist%data(2 + 2*NR + NE + i + 1)) + NP = int(edist%data(lc + 2)) + E_i1_1 = edist%data(lc + 2 + 1) + E_i1_K = edist%data(lc + 2 + NP) E_1 = E_i_1 + r*(E_i1_1 - E_i_1) E_K = E_i_K + r*(E_i1_K - E_i_K) ! determine location of outgoing energies, pdf, cdf for E(l) - loc = int(edist % data(2 + 2*NR + NE + l)) + lc = int(edist % data(2 + 2*NR + NE + l)) ! determine type of interpolation and number of discrete lines - INTTp = int(edist % data(loc + 1)) - NP = int(edist % data(loc + 2)) + INTTp = int(edist % data(lc + 1)) + NP = int(edist % data(lc + 2)) if (INTTp > 10) then INTT = mod(INTTp,10) ND = (INTTp - INTT)/10 @@ -1627,16 +1627,16 @@ contains ! determine outgoing energy bin r1 = prn() - loc = loc + 2 ! start of EOUT - c_k = edist % data(loc + 2*NP + 1) + lc = lc + 2 ! start of EOUT + c_k = edist % data(lc + 2*NP + 1) do k = 1, NP-1 - c_k1 = edist % data(loc + 2*NP + k+1) + c_k1 = edist % data(lc + 2*NP + k+1) if (r1 < c_k1) exit c_k = c_k1 end do - E_l_k = edist % data(loc+k) - p_l_k = edist % data(loc+NP+k) + E_l_k = edist % data(lc+k) + p_l_k = edist % data(lc+NP+k) if (INTT == HISTOGRAM) then ! Histogram interpolation E_out = E_l_k + (r1 - c_k)/p_l_k @@ -1644,8 +1644,8 @@ contains elseif (INTT == LINEAR_LINEAR) then ! Linear-linear interpolation -- not sure how you come about the ! formula given in the MCNP manual - E_l_k1 = edist % data(loc+k+1) - p_l_k1 = edist % data(loc+NP+k+1) + E_l_k1 = edist % data(lc+k+1) + p_l_k1 = edist % data(lc+NP+k+1) frac = (p_l_k1 - p_l_k)/(E_l_k1 - E_l_k) if (frac == ZERO) then @@ -1694,8 +1694,8 @@ contains T = interpolate_tab1(edist % data, E_in) ! determine restriction energy - loc = 2 + 2*NR + 2*NE - U = edist % data(loc + 1) + lc = 2 + 2*NR + 2*NE + U = edist % data(lc + 1) ! sample outgoing energy based on evaporation spectrum probability ! density function @@ -1719,8 +1719,8 @@ contains Watt_a = interpolate_tab1(edist % data, E_in) ! determine Watt parameter 'b' from tabulated function - loc = 3 + 2*(NR + NE) - Watt_b = interpolate_tab1(edist % data, E_in, loc) + lc = 3 + 2*(NR + NE) + Watt_b = interpolate_tab1(edist % data, E_in, lc) ! Sample energy-dependent Watt fission spectrum E_out = watt_spectrum(Watt_a, Watt_b) @@ -1748,17 +1748,17 @@ contains ! find energy bin and calculate interpolation factor -- if the energy is ! outside the range of the tabulated energies, choose the first or last ! bins - loc = 2 + 2*NR - if (E_in < edist % data(loc+1)) then + lc = 2 + 2*NR + if (E_in < edist % data(lc+1)) then i = 1 r = ZERO - elseif (E_in > edist % data(loc+NE)) then + elseif (E_in > edist % data(lc+NE)) then i = NE - 1 r = ONE else - i = binary_search(edist % data(loc+1), NE, E_in) - r = (E_in - edist%data(loc+i)) / & - & (edist%data(loc+i+1) - edist%data(loc+i)) + i = binary_search(edist % data(lc+1), NE, E_in) + r = (E_in - edist%data(lc+i)) / & + & (edist%data(lc+i+1) - edist%data(lc+i)) end if ! Sample between the ith and (i+1)th bin @@ -1770,26 +1770,26 @@ contains end if ! determine endpoints on grid i - loc = int(edist%data(2+2*NR+NE + i)) ! start of LDAT for i - NP = int(edist%data(loc + 2)) - E_i_1 = edist%data(loc + 2 + 1) - E_i_K = edist%data(loc + 2 + NP) + lc = int(edist%data(2+2*NR+NE + i)) ! start of LDAT for i + NP = int(edist%data(lc + 2)) + E_i_1 = edist%data(lc + 2 + 1) + E_i_K = edist%data(lc + 2 + NP) ! determine endpoints on grid i+1 - loc = int(edist%data(2+2*NR+NE + i+1)) ! start of LDAT for i+1 - NP = int(edist%data(loc + 2)) - E_i1_1 = edist%data(loc + 2 + 1) - E_i1_K = edist%data(loc + 2 + NP) + lc = int(edist%data(2+2*NR+NE + i+1)) ! start of LDAT for i+1 + NP = int(edist%data(lc + 2)) + E_i1_1 = edist%data(lc + 2 + 1) + E_i1_K = edist%data(lc + 2 + NP) E_1 = E_i_1 + r*(E_i1_1 - E_i_1) E_K = E_i_K + r*(E_i1_K - E_i_K) ! determine location of outgoing energies, pdf, cdf for E(l) - loc = int(edist % data(2 + 2*NR + NE + l)) + lc = int(edist % data(2 + 2*NR + NE + l)) ! determine type of interpolation and number of discrete lines - INTTp = int(edist % data(loc + 1)) - NP = int(edist % data(loc + 2)) + INTTp = int(edist % data(lc + 1)) + NP = int(edist % data(lc + 2)) if (INTTp > 10) then INTT = mod(INTTp,10) ND = (INTTp - INTT)/10 @@ -1807,29 +1807,29 @@ contains ! determine outgoing energy bin r1 = prn() - loc = loc + 2 ! start of EOUT - c_k = edist % data(loc + 2*NP + 1) + lc = lc + 2 ! start of EOUT + c_k = edist % data(lc + 2*NP + 1) do k = 1, NP-1 - c_k1 = edist % data(loc + 2*NP + k+1) + c_k1 = edist % data(lc + 2*NP + k+1) if (r1 < c_k1) exit c_k = c_k1 end do - E_l_k = edist % data(loc+k) - p_l_k = edist % data(loc+NP+k) + E_l_k = edist % data(lc+k) + p_l_k = edist % data(lc+NP+k) if (INTT == HISTOGRAM) then ! Histogram interpolation E_out = E_l_k + (r1 - c_k)/p_l_k ! Determine Kalbach-Mann parameters - KM_R = edist % data(loc + 3*NP + k) - KM_A = edist % data(loc + 4*NP + k) + KM_R = edist % data(lc + 3*NP + k) + KM_A = edist % data(lc + 4*NP + k) elseif (INTT == LINEAR_LINEAR) then ! Linear-linear interpolation -- not sure how you come about the ! formula given in the MCNP manual - E_l_k1 = edist % data(loc+k+1) - p_l_k1 = edist % data(loc+NP+k+1) + E_l_k1 = edist % data(lc+k+1) + p_l_k1 = edist % data(lc+NP+k+1) ! Find E prime frac = (p_l_k1 - p_l_k)/(E_l_k1 - E_l_k) @@ -1841,10 +1841,10 @@ contains end if ! Determine Kalbach-Mann parameters - R_k = edist % data(loc + 3*NP + k) - R_k1 = edist % data(loc + 3*NP + k+1) - A_k = edist % data(loc + 4*NP + k) - A_k1 = edist % data(loc + 4*NP + k+1) + R_k = edist % data(lc + 3*NP + k) + R_k1 = edist % data(lc + 3*NP + k+1) + A_k = edist % data(lc + 4*NP + k) + A_k1 = edist % data(lc + 4*NP + k+1) KM_R = R_k + (R_k1 - R_k)*(E_out - E_l_k)/(E_l_k1 - E_l_k) KM_A = A_k + (A_k1 - A_k)*(E_out - E_l_k)/(E_l_k1 - E_l_k) @@ -1891,17 +1891,17 @@ contains ! find energy bin and calculate interpolation factor -- if the energy is ! outside the range of the tabulated energies, choose the first or last ! bins - loc = 2 + 2*NR - if (E_in < edist % data(loc+1)) then + lc = 2 + 2*NR + if (E_in < edist % data(lc+1)) then i = 1 r = ZERO - elseif (E_in > edist % data(loc+NE)) then + elseif (E_in > edist % data(lc+NE)) then i = NE - 1 r = ONE else - i = binary_search(edist % data(loc+1), NE, E_in) - r = (E_in - edist%data(loc+i)) / & - & (edist%data(loc+i+1) - edist%data(loc+i)) + i = binary_search(edist % data(lc+1), NE, E_in) + r = (E_in - edist%data(lc+i)) / & + & (edist%data(lc+i+1) - edist%data(lc+i)) end if ! Sample between the ith and (i+1)th bin @@ -1913,26 +1913,26 @@ contains end if ! determine endpoints on grid i - loc = int(edist%data(2+2*NR+NE + i)) ! start of LDAT for i - NP = int(edist%data(loc + 2)) - E_i_1 = edist%data(loc + 2 + 1) - E_i_K = edist%data(loc + 2 + NP) + lc = int(edist%data(2+2*NR+NE + i)) ! start of LDAT for i + NP = int(edist%data(lc + 2)) + E_i_1 = edist%data(lc + 2 + 1) + E_i_K = edist%data(lc + 2 + NP) ! determine endpoints on grid i+1 - loc = int(edist%data(2+2*NR+NE + i+1)) ! start of LDAT for i+1 - NP = int(edist%data(loc + 2)) - E_i1_1 = edist%data(loc + 2 + 1) - E_i1_K = edist%data(loc + 2 + NP) + lc = int(edist%data(2+2*NR+NE + i+1)) ! start of LDAT for i+1 + NP = int(edist%data(lc + 2)) + E_i1_1 = edist%data(lc + 2 + 1) + E_i1_K = edist%data(lc + 2 + NP) E_1 = E_i_1 + r*(E_i1_1 - E_i_1) E_K = E_i_K + r*(E_i1_K - E_i_K) ! determine location of outgoing energies, pdf, cdf for E(l) - loc = int(edist % data(2 + 2*NR + NE + l)) + lc = int(edist % data(2 + 2*NR + NE + l)) ! determine type of interpolation and number of discrete lines - INTTp = int(edist % data(loc + 1)) - NP = int(edist % data(loc + 2)) + INTTp = int(edist % data(lc + 1)) + NP = int(edist % data(lc + 2)) if (INTTp > 10) then INTT = mod(INTTp,10) ND = (INTTp - INTT)/10 @@ -1950,16 +1950,16 @@ contains ! determine outgoing energy bin r1 = prn() - loc = loc + 2 ! start of EOUT - c_k = edist % data(loc + 2*NP + 1) + lc = lc + 2 ! start of EOUT + c_k = edist % data(lc + 2*NP + 1) do k = 1, NP-1 - c_k1 = edist % data(loc + 2*NP + k+1) + c_k1 = edist % data(lc + 2*NP + k+1) if (r1 < c_k1) exit c_k = c_k1 end do - E_l_k = edist % data(loc+k) - p_l_k = edist % data(loc+NP+k) + E_l_k = edist % data(lc+k) + p_l_k = edist % data(lc+NP+k) if (INTT == HISTOGRAM) then ! Histogram interpolation E_out = E_l_k + (r1 - c_k)/p_l_k @@ -1967,8 +1967,8 @@ contains elseif (INTT == LINEAR_LINEAR) then ! Linear-linear interpolation -- not sure how you come about the ! formula given in the MCNP manual - E_l_k1 = edist % data(loc+k+1) - p_l_k1 = edist % data(loc+NP+k+1) + E_l_k1 = edist % data(lc+k+1) + p_l_k1 = edist % data(lc+NP+k+1) ! Find E prime frac = (p_l_k1 - p_l_k)/(E_l_k1 - E_l_k) @@ -1991,30 +1991,30 @@ contains end if ! Find location of correlated angular distribution - loc = int(edist % data(loc+3*NP+k)) + lc = int(edist % data(lc+3*NP+k)) ! Check if angular distribution is isotropic - if (loc == 0) then + if (lc == 0) then mu_out = TWO * prn() - ONE return end if ! interpolation type and number of points in angular distribution - JJ = int(edist % data(loc + 1)) - NP = int(edist % data(loc + 2)) + JJ = int(edist % data(lc + 1)) + NP = int(edist % data(lc + 2)) ! determine outgoing cosine bin r3 = prn() - loc = loc + 2 - c_k = edist % data(loc + 2*NP + 1) + lc = lc + 2 + c_k = edist % data(lc + 2*NP + 1) do k = 1, NP-1 - c_k1 = edist % data(loc + 2*NP + k+1) + c_k1 = edist % data(lc + 2*NP + k+1) if (r3 < c_k1) exit c_k = c_k1 end do - p_k = edist % data(loc + NP + k) - mu_k = edist % data(loc + k) + p_k = edist % data(lc + NP + k) + mu_k = edist % data(lc + k) if (JJ == HISTOGRAM) then ! Histogram interpolation mu_out = mu_k + (r3 - c_k)/p_k @@ -2022,8 +2022,8 @@ contains elseif (JJ == LINEAR_LINEAR) then ! Linear-linear interpolation -- not sure how you come about the ! formula given in the MCNP manual - p_k1 = edist % data(loc + NP + k+1) - mu_k1 = edist % data(loc + k+1) + p_k1 = edist % data(lc + NP + k+1) + mu_k1 = edist % data(lc + k+1) frac = (p_k1 - p_k)/(mu_k1 - mu_k) if (frac == ZERO) then From bf1bbb984534091602eaccb8f58ba6d0bd459306 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 21 Nov 2011 14:36:24 -0500 Subject: [PATCH 18/70] Updated Makefile for ORNL Jaguar. --- src/Makefile.jaguar | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/src/Makefile.jaguar b/src/Makefile.jaguar index aad96ca66..bf2d839c1 100644 --- a/src/Makefile.jaguar +++ b/src/Makefile.jaguar @@ -1,5 +1,10 @@ program = openmc +templates = $(wildcard xml-fortran/templates/*.o) +xml_fort = xml-fortran/xmlparse.o \ + xml-fortran/read_xml_primitives.o \ + xml-fortran/write_xml_primitives.o + #=============================================================================== # Object Files #=============================================================================== @@ -33,16 +38,22 @@ ifeq ($(PROFILE),yes) endif ifeq ($(OPTIMIZE),yes) - F90FLAGS += -ipo -O3 + F90FLAGS += -O3 endif #=============================================================================== # Targets #=============================================================================== -all: $(program) +all: xml-fortran $(program) +xml-fortran: + cd xml-fortran; make F90=$(F90) F90FLAGS="$(F90FLAGS)" + cd xml-fortran/templates; make F90=$(F90) F90FLAGS="$(F90FLAGS)" $(program): $(objects) - $(F90) $(objects) -o $@ $(LDFLAGS) + $(F90) $(objects) $(templates) $(xml_fort) -o $@ $(LDFLAGS) +distclean: clean + cd xml-fortran; make clean + cd xml-fortran/templates; make clean clean: @rm -f *.o *.mod $(program) neat: @@ -53,10 +64,10 @@ neat: #=============================================================================== .SUFFIXES: .f90 .o -.PHONY: all clean neat +.PHONY: all xml-fortran clean neat distclean %.o: %.f90 - $(F90) $(F90FLAGS) -c $< + $(F90) -Ixml-fortran -Ixml-fortran/templates $(F90FLAGS) -c $< #=============================================================================== # Dependencies From 59532bb00f9d4a73b22ee2a87c8019d8e8f236cd Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sun, 27 Nov 2011 22:55:29 -0500 Subject: [PATCH 19/70] Small change to nu-fission analog tallies. --- src/tally.f90 | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/tally.f90 b/src/tally.f90 index 034261940..b4fe31cc9 100644 --- a/src/tally.f90 +++ b/src/tally.f90 @@ -515,6 +515,13 @@ contains bin_energyout = bins(T_ENERGYOUT) score_index0 = score_index + ! 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. + + score = keff + ! loop over number of particles banked do k = 1, p % n_bank ! determine outgoing energy from fission bank @@ -526,14 +533,6 @@ contains ! determine scoring index score_index = sum((bins - 1) * t % stride) + 1 - ! 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. - - score = keff - ! Add score to tally call add_to_score(t % scores(score_index, j), score) end do From 3eb8c69a158c4294597d806dcf78439c17cdb36e Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sun, 27 Nov 2011 22:59:46 -0500 Subject: [PATCH 20/70] Changed printing of spaces in write_tallies. --- src/tally.f90 | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/tally.f90 b/src/tally.f90 index b4fe31cc9..152cf403c 100644 --- a/src/tally.f90 +++ b/src/tally.f90 @@ -982,10 +982,9 @@ contains integer :: score_index ! index in scores array for filters logical :: file_exists ! does tallies.out file already exists? logical :: has_filter(TALLY_TYPES) ! does tally have this filter? - character(MAX_LINE_LEN) :: filename ! name of output file + character(MAX_FILE_LEN) :: filename ! name of output file character(15) :: filter_name(TALLY_TYPES) ! names of tally filters character(27) :: macro_name(N_MACRO_TYPES) ! names of macro scores - character(80) :: space = " " ! spaces type(TallyObject), pointer :: t ! Skip if there are no tallies @@ -1091,7 +1090,7 @@ contains else if (has_filter(j)) then ! Print current filter information - write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A)') space(1:indent), & + write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A)') repeat(" ", indent), & trim(filter_name(j)), trim(get_label(t, j, bins(j))) indent = indent + 2 end if @@ -1102,7 +1101,7 @@ contains end do find_bin ! Print filter information - write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A)') space(1:indent), & + write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A)') repeat(" ", indent), & trim(filter_name(j)), trim(get_label(t, j, bins(j))) ! Determine scoring index for this bin combination -- note that unlike @@ -1115,7 +1114,7 @@ contains indent = indent + 2 do k = 1, t % n_macro_bins write(UNIT=UNIT_TALLY, FMT='(1X,2A,1X,A,"+/- ",A)') & - space(1:indent), macro_name(abs(t % macro_bins(k) % scalar)), & + repeat(" ", indent), macro_name(abs(t % macro_bins(k) % scalar)), & real_to_str(t % scores(score_index,k) % val), & trim(real_to_str(t % scores(score_index,k) % val_sq)) end do From b4ed68158fbded2c0858422644e41cd62c375ea9 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sun, 27 Nov 2011 23:50:29 -0500 Subject: [PATCH 21/70] Updated convert_xsdir.py to add alias. --- cross_sections.xml | 2076 ++++++++++++++++++++++++++++++++++++ src/utils/convert_xsdir.py | 45 +- 2 files changed, 2113 insertions(+), 8 deletions(-) create mode 100644 cross_sections.xml diff --git a/cross_sections.xml b/cross_sections.xml new file mode 100644 index 000000000..180021064 --- /dev/null +++ b/cross_sections.xml @@ -0,0 +1,2076 @@ + + + + /opt/mcnp/data + + + binary + + + 4096 + + + 512 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/utils/convert_xsdir.py b/src/utils/convert_xsdir.py index 912dd2b2f..b7a1ae22f 100755 --- a/src/utils/convert_xsdir.py +++ b/src/utils/convert_xsdir.py @@ -4,6 +4,18 @@ import os import sys from xml.dom.minidom import getDOMImplementation +elements = [None, "H", "He", "Li", "Be", "B", "C", "N", "O", "F", "Ne", "Na", + "Mg", "Al", "Si", "P", "S", "Cl", "Ar", "K", "Ca", "Sc", "Ti", "V", + "Cr", "Mn", "Fe", "Co", "Ni", "Cu", "Zn", "Ga", "Ge", "As", "Se", + "Br", "Kr", "Rb", "Sr", "Y", "Zr", "Nb", "Mo", "Tc", "Ru", "Rh", + "Pd", "Ag", "Cd", "In", "Sn", "Sb", "Te", "I", "Xe", "Cs", "Ba", + "La", "Ce", "Pr", "Nd", "Pm", "Sm", "Eu", "Gd", "Tb", "Dy", "Ho", + "Er", "Tm", "Yb", "Lu", "Hf", "Ta", "W", "Re", "Os", "Ir", "Pt", + "Au", "Hg", "Tl", "Pb", "Bi", "Po", "At", "Rn", "Fr", "Ra", "Ac", + "Th", "Pa", "U", "Np", "Pu", "Am", "Cm", "Bk", "Cf", "Es", "Fm", + "Md", "No", "Lr", "Rf", "Db", "Sg", "Bh", "Hs", "Mt", "Ds", "Rg", + "Cn"] + class Xsdir(object): def __init__(self, filename): @@ -192,11 +204,30 @@ class XsdirTable(object): # All other cases A = int(self.zaid) % 1000 - if A > 600: + if A > 300: return 1 else: return 0 + @property + def alias(self): + zaid = self.zaid + Z = int(zaid[:-3]) + A = zaid[-3:] + + if A == '000': + s = 'Nat' + elif zaid == '95242': + s = '242m' + elif zaid == '95642': + s = '242' + elif int(A) > 300: + s = str(int(A) - 400) + "m" + else: + s = str(int(A)) + + return "{0}-{1}.{2}".format(elements[Z], s, self.xs) + @property def zaid(self): if self.name.endswith('c'): @@ -204,19 +235,17 @@ class XsdirTable(object): else: return 0 + @property + def xs(self): + return self.name[self.name.find('.')+1:] + def to_xml_node(self, doc): node = doc.createElement("ace_table") node.setAttribute("name", self.name) for attribute in ["alias", "zaid", "type", "metastable", "awr", "temperature", "path", "location"]: if hasattr(self, attribute): - # Join string for alias attribute - if attribute == "alias": - if not self.alias: - continue - string = " ".join(self.alias) - else: - string = str(getattr(self,attribute)) + string = str(getattr(self,attribute)) # Skip metastable and binary if 0 if attribute == "metastable" and self.metastable == 0: From d37f8f31afeeffa73d8e96f6ef79d8537c1db798 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 28 Nov 2011 09:48:00 -0500 Subject: [PATCH 22/70] Changed name/alias for XsListing to 12 characters to allow for aliases. --- src/cross_section.f90 | 4 ++-- src/cross_section_header.f90 | 4 ++-- src/energy_grid.f90 | 4 ++-- src/initialize.f90 | 2 +- src/input_xml.f90 | 2 +- src/material_header.f90 | 4 ++-- src/xml-fortran/templates/materials_t.xml | 2 +- 7 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/cross_section.f90 b/src/cross_section.f90 index 271e412d9..48998170a 100644 --- a/src/cross_section.f90 +++ b/src/cross_section.f90 @@ -42,8 +42,8 @@ contains integer :: index_list ! index in xs_listings array integer :: index_nuclides ! index in nuclides integer :: index_sab ! index in sab_tables - character(10) :: name ! name of isotope, e.g. 92235.03c - character(10) :: alias ! alias of nuclide, e.g. U-235.03c + character(12) :: name ! name of isotope, e.g. 92235.03c + character(12) :: alias ! alias of nuclide, e.g. U-235.03c type(Material), pointer :: mat => null() type(Nuclide), pointer :: nuc => null() type(SAB_Table), pointer :: sab => null() diff --git a/src/cross_section_header.f90 b/src/cross_section_header.f90 index e630ce772..2f3116062 100644 --- a/src/cross_section_header.f90 +++ b/src/cross_section_header.f90 @@ -154,8 +154,8 @@ module cross_section_header !=============================================================================== type XsListing - character(10) :: name ! table name, e.g. 92235.70c - character(10) :: alias ! table alias, e.g. U-235.70c + character(12) :: name ! table name, e.g. 92235.70c + character(12) :: alias ! table alias, e.g. U-235.70c integer :: type ! type of table (cont-E neutron, S(A,b), etc) integer :: zaid ! ZAID identifier = 1000*Z + A integer :: filetype ! ASCII or BINARY diff --git a/src/energy_grid.f90 b/src/energy_grid.f90 index 25adf1af2..d2351c94c 100644 --- a/src/energy_grid.f90 +++ b/src/energy_grid.f90 @@ -23,8 +23,8 @@ contains integer :: i ! index in materials array integer :: j ! index over nuclides in material integer :: index_list ! index in xs_listings array - character(10) :: name ! name of isotope, e.g. 92235.03c - character(10) :: alias ! alias of nuclide, e.g. U-235.03c + character(12) :: name ! name of isotope, e.g. 92235.03c + character(12) :: alias ! alias of nuclide, e.g. U-235.03c type(ListReal), pointer :: list => null() type(ListReal), pointer :: current => null() type(Material), pointer :: mat => null() diff --git a/src/initialize.f90 b/src/initialize.f90 index 0a0250f87..5c1d6a2be 100644 --- a/src/initialize.f90 +++ b/src/initialize.f90 @@ -528,7 +528,7 @@ contains real(8) :: x ! atom percent logical :: percent_in_atom ! nuclides specified in atom percent? logical :: density_in_atom ! density specified in atom/b-cm? - character(10) :: key ! name of nuclide, e.g. 92235.03c + character(12) :: key ! name of nuclide, e.g. 92235.03c type(Material), pointer :: mat => null() ! first find the index in the xs_listings array for each nuclide in each diff --git a/src/input_xml.f90 b/src/input_xml.f90 index 4009aa54d..a698fbd37 100644 --- a/src/input_xml.f90 +++ b/src/input_xml.f90 @@ -425,7 +425,7 @@ contains logical :: file_exists character(3) :: default_xs character(MAX_WORD_LEN) :: units - character(10) :: name + character(12) :: name character(MAX_LINE_LEN) :: filename type(Material), pointer :: m => null() type(nuclide_xml), pointer :: nuc => null() diff --git a/src/material_header.f90 b/src/material_header.f90 index ac77394d7..916578923 100644 --- a/src/material_header.f90 +++ b/src/material_header.f90 @@ -9,7 +9,7 @@ module material_header type Material integer :: id ! unique identifier integer :: n_nuclides ! number of nuclides - character(10), allocatable :: names(:) ! isotope names + character(12), allocatable :: names(:) ! isotope names integer, allocatable :: xs_listing(:) ! index in xs_listings list integer, allocatable :: nuclide(:) ! index in nuclides array real(8) :: density ! total atom density in atom/b-cm @@ -18,7 +18,7 @@ module material_header ! S(a,b) data references logical :: has_sab_table = .false. - character(10) :: sab_name ! name of S(a,b) table + character(12) :: sab_name ! name of S(a,b) table integer :: sab_table = 0 ! index in sab_tables integer :: sab_nuclide = 0 ! index of nuclide which has S(a,b) table end type Material diff --git a/src/xml-fortran/templates/materials_t.xml b/src/xml-fortran/templates/materials_t.xml index 36207aa78..5e5a0ee41 100644 --- a/src/xml-fortran/templates/materials_t.xml +++ b/src/xml-fortran/templates/materials_t.xml @@ -15,7 +15,7 @@ - + From c60589a3163d5b35b9dba908e1f9a867fd9baf0e Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Tue, 29 Nov 2011 11:00:55 -0500 Subject: [PATCH 23/70] Added STAT check on allocation of source and fission bank. --- src/DEPENDENCIES | 4 +++- src/source.f90 | 25 ++++++++++++++++++++++--- 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/src/DEPENDENCIES b/src/DEPENDENCIES index 9e526688a..53e65bfa2 100644 --- a/src/DEPENDENCIES +++ b/src/DEPENDENCIES @@ -170,11 +170,13 @@ search.o: global.o source.o: bank_header.o source.o: constants.o source.o: cross_section_header.o +source.o: error.o source.o: global.o source.o: output.o -source.o: random_lcg.o source.o: particle_header.o source.o: physics.o +source.o: random_lcg.o +source.o: string.o string.o: constants.o string.o: error.o diff --git a/src/source.f90 b/src/source.f90 index 30e60da35..f91679593 100644 --- a/src/source.f90 +++ b/src/source.f90 @@ -3,11 +3,13 @@ module source use bank_header, only: Bank use constants, only: ONE, MAX_LINE_LEN use cross_section_header, only: Nuclide + use error, only: fatal_error use global use output, only: write_message use particle_header, only: Particle, initialize_particle use physics, only: watt_spectrum use random_lcg, only: prn, set_particle_seed + use string, only: int_to_str implicit none @@ -24,12 +26,15 @@ contains integer(8) :: j ! loop index over bank sites integer :: k ! dummy loop index integer(8) :: maxwork ! maxinum # of particles per processor + integer :: alloc_err ! allocation error code + integer(8) :: bytes ! size of fission/source bank real(8) :: r(3) ! sampled coordinates real(8) :: phi ! azimuthal angle real(8) :: mu ! cosine of polar angle real(8) :: E ! outgoing energy real(8) :: p_min(3) ! minimum coordinates of source real(8) :: p_max(3) ! maximum coordinates of source + type(Bank) :: bank_obj message = "Initializing source particles..." call write_message(6) @@ -37,9 +42,23 @@ contains ! Determine maximum amount of particles to simulate on each processor maxwork = ceiling(real(n_particles)/n_procs,8) - ! Allocate fission and source banks - allocate(source_bank(maxwork)) - allocate(fission_bank(3*maxwork)) + ! Allocate source bank + allocate(source_bank(maxwork), STAT=alloc_err) + if (alloc_err /= 0) then + bytes = maxwork * storage_size(bank_obj) / 8 + message = "Could not allocate source bank. Attempted to allocate " & + // trim(int_to_str(bytes)) // " bytes." + call fatal_error() + end if + + ! Allocate fission bank + allocate(fission_bank(3*maxwork), STAT=alloc_err) + if (alloc_err /= 0) then + bytes = 3 * maxwork * storage_size(bank_obj) / 8 + message = "Could not allocate fission bank. Attempted to allocate " & + // trim(int_to_str(bytes)) // " bytes." + call fatal_error() + end if ! Check external source type if (external_source%type == SRC_BOX) then From bf889922cb214a93eb7f382522b2134f0aa9441c Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Tue, 29 Nov 2011 13:24:11 -0500 Subject: [PATCH 24/70] Added check for particle undergoing too many events. --- src/constants.f90 | 3 +++ src/physics.f90 | 15 ++++++++++++++- 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/src/constants.f90 b/src/constants.f90 index a1ee88cf8..9e63c6c40 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -73,6 +73,9 @@ module constants ! Used for surface current tallies real(8), parameter :: TINY_BIT = 1e-8 + ! Maximum number of collisions/crossings + integer, parameter :: MAX_EVENTS = 10000 + ! Codes for read errors -- better hope these numbers are never used in an ! input file! integer, parameter :: ERROR_INT = -huge(0) diff --git a/src/physics.f90 b/src/physics.f90 index 7e9fed018..9ce663ed8 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -31,6 +31,7 @@ contains integer :: surf ! surface which particle is on integer :: last_cell ! most recent cell particle was in + integer :: n_event ! number of collisions/crossings real(8) :: d_to_boundary ! distance to nearest boundary real(8) :: d_to_collision ! sampled distance to collision real(8) :: distance ! distance particle travels @@ -63,6 +64,9 @@ contains call write_message() end if + ! Initialize number of events to zero + n_event = 0 + ! find energy index, interpolation factor do while (p % alive) @@ -100,7 +104,16 @@ contains ! Save coordinates at collision for tallying purposes p % last_xyz = p % xyz end if - + + ! If particle has too many events, display warning and kill it + n_event = n_event + 1 + if (n_event == MAX_EVENTS) then + message = "Particle " // trim(int_to_str(p%id)) // " underwent " & + // "maximum number of events." + call warning() + p % alive = .false. + end if + end do end subroutine transport From ef0284ffc016e4dd0182148dde5f8d0cd7397c51 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Tue, 29 Nov 2011 13:53:50 -0500 Subject: [PATCH 25/70] Incorporated Jaguar options into main Makefile. --- src/Makefile | 10 ++++++ src/Makefile.jaguar | 76 --------------------------------------------- 2 files changed, 10 insertions(+), 76 deletions(-) delete mode 100644 src/Makefile.jaguar diff --git a/src/Makefile b/src/Makefile index f93c54f05..31ffa5ac5 100644 --- a/src/Makefile +++ b/src/Makefile @@ -118,6 +118,16 @@ ifeq ($(USE_MPI),yes) F90FLAGS += -DMPI endif +#=============================================================================== +# Special options for ORNL Jaguar supercomputer +#=============================================================================== + +HOSTNAME = $(shell hostname) +ifneq (,$(findstring jaguar,$(HOSTNAME))) + F90 = ftn + F90FLAGS += -DMPI +endif + #=============================================================================== # Targets #=============================================================================== diff --git a/src/Makefile.jaguar b/src/Makefile.jaguar deleted file mode 100644 index bf2d839c1..000000000 --- a/src/Makefile.jaguar +++ /dev/null @@ -1,76 +0,0 @@ -program = openmc - -templates = $(wildcard xml-fortran/templates/*.o) -xml_fort = xml-fortran/xmlparse.o \ - xml-fortran/read_xml_primitives.o \ - xml-fortran/write_xml_primitives.o - -#=============================================================================== -# Object Files -#=============================================================================== - -include OBJECTS - -#=============================================================================== -# User Options -#=============================================================================== - -DEBUG = no -PROFILE = no -OPTIMIZE = no - -#=============================================================================== -# Compiler Options -#=============================================================================== - -F90 = ftn -F90FLAGS = -cpp -DMPI -LDFLAGS = - -ifeq ($(DEBUG),yes) - F90FLAGS += -g -traceback -ftrapuv -fp-stack-check -check all - LDFLAGS += -g -endif - -ifeq ($(PROFILE),yes) - F90FLAGS += -pg - LDFLAGS += -pg -endif - -ifeq ($(OPTIMIZE),yes) - F90FLAGS += -O3 -endif - -#=============================================================================== -# Targets -#=============================================================================== - -all: xml-fortran $(program) -xml-fortran: - cd xml-fortran; make F90=$(F90) F90FLAGS="$(F90FLAGS)" - cd xml-fortran/templates; make F90=$(F90) F90FLAGS="$(F90FLAGS)" -$(program): $(objects) - $(F90) $(objects) $(templates) $(xml_fort) -o $@ $(LDFLAGS) -distclean: clean - cd xml-fortran; make clean - cd xml-fortran/templates; make clean -clean: - @rm -f *.o *.mod $(program) -neat: - @rm -f *.o *.mod - -#=============================================================================== -# Rules -#=============================================================================== - -.SUFFIXES: .f90 .o -.PHONY: all xml-fortran clean neat distclean - -%.o: %.f90 - $(F90) -Ixml-fortran -Ixml-fortran/templates $(F90FLAGS) -c $< - -#=============================================================================== -# Dependencies -#=============================================================================== - -include DEPENDENCIES From 8e541ab8ed0b59a9b6919db6b7aba544605f004d Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Tue, 29 Nov 2011 14:44:08 -0500 Subject: [PATCH 26/70] Added Cray compiler option in Makefile. --- src/Makefile | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/Makefile b/src/Makefile index 31ffa5ac5..c56418fa2 100644 --- a/src/Makefile +++ b/src/Makefile @@ -106,6 +106,21 @@ ifeq ($(COMPILER),pgi) endif endif +#=============================================================================== +# Cray compiler options +#=============================================================================== + +ifeq ($(COMPILER),cray) + F90 = ftn + F90FLAGS := -e Z -m 0 + + # Debugging options + ifeq ($(DEBUG),yes) + F90FLAGS += -g -R abcnsp -O0 + LDFLAGS += -g + endif +endif + #=============================================================================== # Miscellaneous compiler options #=============================================================================== From 627870fec8fbe04f269022b1a73b8fe60e393507 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Tue, 29 Nov 2011 15:03:07 -0500 Subject: [PATCH 27/70] Added check for too many resamplings or rejections. --- src/constants.f90 | 1 + src/physics.f90 | 34 +++++++++++++++++++++++++++++++++- 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/src/constants.f90 b/src/constants.f90 index 9e63c6c40..1592fccfd 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -75,6 +75,7 @@ module constants ! Maximum number of collisions/crossings integer, parameter :: MAX_EVENTS = 10000 + integer, parameter :: MAX_SAMPLE = 100000 ! Codes for read errors -- better hope these numbers are never used in an ! input file! diff --git a/src/physics.f90 b/src/physics.f90 index 9ce663ed8..6d0759397 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -1027,6 +1027,7 @@ contains integer :: NE ! number of energies tabulated integer :: nu ! actual number of neutrons produced integer :: law ! energy distribution law + integer :: n_sample ! number of times resampling real(8) :: E ! incoming energy of neutron real(8) :: E_out ! outgoing energy of fission neutron real(8) :: nu_t ! total nu @@ -1123,17 +1124,29 @@ contains lc = lc + 2 + 2*NR + 2*NE + 1 end do - ! sample from energy distribution for group j + ! select energy distribution for group j law = nuc % nu_d_edist(j) % law edist => nuc % nu_d_edist(j) + + ! sample from energy distribution + n_sample = 0 do if (law == 44 .or. law == 61) then call sample_energy(edist, E, E_out, mu) else call sample_energy(edist, E, E_out) end if + ! resample if energy is >= 20 MeV if (E_out < 20) exit + + ! check for large number of resamples + n_sample = n_sample + 1 + if (n_sample == MAX_SAMPLE) then + message = "Resampled energy distribution maximum number of " // & + "times for nuclide " // nuc % name + call fatal_error() + end if end do else @@ -1142,14 +1155,24 @@ contains ! sample from prompt neutron energy distribution law = rxn % edist % law + n_sample = 0 do if (law == 44 .or. law == 61) then call sample_energy(rxn%edist, E, E_out, prob) else call sample_energy(rxn%edist, E, E_out) end if + ! resample if energy is >= 20 MeV if (E_out < 20) exit + + ! check for large number of resamples + n_sample = n_sample + 1 + if (n_sample == MAX_SAMPLE) then + message = "Resampled energy distribution maximum number of " // & + "times for nuclide " // nuc % name + call fatal_error() + end if end do end if @@ -1431,6 +1454,7 @@ contains integer :: i ! index on incoming energy grid integer :: k ! sampled index on outgoing grid integer :: l ! sampled index on incoming grid + integer :: n_sample ! number of rejections integer :: lc ! dummy index integer :: NR ! number of interpolation regions integer :: NE ! number of energies @@ -1712,11 +1736,19 @@ contains ! sample outgoing energy based on evaporation spectrum probability ! density function + n_sample = 0 do r1 = prn() r2 = prn() E_out = -T * log(r1*r2) if (E_out <= E_in - U) exit + + ! check for large number of rejections + n_sample = n_sample + 1 + if (n_sample == MAX_SAMPLE) then + message = "Too many rejections on evaporation spectrum." + call fatal_error() + end if end do case (11) From 68d229dbf801fb35d6c9b1ddacbe9a3d1dac04be Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Tue, 29 Nov 2011 15:16:29 -0500 Subject: [PATCH 28/70] Added restriction energy constraint on sampling Maxwell fission spectrum. --- src/physics.f90 | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/src/physics.f90 b/src/physics.f90 index 6d0759397..f0249fb86 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -1711,13 +1711,32 @@ contains ! ======================================================================= ! MAXWELL FISSION SPECTRUM + ! read number of interpolation regions and incoming energies + NR = int(edist % data(1)) + NE = int(edist % data(2 + 2*NR)) + ! determine nuclear temperature from tabulated function T = interpolate_tab1(edist % data, E_in) - - ! sample maxwell fission spectrum - E_out = maxwell_spectrum(T) - ! TODO: Add restriction energy constraint?? + ! determine restriction energy + lc = 2 + 2*NR + 2*NE + U = edist % data(lc + 1) + + n_sample = 0 + do + ! sample maxwell fission spectrum + E_out = maxwell_spectrum(T) + + ! accept energy based on restriction energy + if (E_out <= E_in - U) exit + + ! check for large number of rejections + n_sample = n_sample + 1 + if (n_sample == MAX_SAMPLE) then + message = "Too many rejections on evaporation spectrum." + call fatal_error() + end if + end do case (9) ! ======================================================================= From f4111ec63c5a77878a715b550f22a03f6be0cbe8 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Tue, 29 Nov 2011 15:32:57 -0500 Subject: [PATCH 29/70] Added restriction energy constraint on sampling Watt spectrum. --- src/physics.f90 | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/src/physics.f90 b/src/physics.f90 index f0249fb86..9e1b8d03b 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -1733,7 +1733,7 @@ contains ! check for large number of rejections n_sample = n_sample + 1 if (n_sample == MAX_SAMPLE) then - message = "Too many rejections on evaporation spectrum." + message = "Too many rejections on Maxwell fission spectrum." call fatal_error() end if end do @@ -1783,13 +1783,33 @@ contains Watt_a = interpolate_tab1(edist % data, E_in) ! determine Watt parameter 'b' from tabulated function - lc = 3 + 2*(NR + NE) - Watt_b = interpolate_tab1(edist % data, E_in, lc) + lc = 2 + 2*(NR + NE) + Watt_b = interpolate_tab1(edist % data, E_in, lc + 1) - ! Sample energy-dependent Watt fission spectrum - E_out = watt_spectrum(Watt_a, Watt_b) + ! read number of interpolation regions and incoming energies for + ! parameter 'a' + NR = int(edist % data(lc + 1)) + NE = int(edist % data(lc + 2 + 2*NR)) - ! TODO: Add restriction energy constraint?? + ! determine restriction energy + lc = lc + 2 + 2*(NR + NE) + U = edist % data(lc + 1) + + n_sample = 0 + do + ! Sample energy-dependent Watt fission spectrum + E_out = watt_spectrum(Watt_a, Watt_b) + + ! accept energy based on restriction energy + if (E_out <= E_in - U) exit + + ! check for large number of rejections + n_sample = n_sample + 1 + if (n_sample == MAX_SAMPLE) then + message = "Too many rejections on Watt spectrum." + call fatal_error() + end if + end do case (44) ! ======================================================================= From 44012b9b9db281da3d43da591b65a08a581b4eae Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Tue, 29 Nov 2011 15:41:30 -0500 Subject: [PATCH 30/70] Added check for too many iterations in binary_search. --- src/search.f90 | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/search.f90 b/src/search.f90 index 67e8c8e2b..2d3c0cc3d 100644 --- a/src/search.f90 +++ b/src/search.f90 @@ -4,6 +4,8 @@ module search use error, only: fatal_error use global, only: message + integer, parameter :: MAX_ITERATION = 64 + contains !=============================================================================== @@ -20,6 +22,7 @@ contains integer :: L integer :: R + integer :: n_iteration real(8) :: testval L = 1 @@ -30,6 +33,7 @@ contains call fatal_error() end if + n_iteration = 0 do while (R - L > 1) ! Check boundaries @@ -49,6 +53,13 @@ contains elseif (val < testval) then R = array_index end if + + ! check for large number of iterations + n_iteration = n_iteration + 1 + if (n_iteration == MAX_ITERATION) then + message = "Reached maximum number of iterations on binary search." + call fatal_error() + end if end do array_index = L From 4cabea8c03f05881b6fe75d39d5e6f9adb64976a Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Wed, 30 Nov 2011 14:20:01 -0500 Subject: [PATCH 31/70] Added check on fission bank synchronization for too many sites send to neighbors. --- src/mpi_routines.f90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/mpi_routines.f90 b/src/mpi_routines.f90 index 847fbc5a5..e0a46d761 100644 --- a/src/mpi_routines.f90 +++ b/src/mpi_routines.f90 @@ -222,6 +222,13 @@ contains send_to_left = int(bank_first - 1_8 - start, 4) send_to_right = int(finish - bank_last, 4) + ! Check to make sure number of sites is not more than size of bank + if (abs(send_to_left) > work .or. abs(send_to_right) > work) then + message = "Tried sending sites to neighboring process greater than " & + // "the size of the source bank." + call fatal_error() + end if + if (rank == n_procs - 1) then if (total > n_particles) then ! If we have extra sites sampled, we will simply discard the extra From de638eb393883ccc710a37b2d65a766039db957b Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Wed, 30 Nov 2011 15:04:59 -0500 Subject: [PATCH 32/70] Improved timing for parallel runs with MPI. --- src/DEPENDENCIES | 1 + src/global.f90 | 15 ++++---- src/initialize.f90 | 6 ++-- src/main.f90 | 17 ++++++--- src/mpi_routines.f90 | 85 ++++++++++++++++++++------------------------ src/output.f90 | 17 ++++++--- src/tally.f90 | 7 ++-- 7 files changed, 78 insertions(+), 70 deletions(-) diff --git a/src/DEPENDENCIES b/src/DEPENDENCIES index 53e65bfa2..178f95a96 100644 --- a/src/DEPENDENCIES +++ b/src/DEPENDENCIES @@ -128,6 +128,7 @@ mpi_routines.o: output.o mpi_routines.o: particle_header.o mpi_routines.o: random_lcg.o mpi_routines.o: tally_header.o +mpi_routines.o: timing.o output.o: constants.o output.o: datatypes.o diff --git a/src/global.f90 b/src/global.f90 index e5533a638..cce461d0d 100644 --- a/src/global.f90 +++ b/src/global.f90 @@ -118,14 +118,21 @@ module global integer :: rank ! rank of process logical :: master ! master process? logical :: mpi_enabled ! is MPI in use and initialized? + integer :: mpi_err ! MPI error code ! ============================================================================ ! TIMING VARIABLES type(Timer) :: time_total ! timer for total run - type(Timer) :: time_init ! timer for initialization + type(Timer) :: time_initialize ! timer for initialization + type(Timer) :: time_read_xs ! timer for reading cross sections type(Timer) :: time_intercycle ! timer for intercycle synchronization + type(Timer) :: time_ic_tallies ! timer for intercycle accumulate tallies + type(Timer) :: time_ic_sample ! timer for intercycle sampling + type(Timer) :: time_ic_sendrecv ! timer for intercycle SEND/RECV + type(Timer) :: time_ic_rebuild ! timer for intercycle source bank rebuild type(Timer) :: time_inactive ! timer for inactive cycles + type(Timer) :: time_active ! timer for active cycles type(Timer) :: time_compute ! timer for computation ! =========================================================================== @@ -169,10 +176,6 @@ contains subroutine free_memory() -#ifdef MPI - integer :: ierr -#endif - ! Deallocate cells, surfaces, materials if (allocated(cells)) deallocate(cells) if (allocated(surfaces)) deallocate(surfaces) @@ -193,7 +196,7 @@ contains #ifdef MPI ! If MPI is in use and enabled, terminate it - call MPI_FINALIZE(ierr) + call MPI_FINALIZE(mpi_err) #endif end subroutine free_memory diff --git a/src/initialize.f90 b/src/initialize.f90 index 5c1d6a2be..1dcafcd6d 100644 --- a/src/initialize.f90 +++ b/src/initialize.f90 @@ -36,7 +36,7 @@ contains type(Universe), pointer :: univ ! Start initialization timer - call timer_start(time_init) + call timer_start(time_initialize) ! Setup MPI call setup_mpi() @@ -84,7 +84,9 @@ contains call normalize_ao() ! Read ACE-format cross sections + call timer_start(time_read_xs) call read_xs() + call timer_stop(time_read_xs) ! Construct unionized energy grid from cross-sections call unionized_grid() @@ -108,7 +110,7 @@ contains end if ! Stop initialization timer - call timer_stop(time_init) + call timer_stop(time_initialize) end subroutine initialize_run diff --git a/src/main.f90 b/src/main.f90 index de1c473fc..6e97bda15 100644 --- a/src/main.f90 +++ b/src/main.f90 @@ -33,10 +33,13 @@ program main else call run_problem() + ! Calculate statistics for tallies and write to tallies.out + call tally_statistics() + if (master) call write_tallies() + ! show timing statistics call timer_stop(time_total) if (master) call print_runtime() - if (master) call write_tallies() end if ! deallocate arrays @@ -58,6 +61,7 @@ contains if (master) call header("BEGIN SIMULATION", 1) tallies_on = .false. + call timer_start(time_active) call timer_start(time_inactive) ! ========================================================================== @@ -103,7 +107,11 @@ contains call timer_start(time_intercycle) ! Collect tallies - if (tallies_on) call synchronize_tallies() + if (tallies_on) then + call timer_start(time_ic_tallies) + call synchronize_tallies() + call timer_stop(time_ic_tallies) + end if ! Distribute fission bank across processors evenly call synchronize_bank(i_cycle) @@ -124,12 +132,11 @@ contains end do CYCLE_LOOP + call timer_stop(time_active) + ! ========================================================================== ! END OF RUN WRAPUP - ! Calculate statistics for tallies - call tally_statistics() - if (master) call header("SIMULATION FINISHED", 1) end subroutine run_problem diff --git a/src/mpi_routines.f90 b/src/mpi_routines.f90 index e0a46d761..2ea05e23f 100644 --- a/src/mpi_routines.f90 +++ b/src/mpi_routines.f90 @@ -7,6 +7,7 @@ module mpi_routines use particle_header, only: Particle, initialize_particle use random_lcg, only: prn, set_particle_seed, prn_skip use tally_header, only: TallyObject + use timing, only: timer_start, timer_stop #ifdef MPI use mpi @@ -16,7 +17,6 @@ module mpi_routines integer :: MPI_BANK ! MPI datatype for fission bank integer(8) :: bank_index ! Fission bank site unique identifier - real(8) :: t_sync(4) ! synchronization time contains @@ -30,7 +30,6 @@ contains #ifdef MPI integer :: i - integer :: ierr ! Error status integer :: bank_blocks(4) ! Count for each datatype integer :: bank_types(4) ! Datatypes integer(MPI_ADDRESS_KIND) :: bank_disp(4) ! Displacements @@ -40,22 +39,22 @@ contains mpi_enabled = .true. ! Initialize MPI - call MPI_INIT(ierr) - if (ierr /= MPI_SUCCESS) then + call MPI_INIT(mpi_err) + if (mpi_err /= MPI_SUCCESS) then message = "Failed to initialize MPI." call fatal_error() end if ! Determine number of processors - call MPI_COMM_SIZE(MPI_COMM_WORLD, n_procs, ierr) - if (ierr /= MPI_SUCCESS) then + call MPI_COMM_SIZE(MPI_COMM_WORLD, n_procs, mpi_err) + if (mpi_err /= MPI_SUCCESS) then message = "Could not determine number of processors." call fatal_error() end if ! Determine rank of each processor - call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) - if (ierr /= MPI_SUCCESS) then + call MPI_COMM_RANK(MPI_COMM_WORLD, rank, mpi_err) + if (mpi_err /= MPI_SUCCESS) then message = "Could not determine MPI rank." call fatal_error() end if @@ -68,10 +67,10 @@ contains end if ! Determine displacements for MPI_BANK type - call MPI_GET_ADDRESS(b % id, bank_disp(1), ierr) - call MPI_GET_ADDRESS(b % xyz, bank_disp(2), ierr) - call MPI_GET_ADDRESS(b % uvw, bank_disp(3), ierr) - call MPI_GET_ADDRESS(b % E, bank_disp(4), ierr) + call MPI_GET_ADDRESS(b % id, bank_disp(1), mpi_err) + call MPI_GET_ADDRESS(b % xyz, bank_disp(2), mpi_err) + call MPI_GET_ADDRESS(b % uvw, bank_disp(3), mpi_err) + call MPI_GET_ADDRESS(b % E, bank_disp(4), mpi_err) ! Adjust displacements base = bank_disp(1) @@ -83,10 +82,9 @@ contains bank_blocks = (/ 1, 3, 3, 1 /) bank_types = (/ MPI_INTEGER8, MPI_REAL8, MPI_REAL8, MPI_REAL8 /) call MPI_TYPE_CREATE_STRUCT(4, bank_blocks, bank_disp, & - & bank_types, MPI_BANK, ierr) - call MPI_TYPE_COMMIT(MPI_BANK, ierr) + & bank_types, MPI_BANK, mpi_err) + call MPI_TYPE_COMMIT(MPI_BANK, mpi_err) - t_sync = ZERO #else ! if no MPI, set processor to master mpi_enabled = .false. @@ -122,32 +120,25 @@ contains & right_bank(:) ! bank sites to send/recv to or fram right node #ifdef MPI - integer :: ierr integer :: status(MPI_STATUS_SIZE) ! message status integer :: request ! communication request for sending sites integer :: request_left ! communication request for recv sites from left integer :: request_right ! communication request for recv sites from right - real(8) :: t0, t1, t2, t3, t4 #endif message = "Collecting number of fission sites..." call write_message(8) #ifdef MPI - call MPI_BARRIER(MPI_COMM_WORLD, ierr) - t0 = MPI_WTIME() - ! Determine starting index for fission bank and total sites in fission bank start = 0_8 call MPI_EXSCAN(n_bank, start, 1, MPI_INTEGER8, MPI_SUM, & - & MPI_COMM_WORLD, ierr) + & MPI_COMM_WORLD, mpi_err) finish = start + n_bank total = finish call MPI_BCAST(total, 1, MPI_INTEGER8, n_procs - 1, & - & MPI_COMM_WORLD, ierr) + & MPI_COMM_WORLD, mpi_err) - t1 = MPI_WTIME() - t_sync(1) = t_sync(1) + (t1 - t0) #else start = 0_8 finish = n_bank @@ -179,6 +170,8 @@ contains message = "Sampling fission sites..." call write_message(8) + call timer_start(time_ic_sample) + ! ========================================================================== ! SAMPLE N_PARTICLES FROM FISSION BANK AND PLACE IN TEMP_SITES do i = 1, int(n_bank,4) @@ -207,11 +200,11 @@ contains #ifdef MPI start = 0_8 call MPI_EXSCAN(index_local, start, 1, MPI_INTEGER8, MPI_SUM, & - & MPI_COMM_WORLD, ierr) + & MPI_COMM_WORLD, mpi_err) finish = start + index_local total = finish call MPI_BCAST(total, 1, MPI_INTEGER8, n_procs - 1, & - & MPI_COMM_WORLD, ierr) + & MPI_COMM_WORLD, mpi_err) #else start = 0_8 finish = index_local @@ -251,10 +244,10 @@ contains send_to_right = 0 end if -#ifdef MPI - t2 = MPI_WTIME() - t_sync(2) = t_sync(2) + (t2 - t1) + call timer_stop(time_ic_sample) + call timer_start(time_ic_sendrecv) +#ifdef MPI message = "Sending fission sites..." call write_message(8) @@ -266,24 +259,24 @@ contains if (send_to_right > 0) then i = index_local - send_to_right + 1 call MPI_ISEND(temp_sites(i), send_to_right, MPI_BANK, rank+1, 0, & - & MPI_COMM_WORLD, request, ierr) + & MPI_COMM_WORLD, request, mpi_err) else if (send_to_right < 0) then call MPI_IRECV(right_bank, -send_to_right, MPI_BANK, rank+1, 1, & - & MPI_COMM_WORLD, request_right, ierr) + & MPI_COMM_WORLD, request_right, mpi_err) end if if (send_to_left < 0) then call MPI_IRECV(left_bank, -send_to_left, MPI_BANK, rank-1, 0, & - & MPI_COMM_WORLD, request_left, ierr) + & MPI_COMM_WORLD, request_left, mpi_err) else if (send_to_left > 0) then call MPI_ISEND(temp_sites(1), send_to_left, MPI_BANK, rank-1, 1, & - & MPI_COMM_WORLD, request, ierr) + & MPI_COMM_WORLD, request, mpi_err) end if - - t3 = MPI_WTIME() - t_sync(3) = t_sync(3) + (t3 - t2) #endif + call timer_stop(time_ic_sendrecv) + call timer_start(time_ic_rebuild) + message = "Constructing source bank..." call write_message(8) @@ -294,7 +287,7 @@ contains j = int(index_local,4) - send_to_right ! size of second block call copy_from_bank(temp_sites, i+1, j) #ifdef MPI - call MPI_WAIT(request_left, status, ierr) + call MPI_WAIT(request_left, status, mpi_err) #endif call copy_from_bank(left_bank, 1, i) else if (send_to_left >= 0 .and. send_to_right < 0) then @@ -302,7 +295,7 @@ contains j = -send_to_right ! size of second block call copy_from_bank(temp_sites(1+send_to_left), 1, i) #ifdef MPI - call MPI_WAIT(request_right, status, ierr) + call MPI_WAIT(request_right, status, mpi_err) #endif call copy_from_bank(right_bank, i+1, j) else if (send_to_left >= 0 .and. send_to_right >= 0) then @@ -314,23 +307,22 @@ contains k = -send_to_right call copy_from_bank(temp_sites, i+1, j) #ifdef MPI - call MPI_WAIT(request_left, status, ierr) + call MPI_WAIT(request_left, status, mpi_err) #endif call copy_from_bank(left_bank, 1, i) #ifdef MPI - call MPI_WAIT(request_right, status, ierr) + call MPI_WAIT(request_right, status, mpi_err) #endif call copy_from_bank(right_bank, i+j+1, k) end if ! Reset source index source_index = 0_8 + + call timer_stop(time_ic_rebuild) #ifdef MPI - t4 = MPI_WTIME() - t_sync(4) = t_sync(4) + (t4 - t3) - - deallocate(left_bank ) + deallocate(left_bank) deallocate(right_bank) #endif deallocate(temp_sites) @@ -380,7 +372,6 @@ contains integer :: n integer :: m integer :: n_bins - integer :: ierr real(8), allocatable :: tally_temp(:,:) type(TallyObject), pointer :: t @@ -398,14 +389,14 @@ contains if (master) then ! Description of MPI_IN_PLANE call MPI_REDUCE(MPI_IN_PLACE, tally_temp, n_bins, MPI_REAL8, MPI_SUM, & - 0, MPI_COMM_WORLD, ierr) + 0, MPI_COMM_WORLD, mpi_err) ! Transfer values to val_history on master t % scores(:,:) % val_history = tally_temp else ! Receive buffer not significant at other processors call MPI_REDUCE(tally_temp, tally_temp, n_bins, MPI_REAL8, MPI_SUM, & - 0, MPI_COMM_WORLD, ierr) + 0, MPI_COMM_WORLD, mpi_err) ! Reset val_history on other processors t % scores(:,:) % val_history = 0 diff --git a/src/output.f90 b/src/output.f90 index 860559593..68603f2d9 100644 --- a/src/output.f90 +++ b/src/output.f90 @@ -718,7 +718,7 @@ contains write(ou,*) ! Format descriptor for columns -100 format (1X,A,T35,A) +100 format (1X,A,T25,A) nullify(s) nullify(c) @@ -768,13 +768,20 @@ contains character(15) :: string ! display header block - call header("Time Elapsed") + call header("Timing Statistics") ! display time elapsed for various sections - write(ou,100) "Total time elapsed", time_total % elapsed - write(ou,100) "Total time for initialization", time_init % elapsed + write(ou,100) "Total time for initialization", time_initialize % elapsed + write(ou,100) " Reading cross sections", time_read_xs % elapsed write(ou,100) "Total time in computation", time_compute % elapsed write(ou,100) "Total time between cycles", time_intercycle % elapsed + write(ou,100) " Accumulating tallies", time_ic_tallies % elapsed + write(ou,100) " Sampling source sites", time_ic_sample % elapsed + write(ou,100) " SEND/RECV source sites", time_ic_sendrecv % elapsed + write(ou,100) " Reconstruct source bank", time_ic_rebuild % elapsed + write(ou,100) "Total time in inactive cycles", time_inactive % elapsed + write(ou,100) "Total time in active cycles", time_active % elapsed + write(ou,100) "Total time elapsed", time_total % elapsed ! display header block call header("Run Statistics") @@ -788,7 +795,7 @@ contains write(ou,*) ! format for write statements -100 format (1X,A,T33,"= ",ES11.4," seconds") +100 format (1X,A,T35,"= ",ES11.4," seconds") 101 format (1X,A,T20,"= ",A," neutrons/second") 102 format (1X,A,T20,"= ",F8.5," +/- ",F8.5) diff --git a/src/tally.f90 b/src/tally.f90 index 152cf403c..ca9f0eb26 100644 --- a/src/tally.f90 +++ b/src/tally.f90 @@ -35,9 +35,6 @@ contains real(8), save :: k1 = 0. ! accumulated keff real(8), save :: k2 = 0. ! accumulated keff**2 real(8) :: std ! stdev of keff over active cycles -#ifdef MPI - integer :: ierr -#endif message = "Calculate cycle keff..." call write_message(8) @@ -51,7 +48,7 @@ contains #ifdef MPI ! Collect number bank sites onto master process call MPI_REDUCE(n_bank, total_bank, 1, MPI_INTEGER8, MPI_SUM, 0, & - & MPI_COMM_WORLD, ierr) + & MPI_COMM_WORLD, mpi_err) #else total_bank = n_bank #endif @@ -78,7 +75,7 @@ contains end if #ifdef MPI - call MPI_BCAST(keff, 1, MPI_REAL8, 0, MPI_COMM_WORLD, ierr) + call MPI_BCAST(keff, 1, MPI_REAL8, 0, MPI_COMM_WORLD, mpi_err) #endif 100 format (2X,I4,2X,F8.5) From 3343740efc5ccba2a01b476cbc67de475935ec8f Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Wed, 30 Nov 2011 15:53:10 -0500 Subject: [PATCH 33/70] Reorganized constants module. --- src/constants.f90 | 108 ++++++++++++++++++++++++++++------------------ 1 file changed, 65 insertions(+), 43 deletions(-) diff --git a/src/constants.f90 b/src/constants.f90 index 1592fccfd..cde593ffd 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -2,12 +2,39 @@ module constants implicit none - ! Versioning numbers + ! ============================================================================ + ! VERSIONING NUMBERS + integer, parameter :: VERSION_MAJOR = 0 integer, parameter :: VERSION_MINOR = 3 integer, parameter :: VERSION_RELEASE = 3 - ! Physical constants + ! ============================================================================ + ! ADJUSTABLE PARAMETERS + + ! NOTE: This is the only section of the constants module that should ever be + ! adjusted. Modifying constants in other sections may cause the code to fail. + + ! Monoatomic ideal-gas scattering treatment threshold + real(8), parameter :: FREE_GAS_THRESHOLD = 400.0 + + ! Used for surface current tallies + real(8), parameter :: TINY_BIT = 1e-8 + + ! Maximum number of collisions/crossings + integer, parameter :: MAX_EVENTS = 10000 + integer, parameter :: MAX_SAMPLE = 100000 + + ! Maximum number of words in a single line, length of line, and length of + ! single word + integer, parameter :: MAX_WORDS = 500 + integer, parameter :: MAX_LINE_LEN = 250 + integer, parameter :: MAX_WORD_LEN = 150 + integer, parameter :: MAX_FILE_LEN = 255 + + ! ============================================================================ + ! PHYSICAL CONSTANTS + real(8), parameter :: & PI = 3.1415926535898_8, & ! pi MASS_NEUTRON = 1.0086649156, & ! mass of a neutron @@ -20,8 +47,8 @@ module constants ONE = 1.0_8, & TWO = 2.0_8 - ! Monoatomic ideal-gas scattering treatment threshold - real(8), parameter :: FREE_GAS_THRESHOLD = 400.0 + ! ============================================================================ + ! GEOMETRY-RELATED CONSTANTS ! Boundary conditions integer, parameter :: & @@ -70,27 +97,8 @@ module constants & SENSE_POSITIVE = 1, & & SENSE_NEGATIVE = -1 - ! Used for surface current tallies - real(8), parameter :: TINY_BIT = 1e-8 - - ! Maximum number of collisions/crossings - integer, parameter :: MAX_EVENTS = 10000 - integer, parameter :: MAX_SAMPLE = 100000 - - ! Codes for read errors -- better hope these numbers are never used in an - ! input file! - integer, parameter :: ERROR_INT = -huge(0) - real(8), parameter :: ERROR_REAL = -huge(0.0_8) * 0.917826354_8 - - ! Source types - integer, parameter :: & - SRC_BOX = 1, & ! Source in a rectangular prism - SRC_CELL = 2, & ! Source in a cell - SRC_SURFACE = 3 ! Source on a surface - - integer, parameter :: & - PROB_SOURCE = 1, & ! External source problem - PROB_CRITICALITY = 2 ! Criticality problem + ! ============================================================================ + ! CROSS SECTION RELATED CONSTANTS ! Interpolation flag integer, parameter :: & @@ -179,6 +187,23 @@ module constants ACE_THERMAL = 2, & ! thermal S(a,b) scattering data ACE_DOSIMETRY = 3 ! dosimetry cross sections + ! Fission neutron emission (nu) type + integer, parameter :: & + NU_NONE = 0, & ! No nu values (non-fissionable) + NU_POLYNOMIAL = 1, & ! Nu values given by polynomial + NU_TABULAR = 2 ! Nu values given by tabular distribution + + ! Cross section filetypes + integer, parameter :: & + ASCII = 1, & ! ASCII cross section file + BINARY = 2 ! Binary cross section file + + ! Maximum number of partial fission reactions + integer, parameter :: PARTIAL_FISSION_MAX = 4 + + ! ============================================================================ + ! TALLY-RELATED CONSTANTS + ! Tally macro reactions integer, parameter :: N_MACRO_TYPES = 15 integer, parameter :: & @@ -230,26 +255,23 @@ module constants IN_TOP = 5, & OUT_TOP = 6 - ! Fission neutron emission (nu) type + ! ============================================================================ + ! MISCELLANEOUS CONSTANTS + + ! Codes for read errors -- better hope these numbers are never used in an + ! input file! + integer, parameter :: ERROR_INT = -huge(0) + real(8), parameter :: ERROR_REAL = -huge(0.0_8) * 0.917826354_8 + + ! Source types integer, parameter :: & - NU_NONE = 0, & ! No nu values (non-fissionable) - NU_POLYNOMIAL = 1, & ! Nu values given by polynomial - NU_TABULAR = 2 ! Nu values given by tabular distribution + SRC_BOX = 1, & ! Source in a rectangular prism + SRC_CELL = 2, & ! Source in a cell + SRC_SURFACE = 3 ! Source on a surface - ! Cross section filetypes - integer, parameter :: & - ASCII = 1, & ! ASCII cross section file - BINARY = 2 ! Binary cross section file - - ! Maximum number of partial fission reactions - integer, parameter :: PARTIAL_FISSION_MAX = 4 - - ! Maximum number of words in a single line, length of line, and length of - ! single word - integer, parameter :: MAX_WORDS = 500 - integer, parameter :: MAX_LINE_LEN = 250 - integer, parameter :: MAX_WORD_LEN = 150 - integer, parameter :: MAX_FILE_LEN = 255 + integer, parameter :: & + PROB_SOURCE = 1, & ! External source problem + PROB_CRITICALITY = 2 ! Criticality problem ! Unit numbers integer, parameter :: UNIT_LOG = 11 ! unit # for writing log file From 585d353f6874818a02dadd170633432ff7b7b489 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Wed, 30 Nov 2011 15:57:57 -0500 Subject: [PATCH 34/70] Added timer for unionizing energy grid. --- src/global.f90 | 1 + src/initialize.f90 | 2 ++ src/output.f90 | 1 + 3 files changed, 4 insertions(+) diff --git a/src/global.f90 b/src/global.f90 index cce461d0d..570c726ca 100644 --- a/src/global.f90 +++ b/src/global.f90 @@ -126,6 +126,7 @@ module global type(Timer) :: time_total ! timer for total run type(Timer) :: time_initialize ! timer for initialization type(Timer) :: time_read_xs ! timer for reading cross sections + type(Timer) :: time_unionize ! timer for unionizing energy grid type(Timer) :: time_intercycle ! timer for intercycle synchronization type(Timer) :: time_ic_tallies ! timer for intercycle accumulate tallies type(Timer) :: time_ic_sample ! timer for intercycle sampling diff --git a/src/initialize.f90 b/src/initialize.f90 index 1dcafcd6d..d9d79736e 100644 --- a/src/initialize.f90 +++ b/src/initialize.f90 @@ -89,8 +89,10 @@ contains call timer_stop(time_read_xs) ! Construct unionized energy grid from cross-sections + call timer_start(time_unionize) call unionized_grid() call original_indices() + call timer_stop(time_unionize) ! Create tally map call create_tally_map() diff --git a/src/output.f90 b/src/output.f90 index 68603f2d9..d2c7b0e79 100644 --- a/src/output.f90 +++ b/src/output.f90 @@ -773,6 +773,7 @@ contains ! display time elapsed for various sections write(ou,100) "Total time for initialization", time_initialize % elapsed write(ou,100) " Reading cross sections", time_read_xs % elapsed + write(ou,100) " Unionizing energy grid", time_unionize % elapsed write(ou,100) "Total time in computation", time_compute % elapsed write(ou,100) "Total time between cycles", time_intercycle % elapsed write(ou,100) " Accumulating tallies", time_ic_tallies % elapsed From d8af37eef73d0cc30e59f1f0a24c95bc9f98a2f6 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Wed, 30 Nov 2011 20:58:43 -0500 Subject: [PATCH 35/70] Added energy grid summary on output. --- src/output.f90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/output.f90 b/src/output.f90 index d2c7b0e79..d5eb843da 100644 --- a/src/output.f90 +++ b/src/output.f90 @@ -704,6 +704,12 @@ contains end do end if + ! print summary of unionized energy grid + call header("UNIONIZED ENERGY GRID") + write(ou,*) "Points on energy grid: " // trim(int_to_str(n_grid)) + write(ou,*) "Extra storage required: " // trim(int_to_str(& + n_grid*n_nuclides_total*4)) // " bytes" + ! print summary of variance reduction call header("VARIANCE REDUCTION") if (survival_biasing) then From 1d81b40bde1a3e37829618015d5a855a918b5e71 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Wed, 30 Nov 2011 23:11:25 -0500 Subject: [PATCH 36/70] Added floating point equality check for lattice and parent boundaries. --- src/constants.f90 | 3 +++ src/geometry.f90 | 43 ++++++++++++++++++++++++++++++------------- 2 files changed, 33 insertions(+), 13 deletions(-) diff --git a/src/constants.f90 b/src/constants.f90 index cde593ffd..3e272e7c7 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -21,6 +21,9 @@ module constants ! Used for surface current tallies real(8), parameter :: TINY_BIT = 1e-8 + ! User for precision in geometry + real(8), parameter :: FP_PRECISION = 1e-9_8 + ! Maximum number of collisions/crossings integer, parameter :: MAX_EVENTS = 10000 integer, parameter :: MAX_SAMPLE = 100000 diff --git a/src/geometry.f90 b/src/geometry.f90 index 0e28d3ea3..b77915d44 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -550,10 +550,12 @@ contains i_x = p % index_x i_y = p % index_y if (i_x < 1 .or. i_x > lat % n_x) then - message = "Reached edge of lattice." + message = "Reached edge of lattice (" // trim(int_to_str(i_x)) // & + "," // trim(int_to_str(i_y)) // ")." call fatal_error() elseif (i_y < 1 .or. i_y > lat % n_y) then - message = "Reached edge of lattice." + message = "Reached edge of lattice (" // trim(int_to_str(i_x)) // & + "," // trim(int_to_str(i_y)) // ")." call fatal_error() end if @@ -634,7 +636,9 @@ contains v = p % uvw(2) w = p % uvw(3) - ! loop over all surfaces + ! ========================================================================== + ! FIND MINIMUM DISTANCE TO SURFACES IN CELL AND PARENT + dist = INFINITY do i = 1, n_surf if (i <= n1) then @@ -911,10 +915,11 @@ contains dist = d surf = -expression(i) end if - end do - ! Check lattice surfaces + ! ========================================================================== + ! FIND MINIMUM DISTANCE TO LATTICE SURFACES + in_lattice = .false. if (p % lattice > 0) then lat => lattices(p % lattice) @@ -922,9 +927,8 @@ contains x = p % xyz_local(1) y = p % xyz_local(2) z = p % xyz_local(3) - x0 = lat % width_x * 0.5 - y0 = lat % width_y * 0.5 - + x0 = lat % width_x * 0.5_8 + y0 = lat % width_y * 0.5_8 ! left and right sides if (u > 0) then @@ -932,9 +936,19 @@ contains else d = -(x + x0)/u end if - if (d < dist) then - dist = d - in_lattice = .true. + + ! If the lattice boundary is coincident with the parent cell boundary, + ! we need to make sure that the lattice is not selected. This is + ! complicated by the fact that floating point may determine that one + ! is closer than the other (can't check direct equality). Thus, the + ! logic here checks whether the relative difference is within floating + ! point precision. + + if (d < dist) then + if (abs(d - dist)/dist >= FP_PRECISION) then + dist = d + in_lattice = .true. + end if end if ! top and bottom sides @@ -943,9 +957,12 @@ contains else d = -(y + y0)/v end if + if (d < dist) then - dist = d - in_lattice = .true. + if (abs(d - dist)/dist >= FP_PRECISION) then + dist = d + in_lattice = .true. + end if end if elseif (lat % type == LATTICE_HEX) then From 392fecb7db736c355ec4e45a85be27a624ced415 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 1 Dec 2011 11:31:02 -0500 Subject: [PATCH 37/70] Removed echo_input, added print_geometry, allow plotting mode to use pwd by default. --- src/initialize.f90 | 8 ++--- src/output.f90 | 85 ++++++++++++++++++++++------------------------ 2 files changed, 44 insertions(+), 49 deletions(-) diff --git a/src/initialize.f90 b/src/initialize.f90 index d9d79736e..ce045c499 100644 --- a/src/initialize.f90 +++ b/src/initialize.f90 @@ -14,8 +14,8 @@ module initialize cells_in_univ_dict use logging, only: create_log use mpi_routines, only: setup_mpi - use output, only: title, echo_input, message, print_summary, & - print_particle, header, print_plot + use output, only: title, header, print_summary, print_geometry, & + print_plot use random_lcg, only: initialize_prng use source, only: initialize_source use string, only: int_to_str, starts_with, ends_with, lower_case @@ -104,9 +104,9 @@ contains ! stop timer for initialization if (master) then if (plotting) then + call print_geometry() call print_plot() else - call echo_input() call print_summary() end if end if @@ -150,7 +150,7 @@ contains end do ! Determine directory where XML input files are - if (argc > 0) then + if (argc > 0 .and. last_flag < argc) then path_input = argv(last_flag + 1) ! Need to add working directory if the given path is a relative path if (.not. starts_with(path_input, "/")) then diff --git a/src/output.f90 b/src/output.f90 index d5eb843da..3f52da8a0 100644 --- a/src/output.f90 +++ b/src/output.f90 @@ -58,36 +58,6 @@ contains end subroutine title -!=============================================================================== -! ECHO_INPUT displays summary information about the problem about to be run -! after reading all the input. -!=============================================================================== - - subroutine echo_input() - - ! Display problem summary - call header("PROBLEM SUMMARY") - if (problem_type == PROB_CRITICALITY) then - write(ou,100) 'Problem type:', 'Criticality' - write(ou,101) 'Number of Cycles:', n_cycles - write(ou,101) 'Number of Inactive Cycles:', n_inactive - elseif (problem_type == PROB_SOURCE) then - write(ou,100) 'Problem type:', 'External Source' - end if - write(ou,101) 'Number of Particles:', n_particles - - ! Display geometry summary - call header("GEOMETRY SUMMARY") - write(ou,101) 'Number of Cells:', n_cells - write(ou,101) 'Number of Surfaces:', n_surfaces - write(ou,101) 'Number of Materials:', n_materials - - ! Format descriptor for columns -100 format (1X,A,T35,A) -101 format (1X,A,T35,I11) - - end subroutine echo_input - !=============================================================================== ! HEADER displays a header block according to a specified level. If no level is ! specified, it is assumed to be a minor header block (H3). @@ -642,21 +612,17 @@ contains end subroutine print_tally !=============================================================================== -! PRINT_SUMMARY displays the attributes of all cells, universes, -! surfaces and materials read in the input file. Very useful for -! debugging! +! PRINT_GEOMETRY displays the attributes of all cells, surfaces, universes, +! surfaces, and lattices read in the input files. !=============================================================================== - subroutine print_summary() + subroutine print_geometry() + integer :: i type(Surface), pointer :: s => null() type(Cell), pointer :: c => null() type(Universe), pointer :: u => null() type(Lattice), pointer :: l => null() - type(Material), pointer :: m => null() - type(TallyObject), pointer :: t => null() - character(15) :: string - integer :: i ! print summary of cells call header("CELL SUMMARY") @@ -688,6 +654,40 @@ contains call print_surface(s) end do + end subroutine print_geometry + +!=============================================================================== +! PRINT_SUMMARY displays summary information about the problem about to be run +! after reading all input files +!=============================================================================== + + subroutine print_summary() + + integer :: i + character(15) :: string + type(Material), pointer :: m => null() + type(TallyObject), pointer :: t => null() + + ! Display problem summary + call header("PROBLEM SUMMARY") + if (problem_type == PROB_CRITICALITY) then + write(ou,100) 'Problem type:', 'Criticality' + write(ou,101) 'Number of Cycles:', n_cycles + write(ou,101) 'Number of Inactive Cycles:', n_inactive + elseif (problem_type == PROB_SOURCE) then + write(ou,100) 'Problem type:', 'External Source' + end if + write(ou,101) 'Number of Particles:', n_particles + + ! Display geometry summary + call header("GEOMETRY SUMMARY") + write(ou,101) 'Number of Cells:', n_cells + write(ou,101) 'Number of Surfaces:', n_surfaces + write(ou,101) 'Number of Materials:', n_materials + + ! print summary of all geometry + call print_geometry() + ! print summary of materials call header("MATERIAL SUMMARY") do i = 1, n_materials @@ -724,14 +724,9 @@ contains write(ou,*) ! Format descriptor for columns -100 format (1X,A,T25,A) +100 format (1X,A,T35,A) +101 format (1X,A,T35,I11) - nullify(s) - nullify(c) - nullify(u) - nullify(l) - nullify(m) - nullify(t) end subroutine print_summary From 86009101de1e06cea411560670d29b34afd50608 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 1 Dec 2011 13:05:31 -0500 Subject: [PATCH 38/70] Added extra output about lattices upon errors. --- src/geometry.f90 | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/geometry.f90 b/src/geometry.f90 index b77915d44..e6a1e2bf5 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -483,13 +483,13 @@ contains type(Lattice), pointer :: lat type(Universe), pointer :: univ + lat => lattices(p % lattice) + if (verbosity >= 10) then - message = " Crossing lattice" + message = " Crossing lattice " // int_to_str(lat % id) call write_message() end if - lat => lattices(p % lattice) - u = p % uvw(1) v = p % uvw(2) @@ -550,12 +550,14 @@ contains i_x = p % index_x i_y = p % index_y if (i_x < 1 .or. i_x > lat % n_x) then - message = "Reached edge of lattice (" // trim(int_to_str(i_x)) // & - "," // trim(int_to_str(i_y)) // ")." + message = "Reached edge of lattice " // trim(int_to_str(lat % id)) // & + " at position (" // trim(int_to_str(i_x)) // "," // & + trim(int_to_str(i_y)) // ")." call fatal_error() elseif (i_y < 1 .or. i_y > lat % n_y) then - message = "Reached edge of lattice (" // trim(int_to_str(i_x)) // & - "," // trim(int_to_str(i_y)) // ")." + message = "Reached edge of lattice " // trim(int_to_str(lat % id)) // & + " at position (" // trim(int_to_str(i_x)) // "," // & + trim(int_to_str(i_y)) // ")." call fatal_error() end if From 06bd0b5626ce78b75c5f40c3adf21fe4eadd41f8 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 1 Dec 2011 13:14:48 -0500 Subject: [PATCH 39/70] Changed dist_to_boundary to distance_to_boundary. --- src/geometry.f90 | 6 +++--- src/physics.f90 | 16 ++++++++-------- src/plot.f90 | 6 +++--- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/geometry.f90 b/src/geometry.f90 index e6a1e2bf5..dbb238fb4 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -574,12 +574,12 @@ contains end subroutine cross_lattice !=============================================================================== -! DIST_TO_BOUNDARY calculates the distance to the nearest boundary for a +! DISTANCE_TO_BOUNDARY calculates the distance to the nearest boundary for a ! particle 'p' traveling in a certain direction. For a cell in a subuniverse ! that has a parent cell, also include the surfaces of the edge of the universe. !=============================================================================== - subroutine dist_to_boundary(p, dist, surf, in_lattice) + subroutine distance_to_boundary(p, dist, surf, in_lattice) type(Particle), pointer :: p real(8), intent(out) :: dist @@ -975,7 +975,7 @@ contains ! deallocate expression deallocate(expression) - end subroutine dist_to_boundary + end subroutine distance_to_boundary !=============================================================================== ! SENSE determines whether a point is on the 'positive' or 'negative' side of a diff --git a/src/physics.f90 b/src/physics.f90 index 9e1b8d03b..420d0f4a2 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -5,8 +5,8 @@ module physics use endf, only: reaction_name, is_fission, is_scatter use error, only: fatal_error, warning use fission, only: nu_total, nu_prompt, nu_delayed - use geometry, only: find_cell, dist_to_boundary, cross_surface, & - cross_lattice + use geometry, only: find_cell, distance_to_boundary, & + cross_surface, cross_lattice use geometry_header, only: Universe, BASE_UNIVERSE use global use interpolation, only: interpolate_tab1 @@ -32,8 +32,8 @@ contains integer :: surf ! surface which particle is on integer :: last_cell ! most recent cell particle was in integer :: n_event ! number of collisions/crossings - real(8) :: d_to_boundary ! distance to nearest boundary - real(8) :: d_to_collision ! sampled distance to collision + real(8) :: d_boundary ! distance to nearest boundary + real(8) :: d_collision ! sampled distance to collision real(8) :: distance ! distance particle travels logical :: found_cell ! found cell which particle is in? logical :: in_lattice ! is surface crossing in lattice? @@ -74,19 +74,19 @@ contains call calculate_xs(p) ! Find the distance to the nearest boundary - call dist_to_boundary(p, d_to_boundary, surf, in_lattice) + call distance_to_boundary(p, d_boundary, surf, in_lattice) ! Sample a distance to collision - d_to_collision = -log(prn()) / material_xs % total + d_collision = -log(prn()) / material_xs % total ! Select smaller of the two distances - distance = min(d_to_boundary, d_to_collision) + distance = min(d_boundary, d_collision) ! Advance particle p % xyz = p % xyz + distance * p % uvw p % xyz_local = p % xyz_local + distance * p % uvw - if (d_to_collision > d_to_boundary) then + if (d_collision > d_boundary) then last_cell = p % cell p % cell = 0 if (in_lattice) then diff --git a/src/plot.f90 b/src/plot.f90 index b8cd12bae..41cc72668 100644 --- a/src/plot.f90 +++ b/src/plot.f90 @@ -2,7 +2,7 @@ module plot use constants use error, only: fatal_error - use geometry, only: find_cell, dist_to_boundary, cross_surface, & + use geometry, only: find_cell, distance_to_boundary, cross_surface, & cross_lattice, cell_contains use geometry_header, only: Universe, BASE_UNIVERSE use global @@ -82,7 +82,7 @@ contains p % cell = univ % cells(i) distance = INFINITY - call dist_to_boundary(p, d, surf, in_lattice) + call distance_to_boundary(p, d, surf, in_lattice) if (d < distance) then ! Move particle forward to next surface p % xyz = p % xyz + d * p % uvw @@ -133,7 +133,7 @@ contains do while (p % alive) ! Calculate distance to next boundary - call dist_to_boundary(p, distance, surf, in_lattice) + call distance_to_boundary(p, distance, surf, in_lattice) ! Advance particle p%xyz = p%xyz + distance * p%uvw From a843d245b6ed2892c8322c27eabb457deb09e278 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 1 Dec 2011 17:55:25 -0500 Subject: [PATCH 40/70] Rewrote all geometry routines to allow for nested universes. --- src/DEPENDENCIES | 1 + src/constants.f90 | 3 + src/geometry.f90 | 1092 ++++++++++++++++++--------------------- src/mpi_routines.f90 | 13 +- src/output.f90 | 42 +- src/particle_header.f90 | 91 +++- src/physics.f90 | 94 ++-- src/plot.f90 | 189 +++---- src/source.f90 | 17 +- src/tally.f90 | 10 +- 10 files changed, 772 insertions(+), 780 deletions(-) diff --git a/src/DEPENDENCIES b/src/DEPENDENCIES index 178f95a96..85c031858 100644 --- a/src/DEPENDENCIES +++ b/src/DEPENDENCIES @@ -140,6 +140,7 @@ output.o: string.o output.o: tally_header.o particle_header.o: constants.o +particle_header.o: geometry_header.o physics.o: constants.o physics.o: cross_section_header.o diff --git a/src/constants.f90 b/src/constants.f90 index 3e272e7c7..332df302e 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -261,6 +261,9 @@ module constants ! ============================================================================ ! MISCELLANEOUS CONSTANTS + ! indicates that an array index hasn't been set + integer, parameter :: NONE = 0 + ! Codes for read errors -- better hope these numbers are never used in an ! input file! integer, parameter :: ERROR_INT = -huge(0) diff --git a/src/geometry.f90 b/src/geometry.f90 index dbb238fb4..ee81c9d9b 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -6,7 +6,7 @@ module geometry use geometry_header, only: Cell, Surface, Universe, Lattice use global use output, only: write_message - use particle_header, only: Particle + use particle_header, only: Particle, LocalCoord, deallocate_coord use string, only: int_to_str use tally, only: score_surface_current @@ -62,7 +62,7 @@ contains ! Compare sense of point to specified sense specified_sense = sign(1,expression(i)) - actual_sense = sense(surf, p % xyz_local) + actual_sense = sense(surf, p % coord % xyz) if (actual_sense == specified_sense) then expression(i) = 1 else @@ -90,77 +90,116 @@ contains ! as it's within the geometry !=============================================================================== - recursive subroutine find_cell(univ, p, found) + recursive subroutine find_cell(p, found, search_cells) - type(Universe), pointer :: univ ! universe to search in - type(Particle), pointer :: p ! pointer to particle - logical, intent(inout) :: found ! particle found? + type(Particle), pointer :: p + logical, intent(inout) :: found + integer, optional :: search_cells(:) - integer :: i ! index over cells - integer :: x, y - type(Cell), pointer :: c ! pointer to cell - type(Lattice), pointer :: lat ! pointer to lattice - type(Universe), pointer :: lower_univ ! if particle is in lower universe, - ! use this pointer to call recursively + integer :: i ! index over cells + integer :: x ! x-index for lattice + integer :: y ! y-index for lattice + integer :: n ! number of cells to search + integer :: index_cell ! index in cells array + logical :: use_search_cells ! use cells provided as argument + type(Cell), pointer :: c ! pointer to cell + type(Lattice), pointer :: lat ! pointer to lattice + type(Universe), pointer :: univ ! universe to search in - found = .false. + ! set size of list to search + if (present(search_cells)) then + use_search_cells = .true. + n = size(search_cells) + else + use_search_cells = .false. + univ => universes(p % coord % universe) + n = univ % n_cells + end if - ! determine what region in - do i = 1, univ % n_cells - c => cells(univ % cells(i)) - - if (cell_contains(c, p)) then - ! If this cell contains a universe or lattice, search for the particle - ! in that universe/lattice - if (c % type == CELL_NORMAL) then - found = .true. - - ! set particle attributes - p % cell = univ % cells(i) - p % universe = dict_get_key(universe_dict, univ % id) - p % material = c % material - exit - elseif (c % type == CELL_FILL) then - lower_univ => universes(c % fill) - call find_cell(lower_univ, p, found) - if (found) then - exit - else - message = "Could not locate particle in universe: " - call fatal_error() - end if - elseif (c % type == CELL_LATTICE) then - ! Set current lattice - lat => lattices(c % fill) - p % lattice = c % fill - - ! determine universe based on lattice position - x = ceiling((p%xyz(1) - lat%x0)/lat%width_x) - y = ceiling((p%xyz(2) - lat%y0)/lat%width_y) - lower_univ => universes(lat % element(x,y)) - - ! adjust local position of particle - p%xyz_local(1) = p%xyz(1) - (lat%x0 + (x-0.5)*lat%width_x) - p%xyz_local(2) = p%xyz(2) - (lat%y0 + (y-0.5)*lat%width_y) - p%xyz_local(3) = p%xyz(3) - - ! set particle lattice indices - p % index_x = x - p % index_y = y - - call find_cell(lower_univ, p, found) - if (found) then - exit - else - message = "Could not locate particle in lattice: " & - & // int_to_str(lat % id) - call fatal_error() - end if - end if + do i = 1, n + ! select cells based on whether we are searching a universe or a provided + ! list of cells (this would be for lists of neighbor cells) + if (use_search_cells) then + index_cell = search_cells(i) + else + index_cell = univ % cells(i) end if + ! get pointer to cell + c => cells(index_cell) + + ! print *, 'searching cell ', c % id, cell_contains(c,p) + + if (cell_contains(c, p)) then + ! Set cell on this level + p % coord % cell = index_cell + + if (c % type == CELL_NORMAL) then + ! ================================================================= + ! AT LOWEST UNIVERSE, TERMINATE SEARCH + + ! set material + p % material = c % material + + elseif (c % type == CELL_FILL) then + ! ================================================================= + ! CELL CONTAINS LOWER UNIVERSE, RECURSIVELY FIND CELL + + ! Create new level of coordinates + p % in_lower_universe = .true. + allocate(p % coord % next) + + ! Move particle to next level and set universe + p % coord => p % coord % next + p % coord % universe = c % fill + + call find_cell(p, found) + if (.not. found) exit + + elseif (c % type == CELL_LATTICE) then + ! ================================================================= + ! CELL CONTAINS LATTICE, RECURSIVELY FIND CELL + + ! Set current lattice + lat => lattices(c % fill) + + ! determine universe based on lattice position + x = ceiling((p % coord % xyz(1) - lat % x0)/lat % width_x) + y = ceiling((p % coord % xyz(2) - lat % y0)/lat % width_y) + + ! Create new level of coordinates + p % in_lower_universe = .true. + allocate(p % coord % next) + + ! adjust local position of particle + p % coord % next % xyz(1) = p % coord % xyz(1) - & + (lat%x0 + (x-0.5_8)*lat%width_x) + p % coord % next % xyz(2) = p % coord % xyz(2) - & + (lat%y0 + (y-0.5_8)*lat%width_y) + p % coord % next % xyz(3) = p % coord % xyz(3) + p % coord % next % uvw = p % coord % uvw + + ! Move particle to next level + p % coord => p % coord % next + + ! set particle lattice indices + p % coord % lattice = c % fill + p % coord % lattice_x = x + p % coord % lattice_y = y + p % coord % universe = lat % element(x,y) + + call find_cell(p, found) + if (.not. found) exit + end if + + ! Found cell so we can return + found = .true. + return + end if end do + found = .false. + end subroutine find_cell !=============================================================================== @@ -173,10 +212,6 @@ contains type(Particle), pointer :: p integer, intent(in) :: last_cell ! last cell particle was in - integer :: i ! index of neighbors - integer :: index_cell ! index in cells array - integer :: i_x ! x index in lattice - integer :: i_y ! y index in lattice real(8) :: x ! x-x0 for sphere real(8) :: y ! y-y0 for sphere real(8) :: z ! z-z0 for sphere @@ -191,9 +226,6 @@ contains real(8) :: norm ! "norm" of surface normal logical :: found ! particle found in universe? type(Surface), pointer :: surf => null() - type(Cell), pointer :: c => null() - type(Lattice), pointer :: lat => null() - type(Universe), pointer :: lower_univ => null() surf => surfaces(abs(p % surface)) if (verbosity >= 10) then @@ -215,7 +247,7 @@ contains ! TODO: Find a better solution to score surface currents than physically ! moving the particle forward slightly - p % xyz = p % xyz + TINY_BIT * p % uvw + p % coord0 % xyz = p % coord0 % xyz + TINY_BIT * p % coord0 % uvw call score_surface_current(p) ! Display message @@ -229,25 +261,31 @@ contains ! ======================================================================= ! PARTICLE REFLECTS FROM SURFACE + ! Do not handle reflective boundary conditions on lower universes + if (p % in_lower_universe) then + message = "Cannot reflect particle off surface in a lower universe." + call fatal_error() + end if + ! Score surface currents since reflection causes the direction of the ! particle to change -- artificially move the particle slightly back in ! case the surface crossing in coincident with a mesh boundary - p % xyz = p % xyz - TINY_BIT * p % uvw + p % coord0 % xyz = p % coord0 % xyz - TINY_BIT * p % coord0 % uvw call score_surface_current(p) - p % xyz = p % xyz + TINY_BIT * p % uvw + p % coord0 % xyz = p % coord0 % xyz + TINY_BIT * p % coord0 % uvw ! Copy particle's direction cosines - u = p % uvw(1) - v = p % uvw(2) - w = p % uvw(3) + u = p % coord0 % uvw(1) + v = p % coord0 % uvw(2) + w = p % coord0 % uvw(3) select case (surf%type) case (SURF_PX) - p % uvw = (/ -u, v, w /) + p % coord0 % uvw = (/ -u, v, w /) case (SURF_PY) - p % uvw = (/ u, -v, w /) + p % coord0 % uvw = (/ u, -v, w /) case (SURF_PZ) - p % uvw = (/ u, v, -w /) + p % coord0 % uvw = (/ u, v, -w /) case (SURF_PLANE) ! Find surface coefficients and norm of vector normal to surface n1 = surf % coeffs(1) @@ -262,11 +300,11 @@ contains w = w - 2*dot_prod*n3/norm ! Set vector - p % uvw = (/ u, v, w /) + p % coord0 % uvw = (/ u, v, w /) case (SURF_CYL_X) ! Find y-y0, z-z0 and dot product of direction and surface normal - y = p % xyz(2) - surf % coeffs(1) - z = p % xyz(3) - surf % coeffs(2) + y = p % coord0 % xyz(2) - surf % coeffs(1) + z = p % coord0 % xyz(3) - surf % coeffs(2) R = surf % coeffs(3) dot_prod = v*y + w*z @@ -275,11 +313,11 @@ contains w = w - 2*dot_prod*z/(R*R) ! Set vector - p % uvw = (/ u, v, w /) + p % coord0 % uvw = (/ u, v, w /) case (SURF_CYL_Y) ! Find x-x0, z-z0 and dot product of direction and surface normal - x = p % xyz(1) - surf % coeffs(1) - z = p % xyz(3) - surf % coeffs(2) + x = p % coord0 % xyz(1) - surf % coeffs(1) + z = p % coord0 % xyz(3) - surf % coeffs(2) R = surf % coeffs(3) dot_prod = u*x + w*z @@ -288,11 +326,11 @@ contains w = w - 2*dot_prod*z/(R*R) ! Set vector - p % uvw = (/ u, v, w /) + p % coord0 % uvw = (/ u, v, w /) case (SURF_CYL_Z) ! Find x-x0, y-y0 and dot product of direction and surface normal - x = p % xyz(1) - surf % coeffs(1) - y = p % xyz(2) - surf % coeffs(2) + x = p % coord0 % xyz(1) - surf % coeffs(1) + y = p % coord0 % xyz(2) - surf % coeffs(2) R = surf % coeffs(3) dot_prod = u*x + v*y @@ -301,13 +339,13 @@ contains v = v - 2*dot_prod*y/(R*R) ! Set vector - p % uvw = (/ u, v, w /) + p % coord0 % uvw = (/ u, v, w /) case (SURF_SPHERE) ! Find x-x0, y-y0, z-z0 and dot product of direction and surface ! normal - x = p % xyz(1) - surf % coeffs(1) - y = p % xyz(2) - surf % coeffs(2) - z = p % xyz(3) - surf % coeffs(3) + x = p % coord0 % xyz(1) - surf % coeffs(1) + y = p % coord0 % xyz(2) - surf % coeffs(2) + z = p % coord0 % xyz(3) - surf % coeffs(3) R = surf % coeffs(4) dot_prod = u*x + v*y + w*z @@ -317,7 +355,7 @@ contains w = w - 2*dot_prod*z/(R*R) ! Set vector - p % uvw = (/ u, v, w /) + p % coord0 % uvw = (/ u, v, w /) case default message = "Reflection not supported for surface " // & trim(int_to_str(surf % id)) @@ -325,11 +363,11 @@ contains end select ! Reassign particle's cell and surface - p % cell = last_cell + p % coord0 % cell = last_cell p % surface = -p % surface ! Set previous coordinate going slightly past surface crossing - p % last_xyz = p % xyz + TINY_BIT * p % uvw + p % last_xyz = p % coord0 % xyz + TINY_BIT * p % coord0 % uvw ! Diagnostic message if (verbosity >= 10) then @@ -345,115 +383,30 @@ contains if (p % surface > 0 .and. allocated(surf % neighbor_pos)) then ! If coming from negative side of surface, search all the neighboring ! cells on the positive side - do i = 1, size(surf % neighbor_pos) - index_cell = surf % neighbor_pos(i) - c => cells(index_cell) - if (cell_contains(c, p)) then - if (c % type == CELL_FILL) then - lower_univ => universes(c % fill) - call find_cell(lower_univ, p, found) - if (.not. found) then - message = "Could not locate particle in universe: " - call fatal_error() - end if - elseif (c % type == CELL_LATTICE) then - ! Set current lattice - lat => lattices(c % fill) - p % lattice = c % fill + + call find_cell(p, found, surf % neighbor_pos) + if (found) return - ! determine universe based on lattice position - i_x = ceiling((p%xyz(1) - lat%x0)/lat%width_x) - i_y = ceiling((p%xyz(2) - lat%y0)/lat%width_y) - lower_univ => universes(lat % element(i_x,i_y)) - - ! adjust local position of particle - p%xyz_local(1) = p%xyz(1) - (lat%x0 + (i_x-0.5)*lat%width_x) - p%xyz_local(2) = p%xyz(2) - (lat%y0 + (i_y-0.5)*lat%width_y) - p%xyz_local(3) = p%xyz(3) - - ! set particle lattice indices - p % index_x = i_x - p % index_y = i_y - - call find_cell(lower_univ, p, found) - if (.not. found) then - message = "Could not locate particle in lattice: " // & - trim(int_to_str(lat % id)) - call fatal_error() - end if - else - ! set current pointers - p % cell = index_cell - p % material = c % material - end if - return - end if - end do elseif (p % surface < 0 .and. allocated(surf % neighbor_neg)) then ! If coming from positive side of surface, search all the neighboring ! cells on the negative side - do i = 1, size(surf % neighbor_neg) - index_cell = surf % neighbor_neg(i) - c => cells(index_cell) - if (cell_contains(c, p)) then - if (c % type == CELL_FILL) then - lower_univ => universes(c % fill) - call find_cell(lower_univ, p, found) - if (.not. found) then - message = "Could not locate particle in universe: " - call fatal_error() - end if - elseif (c % type == CELL_LATTICE) then - ! Set current lattice - lat => lattices(c % fill) - p % lattice = c % fill + + call find_cell(p, found, surf % neighbor_neg) + if (found) return - ! determine universe based on lattice position - i_x = ceiling((p%xyz(1) - lat%x0)/lat%width_x) - i_y = ceiling((p%xyz(2) - lat%y0)/lat%width_y) - lower_univ => universes(lat % element(i_x,i_y)) - - ! adjust local position of particle - p%xyz_local(1) = p%xyz(1) - (lat%x0 + (i_x-0.5)*lat%width_x) - p%xyz_local(2) = p%xyz(2) - (lat%y0 + (i_y-0.5)*lat%width_y) - p%xyz_local(3) = p%xyz(3) - - ! set particle lattice indices - p % index_x = i_x - p % index_y = i_y - - call find_cell(lower_univ, p, found) - if (.not. found) then - message = "Could not locate particle in lattice: " // & - trim(int_to_str(lat % id)) - call fatal_error() - end if - else - ! set current pointers - p % cell = index_cell - p % material = c % material - end if - return - end if - end do end if ! ========================================================================== ! COULDN'T FIND PARTICLE IN NEIGHBORING CELLS, SEARCH ALL CELLS - do i = 1, size(cells) - c => cells(i) - if (cell_contains(c, p)) then - p % cell = i - p % material = c % material - return - end if - end do + call find_cell(p, found) ! Couldn't find next cell anywhere! - message = "After particle crossed surface " // trim(int_to_str(p%surface)) & - // ", it could not be located in any cell and it did not leak." - call fatal_error() + if (.not. found) then + message = "After particle crossed surface " // trim(int_to_str(p%surface)) & + // ", it could not be located in any cell and it did not leak." + call fatal_error() + end if end subroutine cross_surface @@ -480,25 +433,24 @@ contains real(8) :: x0 ! half the width of lattice element real(8) :: y0 ! half the height of lattice element logical :: found ! particle found in cell? - type(Lattice), pointer :: lat - type(Universe), pointer :: univ + type(Lattice), pointer :: lat => null() - lat => lattices(p % lattice) + lat => lattices(p % coord % lattice) if (verbosity >= 10) then message = " Crossing lattice " // int_to_str(lat % id) call write_message() end if - u = p % uvw(1) - v = p % uvw(2) + u = p % coord % uvw(1) + v = p % coord % uvw(2) if (lat % type == LATTICE_RECT) then - x = p % xyz_local(1) - y = p % xyz_local(2) - z = p % xyz_local(3) - x0 = lat % width_x * 0.5 - y0 = lat % width_y * 0.5 + x = p % coord % xyz(1) + y = p % coord % xyz(2) + z = p % coord % xyz(3) + x0 = lat % width_x * 0.5_8 + y0 = lat % width_y * 0.5_8 dist = INFINITY @@ -523,23 +475,23 @@ contains dist = min(d_left, d_right, d_top, d_bottom) if (dist == d_left) then ! Move particle to left element - p % index_x = p % index_x - 1 - p % xyz_local(1) = x0 + p % coord % lattice_x = p % coord % lattice_x - 1 + p % coord % xyz(1) = x0 elseif (dist == d_right) then ! Move particle to right element - p % index_x = p % index_x + 1 - p % xyz_local(1) = -x0 + p % coord % lattice_x = p % coord % lattice_x + 1 + p % coord % xyz(1) = -x0 elseif (dist == d_bottom) then ! Move particle to bottom element - p % index_y = p % index_y - 1 - p % xyz_local(2) = y0 + p % coord % lattice_y = p % coord % lattice_y - 1 + p % coord % xyz(2) = y0 elseif (dist == d_top) then ! Move particle to top element - p % index_y = p % index_y + 1 - p % xyz_local(2) = -y0 + p % coord % lattice_y = p % coord % lattice_y + 1 + p % coord % xyz(2) = -y0 end if elseif (lat % type == LATTICE_HEX) then @@ -547,8 +499,8 @@ contains end if ! Check to make sure still in lattice - i_x = p % index_x - i_y = p % index_y + i_x = p % coord % lattice_x + i_y = p % coord % lattice_y if (i_x < 1 .or. i_x > lat % n_x) then message = "Reached edge of lattice " // trim(int_to_str(lat % id)) // & " at position (" // trim(int_to_str(i_x)) // "," // & @@ -562,12 +514,13 @@ contains end if ! Find universe for next lattice element - univ => universes(lat % element(i_x,i_y)) + p % coord % universe = lat % element(i_x, i_y) ! Find cell in next lattice element - call find_cell(univ, p, found) + call find_cell(p, found) if (.not. found) then - message = "Could not locate particle in universe: " + message = "Could not locate particle in universe: " // & + int_to_str(universes(p % coord % universe) % id) call fatal_error() end if @@ -579,20 +532,15 @@ contains ! that has a parent cell, also include the surfaces of the edge of the universe. !=============================================================================== - subroutine distance_to_boundary(p, dist, surf, in_lattice) + subroutine distance_to_boundary(p, dist, surface_crossed, lattice_crossed) type(Particle), pointer :: p real(8), intent(out) :: dist - integer, intent(out) :: surf - logical, intent(out) :: in_lattice + integer, intent(out) :: surface_crossed + logical, intent(out) :: lattice_crossed - integer, allocatable :: expression(:) ! copy of surface list integer :: i ! index for surface in cell - integer :: n_surf ! total number of surfaces to check - integer :: n1 ! number of surfaces in current cell - integer :: n2 ! number of surfaces in parent cell integer :: index_surf ! index in surfaces array (with sign) - integer :: current_surf ! current surface real(8) :: x,y,z ! particle coordinates real(8) :: u,v,w ! particle directions real(8) :: d ! evaluated distance @@ -602,378 +550,372 @@ contains real(8) :: a,b,c,k ! quadratic equation coefficients real(8) :: quad ! discriminant of quadratic equation logical :: on_surface ! is particle on surface? - type(Cell), pointer :: cell_p => null() - type(Cell), pointer :: parent_p => null() - type(Surface), pointer :: surf_p => null() - type(Lattice), pointer :: lat => null() - - if (p % cell == CELL_VOID) then - n_surf = n_surfaces - allocate(expression(n_surfaces)) - expression = (/ (i, i=1, n_surfaces) /) - current_surf = 0 - else - cell_p => cells(p%cell) - - current_surf = p%surface - - ! determine number of surfaces to check - n1 = cell_p % n_surfaces - n2 = 0 - if (cell_p % parent > 0) then - parent_p => cells(cell_p % parent) - n2 = parent_p % n_surfaces - end if - n_surf = n1 + n2 - - ! allocate space and assign expression - allocate(expression(n_surf)) - expression(1:n1) = cell_p % surfaces - if (cell_p % parent > 0) then - expression(n1+1:n1+n2) = parent_p % surfaces - end if - end if - - u = p % uvw(1) - v = p % uvw(2) - w = p % uvw(3) - - ! ========================================================================== - ! FIND MINIMUM DISTANCE TO SURFACES IN CELL AND PARENT + type(Cell), pointer :: cl => null() + type(Surface), pointer :: surf => null() + type(Lattice), pointer :: lat => null() + type(LocalCoord), pointer :: coord => null() + type(LocalCoord), pointer :: final_coord => null() + ! inialize distance to infinity (huge) dist = INFINITY - do i = 1, n_surf - if (i <= n1) then - ! in local cell, so use xyz_local - x = p % xyz_local(1) - y = p % xyz_local(2) - z = p % xyz_local(3) - else - ! in parent cell, so use xyz - x = p % xyz(1) - y = p % xyz(2) - z = p % xyz(3) - end if - ! check for coincident surface -- note that we can't skip the calculation - ! in general because a particle could be on one side of a cylinder and - ! still have a positive distance to the other + ! Get pointer to top-level coordinates + coord => p % coord0 - index_surf = expression(i) - if (index_surf == current_surf) then - on_surface = .true. - else - on_surface = .false. - end if + ! Loop over each universe level + LEVEL_LOOP: do while(associated(coord)) - ! check for operators - index_surf = abs(index_surf) - if (index_surf >= OP_DIFFERENCE) cycle + ! get pointer to cell on this level + cl => cells(coord % cell) - surf_p => surfaces(index_surf) - select case (surf_p%type) - case (SURF_PX) - if (on_surface .or. u == ZERO) then - d = INFINITY + ! copy directional cosines + u = coord % uvw(1) + v = coord % uvw(2) + w = coord % uvw(3) + + ! ======================================================================= + ! FIND MINIMUM DISTANCE TO SURFACE IN THIS CELL + + SURFACE_LOOP: do i = 1, cl % n_surfaces + + ! copy local coordinates of particle + x = coord % xyz(1) + y = coord % xyz(2) + z = coord % xyz(3) + + ! check for coincident surface -- note that we can't skip the + ! calculation in general because a particle could be on one side of a + ! cylinder and still have a positive distance to the other + + index_surf = cl % surfaces(i) + if (index_surf == p % surface) then + on_surface = .true. else - x0 = surf_p % coeffs(1) - d = (x0 - x)/u - if (d < ZERO) d = INFINITY - end if - - case (SURF_PY) - if (on_surface .or. v == ZERO) then - d = INFINITY - else - y0 = surf_p % coeffs(1) - d = (y0 - y)/v - if (d < ZERO) d = INFINITY - end if - - case (SURF_PZ) - if (on_surface .or. w == ZERO) then - d = INFINITY - else - z0 = surf_p % coeffs(1) - d = (z0 - z)/w - if (d < ZERO) d = INFINITY - end if - - case (SURF_PLANE) - A = surf_p % coeffs(1) - B = surf_p % coeffs(2) - C = surf_p % coeffs(3) - D = surf_p % coeffs(4) - - tmp = A*u + B*v + C*w - if (on_surface .or. tmp == ZERO) then - d = INFINITY - else - d = -(A*x + B*y + C*w - D)/tmp - if (d < ZERO) d = INFINITY + on_surface = .false. end if - case (SURF_CYL_X) - a = ONE - u*u ! v^2 + w^2 - if (a == ZERO) then - d = INFINITY - else - y0 = surf_p % coeffs(1) - z0 = surf_p % coeffs(2) - r = surf_p % coeffs(3) + ! check for operators + index_surf = abs(index_surf) + if (index_surf >= OP_DIFFERENCE) cycle - y = y - y0 - z = z - z0 - k = y*v + z*w - c = y*y + z*z - r*r - quad = k*k - a*c + ! get pointer to surface + surf => surfaces(index_surf) - if (quad < ZERO) then - ! no intersection with cylinder - - d = INFINITY - - elseif (on_surface) then - ! particle is on the cylinder, thus one distance is - ! positive/negative and the other is zero. The sign of k - ! determines if we are facing in or out - - if (k >= ZERO) then - d = INFINITY - else - d = (-k + sqrt(quad))/a - end if - - elseif (c < ZERO) then - ! particle is inside the cylinder, thus one distance must be - ! negative and one must be positive. The positive distance will - ! be the one with negative sign on sqrt(quad) - - d = (-k + sqrt(quad))/a - - else - ! particle is outside the cylinder, thus both distances are - ! either positive or negative. If positive, the smaller distance - ! is the one with positive sign on sqrt(quad) - - d = (-k - sqrt(quad))/a - if (d < ZERO) d = INFINITY - - end if - end if - - case (SURF_CYL_Y) - a = ONE - v*v ! u^2 + w^2 - if (a == ZERO) then - d = INFINITY - else - x0 = surf_p % coeffs(1) - z0 = surf_p % coeffs(2) - r = surf_p % coeffs(3) - - x = x - x0 - z = z - z0 - k = x*u + z*w - c = x*x + z*z - r*r - quad = k*k - a*c - - if (quad < ZERO) then - ! no intersection with cylinder - - d = INFINITY - - elseif (on_surface) then - ! particle is on the cylinder, thus one distance is - ! positive/negative and the other is zero. The sign of k - ! determines if we are facing in or out - - if (k >= ZERO) then - d = INFINITY - else - d = (-k + sqrt(quad))/a - end if - - elseif (c < ZERO) then - ! particle is inside the cylinder, thus one distance must be - ! negative and one must be positive. The positive distance will - ! be the one with negative sign on sqrt(quad) - - d = (-k + sqrt(quad))/a - - else - ! particle is outside the cylinder, thus both distances are - ! either positive or negative. If positive, the smaller distance - ! is the one with positive sign on sqrt(quad) - - d = (-k - sqrt(quad))/a - if (d < ZERO) d = INFINITY - - end if - end if - - case (SURF_CYL_Z) - a = ONE - w*w ! u^2 + v^2 - if (a == ZERO) then - d = INFINITY - else - x0 = surf_p % coeffs(1) - y0 = surf_p % coeffs(2) - r = surf_p % coeffs(3) - - x = x - x0 - y = y - y0 - k = x*u + y*v - c = x*x + y*y - r*r - quad = k*k - a*c - - if (quad < ZERO) then - ! no intersection with cylinder - - d = INFINITY - - elseif (on_surface) then - ! particle is on the cylinder, thus one distance is - ! positive/negative and the other is zero. The sign of k - ! determines if we are facing in or out - - if (k >= ZERO) then - d = INFINITY - else - d = (-k + sqrt(quad))/a - end if - - elseif (c < ZERO) then - ! particle is inside the cylinder, thus one distance must be - ! negative and one must be positive. The positive distance will - ! be the one with negative sign on sqrt(quad) - - d = (-k + sqrt(quad))/a - - else - ! particle is outside the cylinder, thus both distances are - ! either positive or negative. If positive, the smaller distance - ! is the one with positive sign on sqrt(quad) - - d = (-k - sqrt(quad))/a - if (d <= ZERO) d = INFINITY - - end if - end if - - case (SURF_SPHERE) - x0 = surf_p % coeffs(1) - y0 = surf_p % coeffs(2) - z0 = surf_p % coeffs(3) - r = surf_p % coeffs(4) - - x = x - x0 - y = y - y0 - z = z - z0 - k = x*u + y*v + z*w - c = x*x + y*y + z*z - r*r - quad = k*k - c - - if (quad < ZERO) then - ! no intersection with sphere - - d = INFINITY - - elseif (on_surface) then - ! particle is on the sphere, thus one distance is positive/negative - ! and the other is zero. The sign of k determines if we are facing - ! in or out - - if (k >= ZERO) then + select case (surf % type) + case (SURF_PX) + if (on_surface .or. u == ZERO) then d = INFINITY else + x0 = surf % coeffs(1) + d = (x0 - x)/u + if (d < ZERO) d = INFINITY + end if + + case (SURF_PY) + if (on_surface .or. v == ZERO) then + d = INFINITY + else + y0 = surf % coeffs(1) + d = (y0 - y)/v + if (d < ZERO) d = INFINITY + end if + + case (SURF_PZ) + if (on_surface .or. w == ZERO) then + d = INFINITY + else + z0 = surf % coeffs(1) + d = (z0 - z)/w + if (d < ZERO) d = INFINITY + end if + + case (SURF_PLANE) + A = surf % coeffs(1) + B = surf % coeffs(2) + C = surf % coeffs(3) + D = surf % coeffs(4) + + tmp = A*u + B*v + C*w + if (on_surface .or. tmp == ZERO) then + d = INFINITY + else + d = -(A*x + B*y + C*w - D)/tmp + if (d < ZERO) d = INFINITY + end if + + case (SURF_CYL_X) + a = ONE - u*u ! v^2 + w^2 + if (a == ZERO) then + d = INFINITY + else + y0 = surf % coeffs(1) + z0 = surf % coeffs(2) + r = surf % coeffs(3) + + y = y - y0 + z = z - z0 + k = y*v + z*w + c = y*y + z*z - r*r + quad = k*k - a*c + + if (quad < ZERO) then + ! no intersection with cylinder + + d = INFINITY + + elseif (on_surface) then + ! particle is on the cylinder, thus one distance is + ! positive/negative and the other is zero. The sign of k + ! determines if we are facing in or out + + if (k >= ZERO) then + d = INFINITY + else + d = (-k + sqrt(quad))/a + end if + + elseif (c < ZERO) then + ! particle is inside the cylinder, thus one distance must be + ! negative and one must be positive. The positive distance + ! will be the one with negative sign on sqrt(quad) + + d = (-k + sqrt(quad))/a + + else + ! particle is outside the cylinder, thus both distances are + ! either positive or negative. If positive, the smaller + ! distance is the one with positive sign on sqrt(quad) + + d = (-k - sqrt(quad))/a + if (d < ZERO) d = INFINITY + + end if + end if + + case (SURF_CYL_Y) + a = ONE - v*v ! u^2 + w^2 + if (a == ZERO) then + d = INFINITY + else + x0 = surf % coeffs(1) + z0 = surf % coeffs(2) + r = surf % coeffs(3) + + x = x - x0 + z = z - z0 + k = x*u + z*w + c = x*x + z*z - r*r + quad = k*k - a*c + + if (quad < ZERO) then + ! no intersection with cylinder + + d = INFINITY + + elseif (on_surface) then + ! particle is on the cylinder, thus one distance is + ! positive/negative and the other is zero. The sign of k + ! determines if we are facing in or out + + if (k >= ZERO) then + d = INFINITY + else + d = (-k + sqrt(quad))/a + end if + + elseif (c < ZERO) then + ! particle is inside the cylinder, thus one distance must be + ! negative and one must be positive. The positive distance + ! will be the one with negative sign on sqrt(quad) + + d = (-k + sqrt(quad))/a + + else + ! particle is outside the cylinder, thus both distances are + ! either positive or negative. If positive, the smaller + ! distance is the one with positive sign on sqrt(quad) + + d = (-k - sqrt(quad))/a + if (d < ZERO) d = INFINITY + + end if + end if + + case (SURF_CYL_Z) + a = ONE - w*w ! u^2 + v^2 + if (a == ZERO) then + d = INFINITY + else + x0 = surf % coeffs(1) + y0 = surf % coeffs(2) + r = surf % coeffs(3) + + x = x - x0 + y = y - y0 + k = x*u + y*v + c = x*x + y*y - r*r + quad = k*k - a*c + + if (quad < ZERO) then + ! no intersection with cylinder + + d = INFINITY + + elseif (on_surface) then + ! particle is on the cylinder, thus one distance is + ! positive/negative and the other is zero. The sign of k + ! determines if we are facing in or out + + if (k >= ZERO) then + d = INFINITY + else + d = (-k + sqrt(quad))/a + end if + + elseif (c < ZERO) then + ! particle is inside the cylinder, thus one distance must be + ! negative and one must be positive. The positive distance + ! will be the one with negative sign on sqrt(quad) + + d = (-k + sqrt(quad))/a + + else + ! particle is outside the cylinder, thus both distances are + ! either positive or negative. If positive, the smaller + ! distance is the one with positive sign on sqrt(quad) + + d = (-k - sqrt(quad))/a + if (d <= ZERO) d = INFINITY + + end if + end if + + case (SURF_SPHERE) + x0 = surf % coeffs(1) + y0 = surf % coeffs(2) + z0 = surf % coeffs(3) + r = surf % coeffs(4) + + x = x - x0 + y = y - y0 + z = z - z0 + k = x*u + y*v + z*w + c = x*x + y*y + z*z - r*r + quad = k*k - c + + if (quad < ZERO) then + ! no intersection with sphere + + d = INFINITY + + elseif (on_surface) then + ! particle is on the sphere, thus one distance is + ! positive/negative and the other is zero. The sign of k + ! determines if we are facing in or out + + if (k >= ZERO) then + d = INFINITY + else + d = -k + sqrt(quad) + end if + + elseif (c < ZERO) then + ! particle is inside the sphere, thus one distance must be + ! negative and one must be positive. The positive distance will + ! be the one with negative sign on sqrt(quad) + d = -k + sqrt(quad) + + else + ! particle is outside the sphere, thus both distances are either + ! positive or negative. If positive, the smaller distance is the + ! one with positive sign on sqrt(quad) + + d = -k - sqrt(quad) + if (d < ZERO) d = INFINITY + end if - elseif (c < ZERO) then - ! particle is inside the sphere, thus one distance must be negative - ! and one must be positive. The positive distance will be the one - ! with negative sign on sqrt(quad) + case (SURF_GQ) + message = "Surface distance not yet implement for general quadratic." + call fatal_error() - d = -k + sqrt(quad) - - else - ! particle is outside the sphere, thus both distances are either - ! positive or negative. If positive, the smaller distance is the - ! one with positive sign on sqrt(quad) - - d = -k - sqrt(quad) - if (d < ZERO) d = INFINITY - - end if - - case (SURF_GQ) - message = "Surface distance not yet implement for general quadratic." - call fatal_error() - - end select - - ! Check is calculated distance is new minimum - if (d < dist) then - dist = d - surf = -expression(i) - end if - end do - - ! ========================================================================== - ! FIND MINIMUM DISTANCE TO LATTICE SURFACES - - in_lattice = .false. - if (p % lattice > 0) then - lat => lattices(p % lattice) - if (lat % type == LATTICE_RECT) then - x = p % xyz_local(1) - y = p % xyz_local(2) - z = p % xyz_local(3) - x0 = lat % width_x * 0.5_8 - y0 = lat % width_y * 0.5_8 - - ! left and right sides - if (u > 0) then - d = (x0 - x)/u - else - d = -(x + x0)/u - end if - - ! If the lattice boundary is coincident with the parent cell boundary, - ! we need to make sure that the lattice is not selected. This is - ! complicated by the fact that floating point may determine that one - ! is closer than the other (can't check direct equality). Thus, the - ! logic here checks whether the relative difference is within floating - ! point precision. - - if (d < dist) then - if (abs(d - dist)/dist >= FP_PRECISION) then - dist = d - in_lattice = .true. - end if - end if - - ! top and bottom sides - if (v > 0) then - d = (y0 - y)/v - else - d = -(y + y0)/v - end if + end select + ! Check is calculated distance is new minimum if (d < dist) then - if (abs(d - dist)/dist >= FP_PRECISION) then - dist = d - in_lattice = .true. - end if + dist = d + surface_crossed = -cl % surfaces(i) + final_coord => coord end if - elseif (lat % type == LATTICE_HEX) then - ! TODO: Add hex lattice support - end if - end if + end do SURFACE_LOOP - ! deallocate expression - deallocate(expression) + ! ======================================================================= + ! FIND MINIMUM DISTANCE TO LATTICE SURFACES + + lattice_crossed = .false. + + if (p % coord % lattice /= NONE) then + lat => lattices(p % coord % lattice) + if (lat % type == LATTICE_RECT) then + x = p % coord % xyz(1) + y = p % coord % xyz(2) + z = p % coord % xyz(3) + x0 = lat % width_x * 0.5_8 + y0 = lat % width_y * 0.5_8 + + ! left and right sides + if (u > 0) then + d = (x0 - x)/u + else + d = -(x + x0)/u + end if + + ! If the lattice boundary is coincident with the parent cell boundary, + ! we need to make sure that the lattice is not selected. This is + ! complicated by the fact that floating point may determine that one + ! is closer than the other (can't check direct equality). Thus, the + ! logic here checks whether the relative difference is within floating + ! point precision. + + if (d < dist) then + if (abs(d - dist)/dist >= FP_PRECISION) then + dist = d + lattice_crossed = .true. + final_coord => coord + end if + end if + + ! top and bottom sides + if (v > 0) then + d = (y0 - y)/v + else + d = -(y + y0)/v + end if + + if (d < dist) then + if (abs(d - dist)/dist >= FP_PRECISION) then + dist = d + lattice_crossed = .true. + final_coord => coord + end if + end if + + elseif (lat % type == LATTICE_HEX) then + ! TODO: Add hex lattice support + end if + end if + + coord => coord % next + + end do LEVEL_LOOP + + ! Remove coordinates for any lower levels + call deallocate_coord(final_coord % next) + + ! Move particle to appropriate coordinate level + p % coord => final_coord end subroutine distance_to_boundary diff --git a/src/mpi_routines.f90 b/src/mpi_routines.f90 index 2ea05e23f..a52369477 100644 --- a/src/mpi_routines.f90 +++ b/src/mpi_routines.f90 @@ -347,16 +347,15 @@ contains i_source = i_start + i - 1 p => source_bank(i_source) - p % xyz = temp_bank(i) % xyz - p % xyz_local = temp_bank(i) % xyz - p % last_xyz = temp_bank(i) % xyz - p % uvw = temp_bank(i) % uvw - p % E = temp_bank(i) % E - p % last_E = p % E - ! set defaults call initialize_particle(p) + p % coord % xyz = temp_bank(i) % xyz + p % coord % uvw = temp_bank(i) % uvw + p % last_xyz = temp_bank(i) % xyz + p % E = temp_bank(i) % E + p % last_E = temp_bank(i) % E + end do end subroutine copy_from_bank diff --git a/src/output.f90 b/src/output.f90 index 3f52da8a0..720683ef6 100644 --- a/src/output.f90 +++ b/src/output.f90 @@ -210,44 +210,40 @@ contains case default write(ou,*) 'Unknown Particle ' // int_to_str(p % id) end select - write(ou,*) ' x = ' // real_to_str(p % xyz(1)) - write(ou,*) ' y = ' // real_to_str(p % xyz(2)) - write(ou,*) ' z = ' // real_to_str(p % xyz(3)) - write(ou,*) ' x local = ' // real_to_str(p % xyz_local(1)) - write(ou,*) ' y local = ' // real_to_str(p % xyz_local(2)) - write(ou,*) ' z local = ' // real_to_str(p % xyz_local(3)) - write(ou,*) ' u = ' // real_to_str(p % uvw(1)) - write(ou,*) ' v = ' // real_to_str(p % uvw(2)) - write(ou,*) ' w = ' // real_to_str(p % uvw(3)) + write(ou,*) ' x = ' // real_to_str(p % coord0 % xyz(1)) + write(ou,*) ' y = ' // real_to_str(p % coord0 % xyz(2)) + write(ou,*) ' z = ' // real_to_str(p % coord0 % xyz(3)) + write(ou,*) ' x local = ' // real_to_str(p % coord % xyz(1)) + write(ou,*) ' y local = ' // real_to_str(p % coord % xyz(2)) + write(ou,*) ' z local = ' // real_to_str(p % coord % xyz(3)) + write(ou,*) ' u = ' // real_to_str(p % coord0 % uvw(1)) + write(ou,*) ' v = ' // real_to_str(p % coord0 % uvw(2)) + write(ou,*) ' w = ' // real_to_str(p % coord0 % uvw(3)) write(ou,*) ' Weight = ' // real_to_str(p % wgt) write(ou,*) ' Energy = ' // real_to_str(p % E) - write(ou,*) ' x index = ' // int_to_str(p % index_x) - write(ou,*) ' y index = ' // int_to_str(p % index_y) + write(ou,*) ' x index = ' // int_to_str(p % coord % lattice_x) + write(ou,*) ' y index = ' // int_to_str(p % coord % lattice_y) write(ou,*) ' IE = ' // int_to_str(p % IE) write(ou,*) ' Interpolation factor = ' // real_to_str(p % interp) - if (p % cell > 0) then - c => cells(p % cell) + if (p % coord % cell /= NONE) then + c => cells(p % coord % cell) write(ou,*) ' Cell = ' // int_to_str(c % id) else write(ou,*) ' Cell not determined' end if - if (p % surface > 0) then + if (p % surface /= NONE) then s => surfaces(p % surface) write(ou,*) ' Surface = ' // int_to_str(s % id) else write(ou,*) ' Surface = None' end if - u => universes(p % universe) + u => universes(p % coord % universe) write(ou,*) ' Universe = ' // int_to_str(u % id) write(ou,*) - nullify(c) - nullify(s) - nullify(u) - end subroutine print_particle !=============================================================================== @@ -325,10 +321,6 @@ contains write(ou,*) ' Surface Specification:' // trim(string) write(ou,*) - ! nullify associated pointers - nullify(u) - nullify(m) - end subroutine print_cell !=============================================================================== @@ -353,8 +345,6 @@ contains write(ou,*) ' Cells =' // trim(string) write(ou,*) - nullify(c) - end subroutine print_universe !=============================================================================== @@ -485,8 +475,6 @@ contains end if write(ou,*) - nullify(nuc) - end subroutine print_material !=============================================================================== diff --git a/src/particle_header.f90 b/src/particle_header.f90 index deec93b06..64fbc2e6d 100644 --- a/src/particle_header.f90 +++ b/src/particle_header.f90 @@ -1,9 +1,33 @@ module particle_header - use constants, only: NEUTRON, ONE + use constants, only: NEUTRON, ONE, NONE + use geometry_header, only: BASE_UNIVERSE implicit none +!=============================================================================== +! LOCALCOORD describes the location of a particle local to a single +! universe. When the geometry consists of nested universes, a particle will have +! a list of coordinates in each level +!=============================================================================== + + type LocalCoord + ! Indices in various arrays for this level + integer :: cell = NONE + integer :: universe = NONE + integer :: lattice = NONE + integer :: lattice_x = NONE + integer :: lattice_y = NONE + + ! Particle position and direction for this level + real(8) :: xyz(3) + real(8) :: uvw(3) + + ! Pointers to next (lower) and previous (higher) universe + type(LocalCoord), pointer :: next => null() + type(LocalCoord), pointer :: prev => null() + end type LocalCoord + !=============================================================================== ! PARTICLE describes the state of a particle being transported through the ! geometry @@ -14,10 +38,12 @@ module particle_header integer(8) :: id ! Unique ID integer :: type ! Particle type (n, p, e, etc) - ! Physical data - real(8) :: xyz(3) ! location - real(8) :: xyz_local(3) ! local location (after transformations) - real(8) :: uvw(3) ! directional cosines + ! Particle coordinates + logical :: in_lower_universe ! is particle in lower universe? + type(LocalCoord), pointer :: coord0 ! coordinates on universe 0 + type(LocalCoord), pointer :: coord ! coordinates on lowest universe + + ! Other physical data real(8) :: wgt ! particle weight real(8) :: E ! energy real(8) :: mu ! angle of scatter @@ -36,15 +62,10 @@ module particle_header real(8) :: interp ! interpolation factor for energy grid ! Indices for various arrays - integer :: cell ! index for current cell + integer :: surface ! index for surface particle is on integer :: cell_born ! index for cell particle was born in - integer :: universe ! index for current universe - integer :: lattice ! index for current lattice - integer :: surface ! index for current surface integer :: material ! index for current material integer :: last_material ! index for last material - integer :: index_x ! lattice index for x direction - integer :: index_y ! lattice index for y direction ! Statistical data integer :: n_collision ! # of collisions @@ -66,22 +87,48 @@ contains ! passed through the fission bank to the source bank, no lookup would be ! needed at the beginning of a cycle - p % type = NEUTRON + p % type = NEUTRON + p % alive = .true. + + ! clear attributes + p % surface = NONE + p % cell_born = NONE + p % material = NONE + p % last_material = NONE p % wgt = ONE p % last_wgt = ONE - p % alive = .true. p % n_bank = 0 - p % cell = 0 - p % cell_born = 0 - p % universe = 0 - p % lattice = 0 - p % surface = 0 - p % material = 0 - p % last_material = 0 - p % index_x = 0 - p % index_y = 0 p % n_collision = 0 + ! remove any original coordinates + call deallocate_coord(p % coord0) + + ! Set up base level coordinates + allocate(p % coord0) + p % coord0 % universe = BASE_UNIVERSE + p % coord => p % coord0 + p % in_lower_universe = .false. + end subroutine initialize_particle +!=============================================================================== +! DEALLOCATE_COORD removes all levels of coordinates below a given level. This +! is used in distance_to_boundary when the particle moves from a lower universe +! to a higher universe since the data for the lower one is not needed anymore. +!=============================================================================== + + recursive subroutine deallocate_coord(coord) + + type(LocalCoord), pointer :: coord + + if (associated(coord)) then + ! recursively deallocate lower coordinates + if (associated(coord % next)) call deallocate_coord(coord%next) + + ! deallocate original coordinate + deallocate(coord) + end if + + end subroutine deallocate_coord + end module particle_header diff --git a/src/physics.f90 b/src/physics.f90 index 420d0f4a2..2b911329d 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -11,7 +11,7 @@ module physics use global use interpolation, only: interpolate_tab1 use output, only: write_message, print_particle - use particle_header, only: Particle + use particle_header, only: Particle, LocalCoord use random_lcg, only: prn use search, only: binary_search use string, only: int_to_str @@ -29,29 +29,27 @@ contains type(Particle), pointer :: p - integer :: surf ! surface which particle is on - integer :: last_cell ! most recent cell particle was in - integer :: n_event ! number of collisions/crossings - real(8) :: d_boundary ! distance to nearest boundary - real(8) :: d_collision ! sampled distance to collision - real(8) :: distance ! distance particle travels - logical :: found_cell ! found cell which particle is in? - logical :: in_lattice ! is surface crossing in lattice? - type(Universe), pointer :: univ + integer :: surface_crossed ! surface which particle is on + integer :: last_cell ! most recent cell particle was in + integer :: n_event ! number of collisions/crossings + real(8) :: d_boundary ! distance to nearest boundary + real(8) :: d_collision ! sampled distance to collision + real(8) :: distance ! distance particle travels + logical :: found_cell ! found cell which particle is in? + logical :: lattice_crossed ! is surface crossing in lattice? + type(LocalCoord), pointer :: coord - if (p % cell == 0) then - univ => universes(BASE_UNIVERSE) - call find_cell(univ, p, found_cell) - - ! if particle couldn't be located, print error + if (p % coord % cell == NONE) then + call find_cell(p, found_cell) + ! Particle couldn't be located if (.not. found_cell) then write(message, '(A,3ES11.3)') & - "Could not locate cell for particle at: ", p % xyz + "Could not locate cell for particle at: ", p % coord0 % xyz call fatal_error() end if ! set birth cell attribute - p % cell_born = p % cell + p % cell_born = p % coord % cell end if if (verbosity >= 9) then @@ -60,7 +58,8 @@ contains end if if (verbosity >= 10) then - message = " Born in cell " // trim(int_to_str(cells(p%cell)%id)) + message = " Born in cell " // trim(int_to_str(& + cells(p % coord % cell) % id)) call write_message() end if @@ -74,7 +73,7 @@ contains call calculate_xs(p) ! Find the distance to the nearest boundary - call distance_to_boundary(p, d_boundary, surf, in_lattice) + call distance_to_boundary(p, d_boundary, surface_crossed, lattice_crossed) ! Sample a distance to collision d_collision = -log(prn()) / material_xs % total @@ -83,26 +82,37 @@ contains distance = min(d_boundary, d_collision) ! Advance particle - p % xyz = p % xyz + distance * p % uvw - p % xyz_local = p % xyz_local + distance * p % uvw + coord => p % coord0 + do while (associated(coord)) + coord % xyz = coord % xyz + distance * coord % uvw + coord => coord % next + end do if (d_collision > d_boundary) then - last_cell = p % cell - p % cell = 0 - if (in_lattice) then - p % surface = 0 + last_cell = p % coord % cell + p % coord % cell = NONE + if (lattice_crossed) then + p % surface = NONE call cross_lattice(p) else - p % surface = surf + p % surface = surface_crossed call cross_surface(p, last_cell) end if else ! collision - p % surface = 0 + p % surface = NONE call collision(p) ! Save coordinates at collision for tallying purposes - p % last_xyz = p % xyz + p % last_xyz = p % coord % xyz + + ! Set all uvws to base level -- right now, after a collision, only the + ! base level uvws are changed + coord => p % coord0 + do while(associated(coord)) + coord % uvw = p % coord0 % uvw + coord => coord % next + end do end if ! If particle has too many events, display warning and kill it @@ -712,7 +722,7 @@ contains awr = nuc % awr ! Neutron velocity in LAB - v_n = vel * p % uvw + v_n = vel * p % coord0 % uvw ! Sample velocity of target nucleus call sample_target_velocity(p, nuc, v_t) @@ -750,7 +760,7 @@ contains ! Set energy and direction of particle in LAB frame p % E = E - p % uvw = v_n / vel + p % coord0 % uvw = v_n / vel ! Copy scattering cosine for tallies p % mu = mu @@ -902,13 +912,13 @@ contains end if ! copy directional cosines - u = p % uvw(1) - v = p % uvw(2) - w = p % uvw(3) + u = p % coord0 % uvw(1) + v = p % coord0 % uvw(2) + w = p % coord0 % uvw(3) ! change direction of particle call rotate_angle(u, v, w, mu) - p % uvw = (/ u, v, w /) + p % coord0 % uvw = (/ u, v, w /) ! change energy of particle p % E = E @@ -993,9 +1003,9 @@ contains ! determine direction of target velocity based on the neutron's velocity ! vector and the sampled angle between them - u = p % uvw(1) - v = p % uvw(2) - w = p % uvw(3) + u = p % coord0 % uvw(1) + v = p % coord0 % uvw(2) + w = p % coord0 % uvw(3) call rotate_angle(u, v, w, mu) ! determine speed of target nucleus @@ -1093,7 +1103,7 @@ contains do i = int(n_bank,4) + 1, int(min(n_bank + nu, 3*work),4) ! Bank source neutrons by copying particle data fission_bank(i) % id = p % id - fission_bank(i) % xyz = p % xyz + fission_bank(i) % xyz = p % coord0 % xyz ! sample cosine of angle mu = sample_angle(rxn, E) @@ -1250,13 +1260,13 @@ contains end if ! copy directional cosines - u = p % uvw(1) - v = p % uvw(2) - w = p % uvw(3) + u = p % coord0 % uvw(1) + v = p % coord0 % uvw(2) + w = p % coord0 % uvw(3) ! change direction of particle call rotate_angle(u, v, w, mu) - p % uvw = (/ u, v, w /) + p % coord0 % uvw = (/ u, v, w /) ! change energy of particle p % E = E diff --git a/src/plot.f90 b/src/plot.f90 index 41cc72668..79a08cd70 100644 --- a/src/plot.f90 +++ b/src/plot.f90 @@ -6,7 +6,7 @@ module plot cross_lattice, cell_contains use geometry_header, only: Universe, BASE_UNIVERSE use global - use particle_header, only: Particle, initialize_particle + use particle_header, only: Particle, initialize_particle, LocalCoord implicit none @@ -18,20 +18,21 @@ contains subroutine run_plot() - integer :: i ! loop index - integer :: surf ! surface which particle is on - integer :: last_cell ! most recent cell particle was in - real(8) :: coord(3) ! starting coordinates - real(8) :: last_x_coord ! bounding x coordinate - real(8) :: last_y_coord ! bounding y coordinate - real(8) :: d ! distance to boundary - real(8) :: distance ! distance particle travels - logical :: found_cell ! found cell which particle is in? - logical :: in_lattice ! is surface crossing in lattice? + integer :: i ! loop index + integer :: surface_crossed ! surface which particle is on + integer :: last_cell ! most recent cell particle was in + real(8) :: xyz(3) ! starting coordinates + real(8) :: last_x_coord ! bounding x coordinate + real(8) :: last_y_coord ! bounding y coordinate + real(8) :: d ! distance to boundary + real(8) :: distance ! distance particle travels + logical :: found_cell ! found cell which particle is in? + logical :: lattice_crossed ! is surface crossing in lattice? character(MAX_LINE_LEN) :: path_plot ! unit for binary plot file - type(Cell), pointer :: c => null() - type(Universe), pointer :: univ => null() - type(Particle), pointer :: p => null() + type(Cell), pointer :: c => null() + type(Universe), pointer :: univ => null() + type(Particle), pointer :: p => null() + type(LocalCoord), pointer :: coord => null() ! Open plot file for binary writing path_plot = trim(path_input) // "plot.out" @@ -44,9 +45,9 @@ contains write(UNIT=UNIT_PLOT) pixel ! Determine coordinates of the upper-left corner of the plot - coord(1) = plot_origin(1) - plot_width(1) / 2.0 - coord(2) = plot_origin(2) + (plot_width(2) - pixel) / 2.0 - coord(3) = plot_origin(3) + xyz(1) = plot_origin(1) - plot_width(1) / 2.0 + xyz(2) = plot_origin(2) + (plot_width(2) - pixel) / 2.0 + xyz(3) = plot_origin(3) ! Determine bounding x and y coordinates for plot last_x_coord = plot_origin(1) + plot_width(1) / 2.0 @@ -56,76 +57,75 @@ contains allocate(p) ! loop over horizontal rays - do while(coord(2) > last_y_coord) + do while(xyz(2) > last_y_coord) ! initialize the particle and set starting coordinate and direction call initialize_particle(p) - p % xyz = coord - p % xyz_local = coord - p % uvw = (/ 1, 0, 0 /) + + p % coord % xyz = xyz + p % coord % uvw = (/ 1, 0, 0 /) ! write starting coordinate to file - write(UNIT=UNIT_PLOT) p % xyz + write(UNIT=UNIT_PLOT) p % coord % xyz ! Find cell that particle is currently in - univ => universes(BASE_UNIVERSE) - call find_cell(univ, p, found_cell) + call find_cell(p, found_cell) ! ======================================================================= ! MOVE PARTICLE FORWARD TO NEXT CELL - if (.not. found_cell) then - univ => universes(BASE_UNIVERSE) - do i = 1, univ % n_cells - p % xyz = coord - p % xyz_local = coord - p % cell = univ % cells(i) - - distance = INFINITY - call distance_to_boundary(p, d, surf, in_lattice) - if (d < distance) then - ! Move particle forward to next surface - p % xyz = p % xyz + d * p % uvw - - ! Check to make sure particle is actually going into this cell - ! by moving it slightly forward and seeing if the cell contains - ! that coordinate - - p % xyz = p % xyz + 1e-4 * p % uvw - p % xyz_local = p % xyz - - c => cells(p % cell) - if (.not. cell_contains(c, p)) cycle - - ! Reset coordinate to surface crossing - p % xyz = p % xyz - 1e-4 * p % uvw - p % xyz_local = p % xyz - - ! Set new distance and retain pointer to this cell - distance = d - last_cell = p % cell - end if - end do - - ! No cell was found on this horizontal ray - if (distance == INFINITY) then - p % xyz(1) = last_x_coord - p % cell = 0 - write(UNIT_PLOT) p % xyz, p % cell - - ! Move to next horizontal ray - coord(2) = coord(2) - pixel - cycle - end if - - ! Write coordinate where next cell begins - write(UNIT=UNIT_PLOT) p % xyz, 0 - - ! Process surface crossing for next cell - p % cell = 0 - p % surface = -surf - call cross_surface(p, last_cell) - end if +!!$ if (.not. found_cell) then +!!$ univ => universes(BASE_UNIVERSE) +!!$ do i = 1, univ % n_cells +!!$ p % xyz = coord +!!$ p % xyz_local = coord +!!$ p % cell = univ % cells(i) +!!$ +!!$ distance = INFINITY +!!$ ! call distance_to_boundary(p, d, surf, in_lattice) +!!$ if (d < distance) then +!!$ ! Move particle forward to next surface +!!$ p % xyz = p % xyz + d * p % uvw +!!$ +!!$ ! Check to make sure particle is actually going into this cell +!!$ ! by moving it slightly forward and seeing if the cell contains +!!$ ! that coordinate +!!$ +!!$ p % xyz = p % xyz + 1e-4 * p % uvw +!!$ p % xyz_local = p % xyz +!!$ +!!$ c => cells(p % cell) +!!$ if (.not. cell_contains(c, p)) cycle +!!$ +!!$ ! Reset coordinate to surface crossing +!!$ p % xyz = p % xyz - 1e-4 * p % uvw +!!$ p % xyz_local = p % xyz +!!$ +!!$ ! Set new distance and retain pointer to this cell +!!$ distance = d +!!$ last_cell = p % cell +!!$ end if +!!$ end do +!!$ +!!$ ! No cell was found on this horizontal ray +!!$ if (distance == INFINITY) then +!!$ p % xyz(1) = last_x_coord +!!$ p % cell = 0 +!!$ write(UNIT_PLOT) p % xyz, p % cell +!!$ +!!$ ! Move to next horizontal ray +!!$ xyz(2) = xyz(2) - pixel +!!$ cycle +!!$ end if +!!$ +!!$ ! Write coordinate where next cell begins +!!$ write(UNIT=UNIT_PLOT) p % xyz, 0 +!!$ +!!$ ! Process surface crossing for next cell +!!$ p % cell = 0 +!!$ p % surface = -surf +!!$ call cross_surface(p, last_cell) +!!$ end if ! ======================================================================= ! MOVE PARTICLE ACROSS HORIZONTAL TRACK @@ -133,43 +133,46 @@ contains do while (p % alive) ! Calculate distance to next boundary - call distance_to_boundary(p, distance, surf, in_lattice) + call distance_to_boundary(p, distance, surface_crossed, lattice_crossed) ! Advance particle - p%xyz = p%xyz + distance * p%uvw - p%xyz_local = p%xyz_local + distance * p%uvw + coord => p % coord0 + do while (associated(coord)) + coord % xyz = coord % xyz + distance * coord % uvw + coord => coord % next + end do ! If next boundary crossing is out of range of the plot, only include ! the visible portion and move to next horizontal ray - if (p % xyz(1) >= last_x_coord) then + if (p % coord0 % xyz(1) >= last_x_coord) then p % alive = .false. - p % xyz(1) = last_x_coord + p % coord0 % xyz(1) = last_x_coord ! If there is no cell beyond this boundary, mark it as cell 0 - if (distance == INFINITY) p % cell = 0 + if (distance == INFINITY) p % coord % cell = 0 ! Write ending coordinates to file - write(UNIT=UNIT_PLOT) p % xyz, p % cell + write(UNIT=UNIT_PLOT) p % coord0 % xyz, p % coord % cell cycle end if ! Write boundary crossing coordinates to file - write(UNIT=UNIT_PLOT) p % xyz, p % cell + write(UNIT=UNIT_PLOT) p % coord0 % xyz, p % coord % cell - last_cell = p % cell - p % cell = 0 - if (in_lattice) then - p % surface = 0 + last_cell = p % coord % cell + p % coord % cell = 0 + if (lattice_crossed) then + p % surface = NONE call cross_lattice(p) else - p % surface = surf + p % surface = surface_crossed call cross_surface(p, last_cell) ! Since boundary conditions are disabled in plotting mode, we need ! to manually add the last segment - if (surfaces(surf) % bc == BC_VACUUM) then - p % xyz(1) = last_x_coord - write(UNIT=UNIT_PLOT) p % xyz, 0 + if (surfaces(surface_crossed) % bc == BC_VACUUM) then + p % coord0 % xyz(1) = last_x_coord + write(UNIT=UNIT_PLOT) p % coord0 % xyz, 0 exit end if end if @@ -177,7 +180,7 @@ contains end do ! Move y-coordinate to next position - coord(2) = coord(2) - pixel + xyz(2) = xyz(2) - pixel end do ! Close plot file diff --git a/src/source.f90 b/src/source.f90 index f91679593..08d3b6195 100644 --- a/src/source.f90 +++ b/src/source.f90 @@ -79,25 +79,24 @@ contains do j = bank_first, bank_last p => source_bank(j - bank_first + 1) + ! set defaults + call initialize_particle(p) + ! initialize random number seed call set_particle_seed(int(j,8)) ! sample position r = (/ (prn(), k = 1,3) /) p % id = j - p % xyz = p_min + r*(p_max - p_min) - p % xyz_local = p % xyz - p % last_xyz = p % xyz + p % coord0 % xyz = p_min + r*(p_max - p_min) + p % last_xyz = p % coord0 % xyz ! sample angle phi = TWO*PI*prn() mu = TWO*prn() - ONE - p % uvw(1) = mu - p % uvw(2) = sqrt(ONE - mu*mu) * cos(phi) - p % uvw(3) = sqrt(ONE - mu*mu) * sin(phi) - - ! set defaults - call initialize_particle(p) + p % coord0 % uvw(1) = mu + p % coord0 % uvw(2) = sqrt(ONE - mu*mu) * cos(phi) + p % coord0 % uvw(3) = sqrt(ONE - mu*mu) * sin(phi) ! sample energy from Watt fission energy spectrum for U-235 do diff --git a/src/tally.f90 b/src/tally.f90 index ca9f0eb26..253e040d7 100644 --- a/src/tally.f90 +++ b/src/tally.f90 @@ -343,7 +343,7 @@ contains ! determine next universe bin if (t % n_bins(T_UNIVERSE) > 0) then - bins(T_UNIVERSE) = get_next_bin(T_UNIVERSE, p % universe, i) + bins(T_UNIVERSE) = get_next_bin(T_UNIVERSE, p % coord % universe, i) if (bins(T_UNIVERSE) == NO_BIN_FOUND) cycle else bins(T_UNIVERSE) = 1 @@ -359,7 +359,7 @@ contains ! determine next cell bin if (t % n_bins(T_CELL) > 0) then - bins(T_CELL) = get_next_bin(T_CELL, p % cell, i) + bins(T_CELL) = get_next_bin(T_CELL, p % coord % cell, i) if (bins(T_CELL) == NO_BIN_FOUND) cycle else bins(T_CELL) = 1 @@ -386,7 +386,7 @@ contains m => meshes(t % mesh) ! Determine if we're in the mesh first - call get_mesh_bin(m, p % xyz, mesh_bin, in_mesh) + call get_mesh_bin(m, p % coord0 % xyz, mesh_bin, in_mesh) if (.not. in_mesh) cycle bins(T_MESH) = mesh_bin @@ -610,7 +610,7 @@ contains do i = 1, n_tallies ! Copy starting and ending location of particle xyz0 = p % last_xyz - xyz1 = p % xyz + xyz1 = p % coord0 % xyz ! Get pointer to tally t => tallies(i) @@ -631,7 +631,7 @@ contains if (n_cross == 0) cycle ! Copy particle's direction - uvw = p % uvw + uvw = p % coord0 % uvw ! determine incoming energy bin n = t % n_bins(T_ENERGYIN) From 76ed79fc215fd1ab7a56d8853ad81f8f91af57bb Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Fri, 2 Dec 2011 03:44:38 -0500 Subject: [PATCH 41/70] Updated lattice example with simple and nested versions. --- examples/lattice/geometry.xml | 58 ---------------------- examples/lattice/materials.xml | 17 ------- examples/lattice/nested/geometry.xml | 45 +++++++++++++++++ examples/lattice/nested/materials.xml | 19 +++++++ examples/lattice/nested/plot.xml | 6 +++ examples/lattice/{ => nested}/settings.xml | 9 ++-- examples/lattice/nested/tallies.xml | 19 +++++++ examples/lattice/simple/geometry.xml | 33 ++++++++++++ examples/lattice/simple/materials.xml | 19 +++++++ examples/lattice/simple/plot.xml | 6 +++ examples/lattice/simple/settings.xml | 19 +++++++ examples/lattice/simple/tallies.xml | 19 +++++++ 12 files changed, 188 insertions(+), 81 deletions(-) delete mode 100644 examples/lattice/geometry.xml delete mode 100644 examples/lattice/materials.xml create mode 100644 examples/lattice/nested/geometry.xml create mode 100644 examples/lattice/nested/materials.xml create mode 100644 examples/lattice/nested/plot.xml rename examples/lattice/{ => nested}/settings.xml (63%) create mode 100644 examples/lattice/nested/tallies.xml create mode 100644 examples/lattice/simple/geometry.xml create mode 100644 examples/lattice/simple/materials.xml create mode 100644 examples/lattice/simple/plot.xml create mode 100644 examples/lattice/simple/settings.xml create mode 100644 examples/lattice/simple/tallies.xml diff --git a/examples/lattice/geometry.xml b/examples/lattice/geometry.xml deleted file mode 100644 index 8848e6810..000000000 --- a/examples/lattice/geometry.xml +++ /dev/null @@ -1,58 +0,0 @@ - - - - - 0 - 111 - 1 -2 3 -4 - - - 3 - 40 - -5 - - - 3 - 41 - 5 - - - - rectangular - 20 20 - -10.0 -10.0 - 1.0 1.0 - - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 - - - - - - - - - z-cylinder - 0.0 0.0 0.4 - - - diff --git a/examples/lattice/materials.xml b/examples/lattice/materials.xml deleted file mode 100644 index 88e20c69e..000000000 --- a/examples/lattice/materials.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - - - - - - - - - - - - - - diff --git a/examples/lattice/nested/geometry.xml b/examples/lattice/nested/geometry.xml new file mode 100644 index 000000000..4ce62280a --- /dev/null +++ b/examples/lattice/nested/geometry.xml @@ -0,0 +1,45 @@ + + + + + + + + + + + + + + + rectangular + 2 2 + -1.0 -1.0 + 1.0 1.0 + + 1 2 + 2 3 + + + + + + rectangular + 2 2 + -2.0 -2.0 + 2.0 2.0 + + 5 5 + 5 5 + + + + + + + + + + + + diff --git a/examples/lattice/nested/materials.xml b/examples/lattice/nested/materials.xml new file mode 100644 index 000000000..3605c3ed6 --- /dev/null +++ b/examples/lattice/nested/materials.xml @@ -0,0 +1,19 @@ + + + + 70c + + + + + + + + + + + + + + + diff --git a/examples/lattice/nested/plot.xml b/examples/lattice/nested/plot.xml new file mode 100644 index 000000000..d6a0ca3cd --- /dev/null +++ b/examples/lattice/nested/plot.xml @@ -0,0 +1,6 @@ + + + 0. 0. 0. + 3.999 3.999 + 0.01 + diff --git a/examples/lattice/settings.xml b/examples/lattice/nested/settings.xml similarity index 63% rename from examples/lattice/settings.xml rename to examples/lattice/nested/settings.xml index adbec19c7..aa0b98ee4 100644 --- a/examples/lattice/settings.xml +++ b/examples/lattice/nested/settings.xml @@ -1,11 +1,6 @@ - - - /home/paulromano/openmc/cross_sections_serpent.xml - - 20 @@ -13,10 +8,12 @@ 10000 + 7 + box - -4 -4 -4 4 4 4 + -1 -1 -1 1 1 1 diff --git a/examples/lattice/nested/tallies.xml b/examples/lattice/nested/tallies.xml new file mode 100644 index 000000000..a389dc905 --- /dev/null +++ b/examples/lattice/nested/tallies.xml @@ -0,0 +1,19 @@ + + + + + rectangular + 4 4 + -2.0 -2.0 + 1.0 1.0 + + + + + 1 + + + total + + + \ No newline at end of file diff --git a/examples/lattice/simple/geometry.xml b/examples/lattice/simple/geometry.xml new file mode 100644 index 000000000..4a7722939 --- /dev/null +++ b/examples/lattice/simple/geometry.xml @@ -0,0 +1,33 @@ + + + + + + + + + + + + + rectangular + 4 4 + -2.0 -2.0 + 1.0 1.0 + + 1 2 1 2 + 2 3 2 3 + 1 2 1 2 + 2 3 2 3 + + + + + + + + + + + + diff --git a/examples/lattice/simple/materials.xml b/examples/lattice/simple/materials.xml new file mode 100644 index 000000000..3605c3ed6 --- /dev/null +++ b/examples/lattice/simple/materials.xml @@ -0,0 +1,19 @@ + + + + 70c + + + + + + + + + + + + + + + diff --git a/examples/lattice/simple/plot.xml b/examples/lattice/simple/plot.xml new file mode 100644 index 000000000..d6a0ca3cd --- /dev/null +++ b/examples/lattice/simple/plot.xml @@ -0,0 +1,6 @@ + + + 0. 0. 0. + 3.999 3.999 + 0.01 + diff --git a/examples/lattice/simple/settings.xml b/examples/lattice/simple/settings.xml new file mode 100644 index 000000000..aa0b98ee4 --- /dev/null +++ b/examples/lattice/simple/settings.xml @@ -0,0 +1,19 @@ + + + + + + 20 + 10 + 10000 + + + 7 + + + + box + -1 -1 -1 1 1 1 + + + diff --git a/examples/lattice/simple/tallies.xml b/examples/lattice/simple/tallies.xml new file mode 100644 index 000000000..a389dc905 --- /dev/null +++ b/examples/lattice/simple/tallies.xml @@ -0,0 +1,19 @@ + + + + + rectangular + 4 4 + -2.0 -2.0 + 1.0 1.0 + + + + + 1 + + + total + + + \ No newline at end of file From 18584b6781654fd61f1c2def65f0c589b353c988 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Fri, 2 Dec 2011 09:46:13 -0500 Subject: [PATCH 42/70] Fixed active cycle timer. --- src/main.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main.f90 b/src/main.f90 index 6e97bda15..8d8efbc61 100644 --- a/src/main.f90 +++ b/src/main.f90 @@ -61,7 +61,6 @@ contains if (master) call header("BEGIN SIMULATION", 1) tallies_on = .false. - call timer_start(time_active) call timer_start(time_inactive) ! ========================================================================== @@ -125,6 +124,7 @@ contains if (i_cycle == n_inactive) then tallies_on = .true. call timer_stop(time_inactive) + call timer_start(time_active) end if ! Stop timer for inter-cycle synchronization From ba8169883f709608d1a65656a5fa61aef3ae1d67 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Fri, 2 Dec 2011 11:41:56 -0500 Subject: [PATCH 43/70] Enhanced output from print_particle to display multiple universe levels. --- src/DEPENDENCIES | 1 + src/output.f90 | 78 ++++++++++++++++++++++++++++++------------------ 2 files changed, 50 insertions(+), 29 deletions(-) diff --git a/src/DEPENDENCIES b/src/DEPENDENCIES index 85c031858..5290410fc 100644 --- a/src/DEPENDENCIES +++ b/src/DEPENDENCIES @@ -136,6 +136,7 @@ output.o: endf.o output.o: geometry_header.o output.o: global.o output.o: mesh_header.o +output.o: particle_header.o output.o: string.o output.o: tally_header.o diff --git a/src/output.f90 b/src/output.f90 index 720683ef6..f0f7d6c9a 100644 --- a/src/output.f90 +++ b/src/output.f90 @@ -9,6 +9,7 @@ module output use geometry_header, only: Cell, Universe, Surface use global use mesh_header, only: StructuredMesh + use particle_header, only: Particle, LocalCoord use string, only: upper_case, int_to_str, real_to_str use tally_header, only: TallyObject @@ -194,12 +195,16 @@ contains subroutine print_particle(p) - type(Particle), pointer :: p + type(Particle), pointer :: p - type(Cell), pointer :: c => null() - type(Surface), pointer :: s => null() - type(Universe), pointer :: u => null() + integer :: i + type(Cell), pointer :: c => null() + type(Surface), pointer :: s => null() + type(Universe), pointer :: u => null() + type(Lattice), pointer :: l => null() + type(LocalCoord), pointer :: coord => null() + ! display type of particle select case (p % type) case (NEUTRON) write(ou,*) 'Neutron ' // int_to_str(p % id) @@ -210,38 +215,53 @@ contains case default write(ou,*) 'Unknown Particle ' // int_to_str(p % id) end select - write(ou,*) ' x = ' // real_to_str(p % coord0 % xyz(1)) - write(ou,*) ' y = ' // real_to_str(p % coord0 % xyz(2)) - write(ou,*) ' z = ' // real_to_str(p % coord0 % xyz(3)) - write(ou,*) ' x local = ' // real_to_str(p % coord % xyz(1)) - write(ou,*) ' y local = ' // real_to_str(p % coord % xyz(2)) - write(ou,*) ' z local = ' // real_to_str(p % coord % xyz(3)) - write(ou,*) ' u = ' // real_to_str(p % coord0 % uvw(1)) - write(ou,*) ' v = ' // real_to_str(p % coord0 % uvw(2)) - write(ou,*) ' w = ' // real_to_str(p % coord0 % uvw(3)) - write(ou,*) ' Weight = ' // real_to_str(p % wgt) - write(ou,*) ' Energy = ' // real_to_str(p % E) - write(ou,*) ' x index = ' // int_to_str(p % coord % lattice_x) - write(ou,*) ' y index = ' // int_to_str(p % coord % lattice_y) - write(ou,*) ' IE = ' // int_to_str(p % IE) - write(ou,*) ' Interpolation factor = ' // real_to_str(p % interp) - if (p % coord % cell /= NONE) then - c => cells(p % coord % cell) - write(ou,*) ' Cell = ' // int_to_str(c % id) - else - write(ou,*) ' Cell not determined' - end if + ! loop through each level of universes + coord => p % coord0 + i = 0 + do while(associated(coord)) + ! Print level + write(ou,*) ' Level ' // trim(int_to_str(i)) + ! Print cell for this level + if (coord % cell /= NONE) then + c => cells(coord % cell) + write(ou,*) ' Cell = ' // trim(int_to_str(c % id)) + end if + + ! Print universe for this level + if (coord % universe /= NONE) then + u => universes(coord % universe) + write(ou,*) ' Universe = ' // trim(int_to_str(u % id)) + end if + + ! Print information on lattice + if (coord % lattice /= NONE) then + l => lattices(coord % lattice) + write(ou,*) ' Lattice = ' // trim(int_to_str(l % id)) + write(ou,*) ' Lattice position = (' // trim(int_to_str(& + p % coord % lattice_x)) // ',' // trim(int_to_str(& + p % coord % lattice_y)) // ')' + end if + + ! Print local coordinates + write(ou,'(1X,A,3ES11.4)') ' xyz = ', coord % xyz + write(ou,'(1X,A,3ES11.4)') ' uvw = ', coord % uvw + + coord => coord % next + i = i + 1 + end do + + ! Print surface if (p % surface /= NONE) then s => surfaces(p % surface) write(ou,*) ' Surface = ' // int_to_str(s % id) - else - write(ou,*) ' Surface = None' end if - u => universes(p % coord % universe) - write(ou,*) ' Universe = ' // int_to_str(u % id) + write(ou,*) ' Weight = ' // real_to_str(p % wgt) + write(ou,*) ' Energy = ' // real_to_str(p % E) + write(ou,*) ' IE = ' // int_to_str(p % IE) + write(ou,*) ' Interpolation factor = ' // real_to_str(p % interp) write(ou,*) end subroutine print_particle From a26ea65f2cc742a99b40f54e8c207fae396fb3d1 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Fri, 2 Dec 2011 11:51:52 -0500 Subject: [PATCH 44/70] Fixed geometry errors and plotting routine. --- src/geometry.f90 | 49 ++++++++++++++++++++++++++--------------- src/particle_header.f90 | 6 ++--- src/physics.f90 | 4 ++-- src/plot.f90 | 13 ++++++----- 4 files changed, 44 insertions(+), 28 deletions(-) diff --git a/src/geometry.f90 b/src/geometry.f90 index ee81c9d9b..bdcc6c741 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -101,11 +101,15 @@ contains integer :: y ! y-index for lattice integer :: n ! number of cells to search integer :: index_cell ! index in cells array + real(8) :: xyz(3) ! temporary location logical :: use_search_cells ! use cells provided as argument type(Cell), pointer :: c ! pointer to cell type(Lattice), pointer :: lat ! pointer to lattice type(Universe), pointer :: univ ! universe to search in + ! Remove coordinates for any lower levels + call deallocate_coord(p % coord % next) + ! set size of list to search if (present(search_cells)) then use_search_cells = .true. @@ -128,8 +132,6 @@ contains ! get pointer to cell c => cells(index_cell) - ! print *, 'searching cell ', c % id, cell_contains(c,p) - if (cell_contains(c, p)) then ! Set cell on this level p % coord % cell = index_cell @@ -164,8 +166,9 @@ contains lat => lattices(c % fill) ! determine universe based on lattice position - x = ceiling((p % coord % xyz(1) - lat % x0)/lat % width_x) - y = ceiling((p % coord % xyz(2) - lat % y0)/lat % width_y) + xyz = p % coord % xyz + TINY_BIT * p % coord % uvw + x = ceiling((xyz(1) - lat % x0)/lat % width_x) + y = ceiling((xyz(2) - lat % y0)/lat % width_y) ! Create new level of coordinates p % in_lower_universe = .true. @@ -455,7 +458,10 @@ contains dist = INFINITY ! left and right sides - if (u > 0) then + if (u == ZERO) then + d_left = INFINITY + d_right = INFINITY + elseif (u > 0) then d_left = INFINITY d_right = (x0 - x)/u else @@ -464,7 +470,10 @@ contains end if ! top and bottom sides - if (v > 0) then + if (v == ZERO) then + d_bottom = INFINITY + d_top = INFINITY + elseif (v > 0) then d_bottom = INFINITY d_top = (y0 - y)/v else @@ -558,6 +567,7 @@ contains ! inialize distance to infinity (huge) dist = INFINITY + lattice_crossed = .false. ! Get pointer to top-level coordinates coord => p % coord0 @@ -846,6 +856,7 @@ contains if (d < dist) then dist = d surface_crossed = -cl % surfaces(i) + lattice_crossed = .false. final_coord => coord end if @@ -854,19 +865,22 @@ contains ! ======================================================================= ! FIND MINIMUM DISTANCE TO LATTICE SURFACES - lattice_crossed = .false. - - if (p % coord % lattice /= NONE) then - lat => lattices(p % coord % lattice) + if (coord % lattice /= NONE) then + lat => lattices(coord % lattice) if (lat % type == LATTICE_RECT) then - x = p % coord % xyz(1) - y = p % coord % xyz(2) - z = p % coord % xyz(3) + ! copy local coordinates + x = coord % xyz(1) + y = coord % xyz(2) + z = coord % xyz(3) + + ! determine oncoming edge x0 = lat % width_x * 0.5_8 y0 = lat % width_y * 0.5_8 ! left and right sides - if (u > 0) then + if (u == ZERO) then + d = INFINITY + elseif (u > 0) then d = (x0 - x)/u else d = -(x + x0)/u @@ -888,7 +902,9 @@ contains end if ! top and bottom sides - if (v > 0) then + if (v == ZERO) then + d = INFINITY + elseif (v > 0) then d = (y0 - y)/v else d = -(y + y0)/v @@ -911,9 +927,6 @@ contains end do LEVEL_LOOP - ! Remove coordinates for any lower levels - call deallocate_coord(final_coord % next) - ! Move particle to appropriate coordinate level p % coord => final_coord diff --git a/src/particle_header.f90 b/src/particle_header.f90 index 64fbc2e6d..fcd606803 100644 --- a/src/particle_header.f90 +++ b/src/particle_header.f90 @@ -39,9 +39,9 @@ module particle_header integer :: type ! Particle type (n, p, e, etc) ! Particle coordinates - logical :: in_lower_universe ! is particle in lower universe? - type(LocalCoord), pointer :: coord0 ! coordinates on universe 0 - type(LocalCoord), pointer :: coord ! coordinates on lowest universe + logical :: in_lower_universe ! is particle in lower universe? + type(LocalCoord), pointer :: coord0 => null() ! coordinates on universe 0 + type(LocalCoord), pointer :: coord => null() ! coordinates on lowest universe ! Other physical data real(8) :: wgt ! particle weight diff --git a/src/physics.f90 b/src/physics.f90 index 2b911329d..6c5d4ec90 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -10,7 +10,7 @@ module physics use geometry_header, only: Universe, BASE_UNIVERSE use global use interpolation, only: interpolate_tab1 - use output, only: write_message, print_particle + use output, only: write_message use particle_header, only: Particle, LocalCoord use random_lcg, only: prn use search, only: binary_search @@ -104,7 +104,7 @@ contains call collision(p) ! Save coordinates at collision for tallying purposes - p % last_xyz = p % coord % xyz + p % last_xyz = p % coord0 % xyz ! Set all uvws to base level -- right now, after a collision, only the ! base level uvws are changed diff --git a/src/plot.f90 b/src/plot.f90 index 79a08cd70..785b05135 100644 --- a/src/plot.f90 +++ b/src/plot.f90 @@ -13,7 +13,9 @@ module plot contains !=============================================================================== -! RUN_PLOT +! RUN_PLOT generates a binary stream file containing a list of surface/lattice +! crossings and what cell was traveled through. A Python script can then be used +! to generate a plot based on the recorded crossings and cells !=============================================================================== subroutine run_plot() @@ -131,6 +133,8 @@ contains ! MOVE PARTICLE ACROSS HORIZONTAL TRACK do while (p % alive) + ! save particle's current cell + last_cell = p % coord % cell ! Calculate distance to next boundary call distance_to_boundary(p, distance, surface_crossed, lattice_crossed) @@ -152,14 +156,13 @@ contains if (distance == INFINITY) p % coord % cell = 0 ! Write ending coordinates to file - write(UNIT=UNIT_PLOT) p % coord0 % xyz, p % coord % cell + write(UNIT=UNIT_PLOT) p % coord0 % xyz, last_cell cycle end if ! Write boundary crossing coordinates to file - write(UNIT=UNIT_PLOT) p % coord0 % xyz, p % coord % cell + write(UNIT=UNIT_PLOT) p % coord0 % xyz, last_cell - last_cell = p % coord % cell p % coord % cell = 0 if (lattice_crossed) then p % surface = NONE @@ -170,7 +173,7 @@ contains ! Since boundary conditions are disabled in plotting mode, we need ! to manually add the last segment - if (surfaces(surface_crossed) % bc == BC_VACUUM) then + if (surfaces(abs(surface_crossed)) % bc == BC_VACUUM) then p % coord0 % xyz(1) = last_x_coord write(UNIT=UNIT_PLOT) p % coord0 % xyz, 0 exit From d335606220db98ce68e11b59684d8425654c6104 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sun, 4 Dec 2011 18:28:36 -0500 Subject: [PATCH 45/70] Fixed geometry plotting when bounding box is bigger than geometry. --- src/geometry.f90 | 5 ++- src/plot.f90 | 108 ++++++++++++++++++++++++----------------------- 2 files changed, 58 insertions(+), 55 deletions(-) diff --git a/src/geometry.f90 b/src/geometry.f90 index bdcc6c741..da2a3feba 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -405,7 +405,7 @@ contains call find_cell(p, found) ! Couldn't find next cell anywhere! - if (.not. found) then + if ((.not. found) .and. (.not. plotting)) then message = "After particle crossed surface " // trim(int_to_str(p%surface)) & // ", it could not be located in any cell and it did not leak." call fatal_error() @@ -568,6 +568,7 @@ contains ! inialize distance to infinity (huge) dist = INFINITY lattice_crossed = .false. + nullify(final_coord) ! Get pointer to top-level coordinates coord => p % coord0 @@ -928,7 +929,7 @@ contains end do LEVEL_LOOP ! Move particle to appropriate coordinate level - p % coord => final_coord + if (associated(final_coord)) p % coord => final_coord end subroutine distance_to_boundary diff --git a/src/plot.f90 b/src/plot.f90 index 785b05135..8eb0a1082 100644 --- a/src/plot.f90 +++ b/src/plot.f90 @@ -6,7 +6,8 @@ module plot cross_lattice, cell_contains use geometry_header, only: Universe, BASE_UNIVERSE use global - use particle_header, only: Particle, initialize_particle, LocalCoord + use particle_header, only: Particle, initialize_particle, LocalCoord, & + deallocate_coord implicit none @@ -76,58 +77,59 @@ contains ! ======================================================================= ! MOVE PARTICLE FORWARD TO NEXT CELL -!!$ if (.not. found_cell) then -!!$ univ => universes(BASE_UNIVERSE) -!!$ do i = 1, univ % n_cells -!!$ p % xyz = coord -!!$ p % xyz_local = coord -!!$ p % cell = univ % cells(i) -!!$ -!!$ distance = INFINITY -!!$ ! call distance_to_boundary(p, d, surf, in_lattice) -!!$ if (d < distance) then -!!$ ! Move particle forward to next surface -!!$ p % xyz = p % xyz + d * p % uvw -!!$ -!!$ ! Check to make sure particle is actually going into this cell -!!$ ! by moving it slightly forward and seeing if the cell contains -!!$ ! that coordinate -!!$ -!!$ p % xyz = p % xyz + 1e-4 * p % uvw -!!$ p % xyz_local = p % xyz -!!$ -!!$ c => cells(p % cell) -!!$ if (.not. cell_contains(c, p)) cycle -!!$ -!!$ ! Reset coordinate to surface crossing -!!$ p % xyz = p % xyz - 1e-4 * p % uvw -!!$ p % xyz_local = p % xyz -!!$ -!!$ ! Set new distance and retain pointer to this cell -!!$ distance = d -!!$ last_cell = p % cell -!!$ end if -!!$ end do -!!$ -!!$ ! No cell was found on this horizontal ray -!!$ if (distance == INFINITY) then -!!$ p % xyz(1) = last_x_coord -!!$ p % cell = 0 -!!$ write(UNIT_PLOT) p % xyz, p % cell -!!$ -!!$ ! Move to next horizontal ray -!!$ xyz(2) = xyz(2) - pixel -!!$ cycle -!!$ end if -!!$ -!!$ ! Write coordinate where next cell begins -!!$ write(UNIT=UNIT_PLOT) p % xyz, 0 -!!$ -!!$ ! Process surface crossing for next cell -!!$ p % cell = 0 -!!$ p % surface = -surf -!!$ call cross_surface(p, last_cell) -!!$ end if + if (.not. found_cell) then + ! Clear any coordinates beyond first level + call deallocate_coord(p % coord0 % next) + p % coord => p % coord0 + + univ => universes(BASE_UNIVERSE) + do i = 1, univ % n_cells + p % coord0 % xyz = xyz + p % coord0 % cell = univ % cells(i) + + distance = INFINITY + call distance_to_boundary(p, d, surface_crossed, lattice_crossed) + if (d < distance) then + ! Move particle forward to next surface + ! Advance particle + p % coord0 % xyz = p % coord0 % xyz + d * p % coord0 % uvw + + ! Check to make sure particle is actually going into this cell + ! by moving it slightly forward and seeing if the cell contains + ! that coordinate + + p % coord0 % xyz = p % coord0 % xyz + 1e-4 * p % coord0 % uvw + + c => cells(p % coord0 % cell) + if (.not. cell_contains(c, p)) cycle + + ! Reset coordinate to surface crossing + p % coord0 % xyz = p % coord0 % xyz - 1e-4 * p % coord0 % uvw + + ! Set new distance and retain pointer to this cell + distance = d + last_cell = p % coord0 % cell + end if + end do + + ! No cell was found on this horizontal ray + if (distance == INFINITY) then + p % coord0 % xyz(1) = last_x_coord + write(UNIT_PLOT) p % coord0 % xyz, 0 + + ! Move to next horizontal ray + xyz(2) = xyz(2) - pixel + cycle + end if + + ! Write coordinate where next cell begins + write(UNIT=UNIT_PLOT) p % coord0 % xyz, 0 + + ! Process surface crossing for next cell + p % coord0 % cell = NONE + p % surface = -surface_crossed + call cross_surface(p, last_cell) + end if ! ======================================================================= ! MOVE PARTICLE ACROSS HORIZONTAL TRACK From 0fae90d092f64f2a54afa347549e0d04cb07f08d Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 5 Dec 2011 08:00:03 -0500 Subject: [PATCH 46/70] Fixed overwritten pointer in build_universe. --- src/initialize.f90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/initialize.f90 b/src/initialize.f90 index ce045c499..cc5314d12 100644 --- a/src/initialize.f90 +++ b/src/initialize.f90 @@ -22,6 +22,10 @@ module initialize use tally, only: create_tally_map, TallyObject use timing, only: timer_start, timer_stop + implicit none + + type(DictionaryII), pointer :: build_dict => null() + contains !=============================================================================== @@ -191,6 +195,9 @@ contains ! Create special dictionary used in input_xml call dict_create(cells_in_univ_dict) + + ! Create special dictionary for building universes + call dict_create(build_dict) end subroutine create_dictionaries @@ -475,7 +482,6 @@ contains type(Cell), pointer :: c => null() type(Universe), pointer :: subuniverse => null() type(Lattice), pointer :: lat => null() - type(DictionaryII), pointer :: dict => null() ! set level of the universe univ % level = level @@ -484,7 +490,7 @@ contains do i = 1, univ % n_cells i_cell = univ % cells(i) c => cells(i_cell) - c%parent = parent + c % parent = parent ! if this cell is filled with another universe, recursively ! call this subroutine @@ -497,15 +503,12 @@ contains ! universe for each unique lattice element if (c % type == CELL_LATTICE) then lat => lattices(c % fill) - call dict_create(dict) do x = 1, lat % n_x do y = 1, lat % n_y + lat => lattices(cells(i_cell) % fill) universe_num = lat % element(x,y) - if (dict_has_key(dict, universe_num)) then - cycle - else - call dict_add_key(dict, universe_num, 0) - + if (.not. dict_has_key(build_dict, universe_num)) then + call dict_add_key(build_dict, universe_num, 0) subuniverse => universes(universe_num) call build_universe(subuniverse, i_cell, level + 1) end if From 98268c0bae0ed24377821e89bf61e76231b4b1d8 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 5 Dec 2011 12:05:48 -0500 Subject: [PATCH 47/70] Fixed geometry plotting. Now works with Hoogenboom-Martin problem. --- src/plot.f90 | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/src/plot.f90 b/src/plot.f90 index 8eb0a1082..a42c2ac4e 100644 --- a/src/plot.f90 +++ b/src/plot.f90 @@ -24,7 +24,8 @@ contains integer :: i ! loop index integer :: surface_crossed ! surface which particle is on integer :: last_cell ! most recent cell particle was in - real(8) :: xyz(3) ! starting coordinates + integer :: enter_surface ! entrance surface + real(8) :: xyz(3) ! starting coordinates real(8) :: last_x_coord ! bounding x coordinate real(8) :: last_y_coord ! bounding y coordinate real(8) :: d ! distance to boundary @@ -82,33 +83,26 @@ contains call deallocate_coord(p % coord0 % next) p % coord => p % coord0 + distance = INFINITY univ => universes(BASE_UNIVERSE) do i = 1, univ % n_cells p % coord0 % xyz = xyz p % coord0 % cell = univ % cells(i) - distance = INFINITY call distance_to_boundary(p, d, surface_crossed, lattice_crossed) if (d < distance) then - ! Move particle forward to next surface - ! Advance particle - p % coord0 % xyz = p % coord0 % xyz + d * p % coord0 % uvw - ! Check to make sure particle is actually going into this cell ! by moving it slightly forward and seeing if the cell contains ! that coordinate - p % coord0 % xyz = p % coord0 % xyz + 1e-4 * p % coord0 % uvw + p % coord0 % xyz = p % coord0 % xyz + (d + TINY_BIT) * p % coord0 % uvw c => cells(p % coord0 % cell) if (.not. cell_contains(c, p)) cycle - ! Reset coordinate to surface crossing - p % coord0 % xyz = p % coord0 % xyz - 1e-4 * p % coord0 % uvw - ! Set new distance and retain pointer to this cell distance = d - last_cell = p % coord0 % cell + enter_surface = surface_crossed end if end do @@ -123,12 +117,13 @@ contains end if ! Write coordinate where next cell begins + p % coord0 % xyz = xyz + distance * p % coord0 % uvw write(UNIT=UNIT_PLOT) p % coord0 % xyz, 0 ! Process surface crossing for next cell p % coord0 % cell = NONE - p % surface = -surface_crossed - call cross_surface(p, last_cell) + p % surface = -enter_surface + call cross_surface(p, enter_surface) end if ! ======================================================================= From f1f443dadc6bc2ad1a14c5ccd5592a374e8abd72 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 5 Dec 2011 12:10:49 -0500 Subject: [PATCH 48/70] Added ability to trace history of specific particle. --- src/geometry.f90 | 8 ++++---- src/global.f90 | 5 +++++ src/input_xml.f90 | 6 ++++++ src/main.f90 | 5 +++++ src/physics.f90 | 4 ++-- src/xml-fortran/templates/settings_t.xml | 1 + 6 files changed, 23 insertions(+), 6 deletions(-) diff --git a/src/geometry.f90 b/src/geometry.f90 index da2a3feba..3ad533223 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -231,7 +231,7 @@ contains type(Surface), pointer :: surf => null() surf => surfaces(abs(p % surface)) - if (verbosity >= 10) then + if (verbosity >= 10 .or. trace) then message = " Crossing surface " // trim(int_to_str(surf % id)) call write_message() end if @@ -254,7 +254,7 @@ contains call score_surface_current(p) ! Display message - if (verbosity >= 10) then + if (verbosity >= 10 .or. trace) then message = " Leaked out of surface " // trim(int_to_str(surf % id)) call write_message() end if @@ -373,7 +373,7 @@ contains p % last_xyz = p % coord0 % xyz + TINY_BIT * p % coord0 % uvw ! Diagnostic message - if (verbosity >= 10) then + if (verbosity >= 10 .or. trace) then message = " Reflected from surface " // trim(int_to_str(surf%id)) call write_message() end if @@ -440,7 +440,7 @@ contains lat => lattices(p % coord % lattice) - if (verbosity >= 10) then + if (verbosity >= 10 .or. trace) then message = " Crossing lattice " // int_to_str(lat % id) call write_message() end if diff --git a/src/global.f90 b/src/global.f90 index 570c726ca..814313c71 100644 --- a/src/global.f90 +++ b/src/global.f90 @@ -168,6 +168,11 @@ module global ! screen and in logs integer :: verbosity = 7 + ! Trace for single particle + logical :: trace + integer :: trace_cycle + integer(8) :: trace_particle + contains !=============================================================================== diff --git a/src/input_xml.f90 b/src/input_xml.f90 index a698fbd37..d08f7e8d8 100644 --- a/src/input_xml.f90 +++ b/src/input_xml.f90 @@ -136,6 +136,12 @@ contains weight_survive = cutoff_(1) % weight_avg end if + ! Particle trace + if (size(trace_) > 0) then + trace_cycle = trace_(1) + trace_particle = trace_(2) + end if + end subroutine read_settings_xml !=============================================================================== diff --git a/src/main.f90 b/src/main.f90 index 8d8efbc61..a123d4790 100644 --- a/src/main.f90 +++ b/src/main.f90 @@ -90,6 +90,11 @@ contains ! set random number seed i_particle = (i_cycle-1)*n_particles + p % id call set_particle_seed(i_particle) + + ! set particle trace + trace = .false. + if (i_cycle == trace_cycle .and. & + p % id == trace_particle) trace = .true. ! transport particle call transport(p) diff --git a/src/physics.f90 b/src/physics.f90 index 6c5d4ec90..7e5d71a8d 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -52,12 +52,12 @@ contains p % cell_born = p % coord % cell end if - if (verbosity >= 9) then + if (verbosity >= 9 .or. trace) then message = "Simulating Particle " // trim(int_to_str(p % id)) call write_message() end if - if (verbosity >= 10) then + if (verbosity >= 10 .or. trace) then message = " Born in cell " // trim(int_to_str(& cells(p % coord % cell) % id)) call write_message() diff --git a/src/xml-fortran/templates/settings_t.xml b/src/xml-fortran/templates/settings_t.xml index 167ff0d63..71ae91bd2 100644 --- a/src/xml-fortran/templates/settings_t.xml +++ b/src/xml-fortran/templates/settings_t.xml @@ -25,5 +25,6 @@ + From f95cb888d775285a6d972172959ec6bb8c071739 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 5 Dec 2011 12:39:59 -0500 Subject: [PATCH 49/70] Added more output on verbosity level 10 (for traces). --- src/geometry.f90 | 4 +++- src/physics.f90 | 19 +++++++++++++------ 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/src/geometry.f90 b/src/geometry.f90 index 3ad533223..0116695c3 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -441,7 +441,9 @@ contains lat => lattices(p % coord % lattice) if (verbosity >= 10 .or. trace) then - message = " Crossing lattice " // int_to_str(lat % id) + message = " Crossing lattice " // trim(int_to_str(lat % id)) // & + ". Current position (" // trim(int_to_str(p % coord % lattice_x)) & + // "," // trim(int_to_str(p % coord % lattice_y)) // ")" call write_message() end if diff --git a/src/physics.f90 b/src/physics.f90 index 7e5d71a8d..249800a72 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -14,7 +14,7 @@ module physics use particle_header, only: Particle, LocalCoord use random_lcg, only: prn use search, only: binary_search - use string, only: int_to_str + use string, only: int_to_str, real_to_str use tally, only: score_tally, score_surface_current implicit none @@ -412,6 +412,13 @@ contains ! Sample nuclide/reaction for the material the particle is in call sample_reaction(p, MT) + ! Display information about collision + if (verbosity >= 10 .or. trace) then + message = " " // trim(reaction_name(MT)) // ". Energy = " // & + trim(real_to_str(p % E * 1e6_8)) // " eV." + call write_message() + end if + ! check for very low energy if (p % E < 1.0e-100_8) then p % alive = .false. @@ -419,11 +426,6 @@ contains call warning() end if - ! Score collision estimator tallies for any macro tallies -- this is done - ! after a collision has occurred rather than before because we need - ! information on the outgoing energy for any tallies with an outgoing energy - ! filter - ! Check if particle scattered or fissioned if (survival_biasing) then fissioned = .false. @@ -433,6 +435,11 @@ contains scattered = is_scatter(MT) end if + ! Score collision estimator tallies for any macro tallies -- this is done + ! after a collision has occurred rather than before because we need + ! information on the outgoing energy for any tallies with an outgoing energy + ! filter + if (tallies_on) then call score_tally(p, scattered, fissioned) call score_surface_current(p) From 1272f5b3477ac3546a162182a110322cd854b4ad Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 5 Dec 2011 13:01:58 -0500 Subject: [PATCH 50/70] Lowered FP_PRECISION and added more output geometry error. --- src/constants.f90 | 4 ++-- src/geometry.f90 | 5 +++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/constants.f90 b/src/constants.f90 index 332df302e..82ca27e4e 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -19,10 +19,10 @@ module constants real(8), parameter :: FREE_GAS_THRESHOLD = 400.0 ! Used for surface current tallies - real(8), parameter :: TINY_BIT = 1e-8 + real(8), parameter :: TINY_BIT = 1e-8_8 ! User for precision in geometry - real(8), parameter :: FP_PRECISION = 1e-9_8 + real(8), parameter :: FP_PRECISION = 1e-8_8 ! Maximum number of collisions/crossings integer, parameter :: MAX_EVENTS = 10000 diff --git a/src/geometry.f90 b/src/geometry.f90 index 0116695c3..991e979f1 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -406,8 +406,9 @@ contains ! Couldn't find next cell anywhere! if ((.not. found) .and. (.not. plotting)) then - message = "After particle crossed surface " // trim(int_to_str(p%surface)) & - // ", it could not be located in any cell and it did not leak." + message = "After particle crossed surface " // trim(int_to_str( & + surfaces(abs(p%surface)) % id)) // " it could not be located in " & + // "any cell and it did not leak." call fatal_error() end if From 01c51c130d66a2f9a021f1914dfae986140533ec Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 5 Dec 2011 14:06:10 -0500 Subject: [PATCH 51/70] Reduced FP_PRECISION yet again. --- src/constants.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/constants.f90 b/src/constants.f90 index 82ca27e4e..eba9786d6 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -22,7 +22,7 @@ module constants real(8), parameter :: TINY_BIT = 1e-8_8 ! User for precision in geometry - real(8), parameter :: FP_PRECISION = 1e-8_8 + real(8), parameter :: FP_PRECISION = 1e-7_8 ! Maximum number of collisions/crossings integer, parameter :: MAX_EVENTS = 10000 From 992abf62b80d2e5309007a8f6df6b79bcb5ccc2e Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Mon, 5 Dec 2011 22:56:27 -0500 Subject: [PATCH 52/70] Fixed trace on gfortran builds. --- src/input_xml.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/input_xml.f90 b/src/input_xml.f90 index d08f7e8d8..634cb6b36 100644 --- a/src/input_xml.f90 +++ b/src/input_xml.f90 @@ -137,7 +137,7 @@ contains end if ! Particle trace - if (size(trace_) > 0) then + if (associated(trace_)) then trace_cycle = trace_(1) trace_particle = trace_(2) end if From 66ca3248281be1db120a761bc2d9d9ec89f1dd01 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Tue, 6 Dec 2011 00:02:21 -0500 Subject: [PATCH 53/70] Reduced redundant calls to calculate_nuclide_xs. --- src/cross_section_header.f90 | 3 +-- src/physics.f90 | 7 ++++++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/cross_section_header.f90 b/src/cross_section_header.f90 index 2f3116062..2977231f5 100644 --- a/src/cross_section_header.f90 +++ b/src/cross_section_header.f90 @@ -176,8 +176,7 @@ module cross_section_header type NuclideMicroXS integer :: index_grid ! index on nuclide energy grid integer :: index_temp ! temperature index for nuclide - integer :: last_index_grid ! previous index on nuclide energy grid - integer :: last_index_temp ! previous temperature index for nuclide + real(8) :: last_E = 0.0 ! last evaluated energy real(8) :: interp_factor ! interpolation factor on nuc. energy grid real(8) :: total ! microscropic total xs real(8) :: elastic ! microscopic elastic scattering xs diff --git a/src/physics.f90 b/src/physics.f90 index 249800a72..6982959ad 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -182,7 +182,9 @@ contains end if ! Calculate microscopic cross section for this nuclide - call calculate_nuclide_xs(p, index_nuclide, index_sab) + if (p % E /= micro_xs(index_nuclide) % last_E) then + call calculate_nuclide_xs(p, index_nuclide, index_sab) + end if ! Copy atom density of nuclide in material atom_density = mat % atom_density(i) @@ -351,6 +353,9 @@ contains micro_xs(i) % elastic_sab = elastic end if + ! Set last evaluated energy + micro_xs(i) % last_E = p % E + end subroutine calculate_nuclide_xs !=============================================================================== From 8bf7b3f77e0d33b46ae295f1b4fcc65e39398d51 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Tue, 6 Dec 2011 14:56:23 -0500 Subject: [PATCH 54/70] Reduced calls to calculate_xs using last_material. --- src/geometry.f90 | 1 + src/physics.f90 | 47 +++++++++++++++++++++++------------------------ 2 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/geometry.f90 b/src/geometry.f90 index 991e979f1..cf0ed8adb 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -141,6 +141,7 @@ contains ! AT LOWEST UNIVERSE, TERMINATE SEARCH ! set material + p % last_material = p % material p % material = c % material elseif (c % type == CELL_FILL) then diff --git a/src/physics.f90 b/src/physics.f90 index 6982959ad..6a431a811 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -37,7 +37,7 @@ contains real(8) :: distance ! distance particle travels logical :: found_cell ! found cell which particle is in? logical :: lattice_crossed ! is surface crossing in lattice? - type(LocalCoord), pointer :: coord + type(LocalCoord), pointer :: coord => null() if (p % coord % cell == NONE) then call find_cell(p, found_cell) @@ -69,8 +69,11 @@ contains ! find energy index, interpolation factor do while (p % alive) - ! Calculate microscopic and macroscopic cross sections - call calculate_xs(p) + ! Calculate microscopic and macroscopic cross sections -- note: if the + ! material is the same as the last material and the energy of the + ! particle hasn't changed, we don't need to lookup cross sections again. + + if (p % material /= p % last_material) call calculate_xs(p) ! Find the distance to the nearest boundary call distance_to_boundary(p, d_boundary, surface_crossed, lattice_crossed) @@ -106,6 +109,10 @@ contains ! Save coordinates at collision for tallying purposes p % last_xyz = p % coord0 % xyz + ! Set last material to none since cross sections will need to be + ! re-evaluated + p % last_material = NONE + ! Set all uvws to base level -- right now, after a collision, only the ! base level uvws are changed coord => p % coord0 @@ -137,18 +144,13 @@ contains type(Particle), pointer :: p - integer :: i ! loop index over nuclides - integer :: index_nuclide ! index into nuclides array - integer :: index_sab - real(8) :: atom_density ! atom density of a nuclide - real(8) :: sab_threshold ! threshold for S(a,b) table + integer :: i ! loop index over nuclides + integer :: index_nuclide ! index into nuclides array + integer :: index_sab ! index into sab_tables array + real(8) :: atom_density ! atom density of a nuclide + real(8) :: sab_threshold ! threshold for S(a,b) table type(Material), pointer :: mat => null() ! current material - ! If the material is the same as the last material and the energy of the - ! particle hasn't changed, we don't need to lookup cross sections again. - - if (p % material == p % last_material) return - ! Set all material macroscopic cross sections to zero material_xs % total = ZERO material_xs % elastic = ZERO @@ -223,14 +225,14 @@ contains integer, intent(in) :: index_nuclide ! index into nuclides array integer, intent(in) :: index_sab ! index into sab_tables array - integer :: i ! index into nuclides array - integer :: IE ! index on nuclide energy grid - integer :: IE_sab ! index on S(a,b) energy grid - real(8) :: f ! interp factor on nuclide energy grid - real(8) :: f_sab ! interp factor on S(a,b) energy grid - real(8) :: inelastic ! S(a,b) inelastic cross section - real(8) :: elastic ! S(a,b) elastic cross section - real(8) :: nu ! total # of neutrons emitted per fission + integer :: i ! index into nuclides array + integer :: IE ! index on nuclide energy grid + integer :: IE_sab ! index on S(a,b) energy grid + real(8) :: f ! interp factor on nuclide energy grid + real(8) :: f_sab ! interp factor on S(a,b) energy grid + real(8) :: inelastic ! S(a,b) inelastic cross section + real(8) :: elastic ! S(a,b) elastic cross section + real(8) :: nu ! total # of neutrons emitted per fission type(Nuclide), pointer :: nuc => null() type(SAB_Table), pointer :: sab => null() @@ -240,9 +242,6 @@ contains ! Set pointer to nuclide nuc => nuclides(i) - ! TODO: Check if last energy/temp combination is same as current. If so, we - ! can return. - ! TODO: If not using unionized energy grid, we need to find the index on the ! nuclide energy grid using lethargy mapping or whatever other technique From 73ae7cb2bb84c5531956a685fc16cc4a07f488f4 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Tue, 6 Dec 2011 15:03:22 -0500 Subject: [PATCH 55/70] Removed temporary index i in calculate_nuclide_xs. --- src/physics.f90 | 40 ++++++++++++++++++---------------------- 1 file changed, 18 insertions(+), 22 deletions(-) diff --git a/src/physics.f90 b/src/physics.f90 index 6a431a811..4af9a452a 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -225,7 +225,6 @@ contains integer, intent(in) :: index_nuclide ! index into nuclides array integer, intent(in) :: index_sab ! index into sab_tables array - integer :: i ! index into nuclides array integer :: IE ! index on nuclide energy grid integer :: IE_sab ! index on S(a,b) energy grid real(8) :: f ! interp factor on nuclide energy grid @@ -236,11 +235,8 @@ contains type(Nuclide), pointer :: nuc => null() type(SAB_Table), pointer :: sab => null() - ! Copy index of nuclide - i = index_nuclide - ! Set pointer to nuclide - nuc => nuclides(i) + nuc => nuclides(index_nuclide) ! TODO: If not using unionized energy grid, we need to find the index on the ! nuclide energy grid using lethargy mapping or whatever other technique @@ -249,37 +245,37 @@ contains IE = nuc % grid_index(p % IE) f = (p%E - nuc%energy(IE))/(nuc%energy(IE+1) - nuc%energy(IE)) - micro_xs(i) % index_grid = IE - micro_xs(i) % interp_factor = f + micro_xs(index_nuclide) % index_grid = IE + micro_xs(index_nuclide) % interp_factor = f ! Initialize sab treatment to false - micro_xs(i) % use_sab = .false. - micro_xs(i) % elastic_sab = ZERO + micro_xs(index_nuclide) % use_sab = .false. + micro_xs(index_nuclide) % elastic_sab = ZERO ! Initialize nuclide cross-sections to zero - micro_xs(i) % fission = ZERO - micro_xs(i) % nu_fission = ZERO + micro_xs(index_nuclide) % fission = ZERO + micro_xs(index_nuclide) % nu_fission = ZERO ! Calculate microscopic nuclide total cross section - micro_xs(i) % total = & + micro_xs(index_nuclide) % total = & (ONE-f) * nuc % total(IE) + f * nuc % total(IE+1) ! Calculate microscopic nuclide total cross section - micro_xs(i) % elastic = & + micro_xs(index_nuclide) % elastic = & (ONE-f) * nuc % elastic(IE) + f * nuc % elastic(IE+1) ! Calculate microscopic nuclide absorption cross section - micro_xs(i) % absorption = & + micro_xs(index_nuclide) % absorption = & (ONE-f) * nuc % absorption(IE) + f * nuc % absorption(IE+1) if (nuc % fissionable) then ! Calculate microscopic nuclide total cross section - micro_xs(i) % fission = & + micro_xs(index_nuclide) % fission = & (ONE-f) * nuc % fission(IE) + f * nuc % fission(IE+1) ! Calculate microscopic nuclide nu-fission cross section nu = nu_total(nuc, p % E) - micro_xs(i) % nu_fission = nu * micro_xs(i) % fission + micro_xs(index_nuclide) % nu_fission = nu * micro_xs(index_nuclide) % fission end if ! If there is S(a,b) data for this nuclide, we need to do a few @@ -288,7 +284,7 @@ contains ! then add back in the calculated S(a,b) elastic+inelastic cross section. if (index_sab > 0) then - micro_xs(i) % use_sab = .true. + micro_xs(index_nuclide) % use_sab = .true. ! Get pointer to S(a,b) table sab => sab_tables(index_sab) @@ -344,16 +340,16 @@ contains end if ! Correct total and elastic cross sections - micro_xs(i) % total = micro_xs(i) % total - micro_xs(i) % elastic & - + inelastic + elastic - micro_xs(i) % elastic = inelastic + elastic + micro_xs(index_nuclide) % total = micro_xs(index_nuclide) % total - & + micro_xs(index_nuclide) % elastic + inelastic + elastic + micro_xs(index_nuclide) % elastic = inelastic + elastic ! Store S(a,b) elastic cross section for sampling later - micro_xs(i) % elastic_sab = elastic + micro_xs(index_nuclide) % elastic_sab = elastic end if ! Set last evaluated energy - micro_xs(i) % last_E = p % E + micro_xs(index_nuclide) % last_E = p % E end subroutine calculate_nuclide_xs From 1f0e6a3831bf08f905789e7865e18e510ced751f Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Wed, 7 Dec 2011 15:06:33 -0500 Subject: [PATCH 56/70] Fixed two errors in surface current tallies. --- src/geometry.f90 | 19 ++++++++++++------- src/tally.f90 | 14 +++++++------- 2 files changed, 19 insertions(+), 14 deletions(-) diff --git a/src/geometry.f90 b/src/geometry.f90 index cf0ed8adb..569755d2e 100644 --- a/src/geometry.f90 +++ b/src/geometry.f90 @@ -248,11 +248,13 @@ contains ! forward slightly so that if the mesh boundary is on the surface, it is ! still processed - ! TODO: Find a better solution to score surface currents than physically - ! moving the particle forward slightly + if (tallies_on) then + ! TODO: Find a better solution to score surface currents than + ! physically moving the particle forward slightly - p % coord0 % xyz = p % coord0 % xyz + TINY_BIT * p % coord0 % uvw - call score_surface_current(p) + p % coord0 % xyz = p % coord0 % xyz + TINY_BIT * p % coord0 % uvw + call score_surface_current(p) + end if ! Display message if (verbosity >= 10 .or. trace) then @@ -274,9 +276,12 @@ contains ! Score surface currents since reflection causes the direction of the ! particle to change -- artificially move the particle slightly back in ! case the surface crossing in coincident with a mesh boundary - p % coord0 % xyz = p % coord0 % xyz - TINY_BIT * p % coord0 % uvw - call score_surface_current(p) - p % coord0 % xyz = p % coord0 % xyz + TINY_BIT * p % coord0 % uvw + + if (tallies_on) then + p % coord0 % xyz = p % coord0 % xyz - TINY_BIT * p % coord0 % uvw + call score_surface_current(p) + p % coord0 % xyz = p % coord0 % xyz + TINY_BIT * p % coord0 % uvw + end if ! Copy particle's direction cosines u = p % coord0 % uvw(1) diff --git a/src/tally.f90 b/src/tally.f90 index 253e040d7..d30533a7e 100644 --- a/src/tally.f90 +++ b/src/tally.f90 @@ -662,7 +662,7 @@ contains bins(TS_SURFACE) = OUT_TOP bins(1:3) = ijk0 + 1 score_index = sum((bins - 1) * t % stride) + 1 - call add_to_score(t % scores(score_index, 1), p % last_wgt) + call add_to_score(t % scores(score_index, 1), p % wgt) end if end do else @@ -672,7 +672,7 @@ contains bins(TS_SURFACE) = IN_TOP bins(1:3) = ijk0 + 1 score_index = sum((bins - 1) * t % stride) + 1 - call add_to_score(t % scores(score_index, 1), p % last_wgt) + call add_to_score(t % scores(score_index, 1), p % wgt) end if end do end if @@ -686,7 +686,7 @@ contains bins(TS_SURFACE) = OUT_FRONT bins(1:3) = ijk0 + 1 score_index = sum((bins - 1) * t % stride) + 1 - call add_to_score(t % scores(score_index, 1), p % last_wgt) + call add_to_score(t % scores(score_index, 1), p % wgt) end if end do else @@ -696,7 +696,7 @@ contains bins(TS_SURFACE) = IN_FRONT bins(1:3) = ijk0 + 1 score_index = sum((bins - 1) * t % stride) + 1 - call add_to_score(t % scores(score_index, 1), p % last_wgt) + call add_to_score(t % scores(score_index, 1), p % wgt) end if end do end if @@ -710,7 +710,7 @@ contains bins(TS_SURFACE) = OUT_RIGHT bins(1:3) = ijk0 + 1 score_index = sum((bins - 1) * t % stride) + 1 - call add_to_score(t % scores(score_index, 1), p % last_wgt) + call add_to_score(t % scores(score_index, 1), p % wgt) end if end do else @@ -720,7 +720,7 @@ contains bins(TS_SURFACE) = IN_RIGHT bins(1:3) = ijk0 + 1 score_index = sum((bins - 1) * t % stride) + 1 - call add_to_score(t % scores(score_index, 1), p % last_wgt) + call add_to_score(t % scores(score_index, 1), p % wgt) end if end do end if @@ -836,7 +836,7 @@ contains end if ! Add to surface current tally - call add_to_score(t % scores(score_index, 1), p % last_wgt) + call add_to_score(t % scores(score_index, 1), p % wgt) end if ! Calculate new coordinates From 1578ae6587e1efc3e123b4c1cdeba54b2e11b192 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Wed, 7 Dec 2011 20:57:04 -0500 Subject: [PATCH 57/70] Added comments in calculate_keff subroutine. --- src/tally.f90 | 59 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 37 insertions(+), 22 deletions(-) diff --git a/src/tally.f90 b/src/tally.f90 index d30533a7e..b31dd24ce 100644 --- a/src/tally.f90 +++ b/src/tally.f90 @@ -1,5 +1,7 @@ module tally + use ISO_FORTRAN_ENV + use constants use error, only: fatal_error use global @@ -22,27 +24,27 @@ module tally contains !=============================================================================== -! CALCULATE_KEFF +! CALCULATE_KEFF calculates the single cycle estimate of keff as well as the +! mean and standard deviation of the mean for active cycles and displays them !=============================================================================== subroutine calculate_keff(i_cycle) integer, intent(in) :: i_cycle ! index of current cycle - integer(8) :: total_bank ! total number of source sites - integer :: n ! active cycle number - real(8) :: kcoll ! keff collision estimator - real(8), save :: k1 = 0. ! accumulated keff - real(8), save :: k2 = 0. ! accumulated keff**2 - real(8) :: std ! stdev of keff over active cycles + integer(8) :: total_bank ! total number of source sites + integer :: n ! active cycle number + real(8) :: k_cycle ! single cycle estimate of keff + real(8), save :: k_sum ! accumulated keff + real(8), save :: k_sum_sq ! accumulated keff**2 message = "Calculate cycle keff..." call write_message(8) - ! set k1 and k2 at beginning of run + ! initialize sum and square of sum at beginning of run if (i_cycle == 1) then - k1 = ZERO - k2 = ZERO + k_sum = ZERO + k_sum_sq = ZERO end if #ifdef MPI @@ -55,31 +57,44 @@ contains ! Collect statistics and print output if (master) then - kcoll = real(total_bank)/real(n_particles)*keff + ! Since the creation of bank sites was originally weighted by the last + ! cycle keff, we need to multiply by that keff to get the current cycle's + ! value + + k_cycle = real(total_bank)/real(n_particles)*keff + if (i_cycle > n_inactive) then + ! Active cycle number n = i_cycle - n_inactive - k1 = k1 + kcoll - k2 = k2 + kcoll**2 - keff = k1/n - std = sqrt((k2/n-keff**2)/n) - keff_std = std + + ! Accumulate cycle estimate of k + k_sum = k_sum + k_cycle + k_sum_sq = k_sum_sq + k_cycle*k_cycle + + ! Determine mean and standard deviation of mean + keff = k_sum/n + keff_std = sqrt((k_sum_sq/n - keff*keff)/n) + + ! Display output for this cycle if (i_cycle > n_inactive+1) then - write(6,101) i_cycle, kcoll, keff, std + write(UNIT=OUTPUT_UNIT, FMT=101) i_cycle, k_cycle, keff, keff_std else - write(6,100) i_cycle, kcoll + write(UNIT=OUTPUT_UNIT, FMT=100) i_cycle, k_cycle end if else - write(6,100) i_cycle, kcoll - keff = kcoll + ! Display output for inactive cycle + write(UNIT=OUTPUT_UNIT, FMT=100) i_cycle, k_cycle + keff = k_cycle end if end if #ifdef MPI + ! Broadcast new keff value to all processors call MPI_BCAST(keff, 1, MPI_REAL8, 0, MPI_COMM_WORLD, mpi_err) #endif -100 format (2X,I4,2X,F8.5) -101 format (2X,I4,2X,F8.5,9X,F8.5,1X,F8.5) +100 format (2X,I5,2X,F8.5) +101 format (2X,I5,2X,F8.5,9X,F8.5,1X,F8.5) end subroutine calculate_keff From 355791993970c2746cc2560d6042261c6dd1383e Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 8 Dec 2011 11:04:22 -0500 Subject: [PATCH 58/70] Moved surface current tallies to pre-collision rather than post-collision. Closes #57. --- src/physics.f90 | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/physics.f90 b/src/physics.f90 index 4af9a452a..f27b67ef1 100644 --- a/src/physics.f90 +++ b/src/physics.f90 @@ -409,6 +409,12 @@ contains ! Add to collision counter for particle p % n_collision = p % n_collision + 1 + ! score surface current tallies -- this has to be done before the collision + ! since the direction of the particle will change and we need to use the + ! pre-collision direction to figure out what mesh surfaces were crossed + + if (tallies_on) call score_surface_current(p) + ! Sample nuclide/reaction for the material the particle is in call sample_reaction(p, MT) @@ -440,10 +446,7 @@ contains ! information on the outgoing energy for any tallies with an outgoing energy ! filter - if (tallies_on) then - call score_tally(p, scattered, fissioned) - call score_surface_current(p) - end if + if (tallies_on) call score_tally(p, scattered, fissioned) ! Reset number of particles banked during collision p % n_bank = 0 From 959dc18108b38d269bca5e677100d9f797d4d7eb Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 8 Dec 2011 15:10:48 -0500 Subject: [PATCH 59/70] Added save attribute in xmlreader. --- src/xml-fortran/xmlreader.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/xml-fortran/xmlreader.f90 b/src/xml-fortran/xmlreader.f90 index c53b1ae71..2daf2fa1a 100644 --- a/src/xml-fortran/xmlreader.f90 +++ b/src/xml-fortran/xmlreader.f90 @@ -552,6 +552,7 @@ subroutine write_prolog & ' use WRITE_XML_PRIMITIVES', & & ' use XMLPARSE', & & ' implicit none', & + & ' save', & & ' integer, private :: lurep_', & & ' logical, private :: strict_' From 9d3e99477934e222bb80b628f8af0aeefbbae183 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 8 Dec 2011 15:35:24 -0500 Subject: [PATCH 60/70] Added stand-alone implementation of complementary error function for compilers without F2008 support. --- src/doppler.f90 | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/src/doppler.f90 b/src/doppler.f90 index bb17889b2..2c4d63f00 100644 --- a/src/doppler.f90 +++ b/src/doppler.f90 @@ -210,4 +210,32 @@ contains end subroutine calculate_F +#ifdef NO_F2008 +!=============================================================================== +! ERFC computes the complementary error function of x +!=============================================================================== + + function erfc(x) result(y) + + real(8), intent(in) :: x + real(8) :: y + + real(8) :: a1 = 0.254829592_8 + real(8) :: a2 = -0.284496736_8 + real(8) :: a3 = 1.421413741_8 + real(8) :: a4 = -1.453152027_8 + real(8) :: a5 = 1.061405429_8 + real(8) :: p = 0.3275911_8 + real(8) :: t + + ! Abramowitz and Stegun formula 7.1.26 + t = 1.0_8/(1.0_8 + p*abs(x)) + y = (((((a5*t + a4)*t) + a3)*t + a2)*t + a1)*t*exp(-x*x) + + ! Account for negative values of x + y = sign(y,x) + + end function erfc +#endif + end module doppler From b87d062a0de46a1ae472e85c7e38e33a4fdfa881 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 8 Dec 2011 15:36:15 -0500 Subject: [PATCH 61/70] Added NO_F2008 option where storage_size intrinsic was used. --- src/source.f90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/source.f90 b/src/source.f90 index 08d3b6195..b3b9a552f 100644 --- a/src/source.f90 +++ b/src/source.f90 @@ -45,7 +45,11 @@ contains ! Allocate source bank allocate(source_bank(maxwork), STAT=alloc_err) if (alloc_err /= 0) then +#ifndef NO_F2008 bytes = maxwork * storage_size(bank_obj) / 8 +#else + bytes = maxwork * 64 / 8 +#endif message = "Could not allocate source bank. Attempted to allocate " & // trim(int_to_str(bytes)) // " bytes." call fatal_error() @@ -54,7 +58,11 @@ contains ! Allocate fission bank allocate(fission_bank(3*maxwork), STAT=alloc_err) if (alloc_err /= 0) then +#ifndef NO_F2008 bytes = 3 * maxwork * storage_size(bank_obj) / 8 +#else + bytes = 3 * maxwork * 64 / 8 +#endif message = "Could not allocate fission bank. Attempted to allocate " & // trim(int_to_str(bytes)) // " bytes." call fatal_error() From 287d4923968c616a099a74b470e5a8bdd3814bef Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 8 Dec 2011 15:52:51 -0500 Subject: [PATCH 62/70] Renamed all f90 files to F90. --- src/Makefile | 4 ++-- src/{bank_header.f90 => bank_header.F90} | 0 src/{constants.f90 => constants.F90} | 0 src/{cross_section.f90 => cross_section.F90} | 0 src/{cross_section_header.f90 => cross_section_header.F90} | 0 src/{datatypes.f90 => datatypes.F90} | 0 src/{datatypes_header.f90 => datatypes_header.F90} | 0 src/{doppler.f90 => doppler.F90} | 0 src/{endf.f90 => endf.F90} | 0 src/{endf_header.f90 => endf_header.F90} | 0 src/{energy_grid.f90 => energy_grid.F90} | 0 src/{error.f90 => error.F90} | 0 src/{fileio.f90 => fileio.F90} | 0 src/{fission.f90 => fission.F90} | 0 src/{geometry.f90 => geometry.F90} | 0 src/{geometry_header.f90 => geometry_header.F90} | 0 src/{global.f90 => global.F90} | 0 src/{initialize.f90 => initialize.F90} | 0 src/{input_xml.f90 => input_xml.F90} | 0 src/{interpolation.f90 => interpolation.F90} | 0 src/{logging.f90 => logging.F90} | 0 src/{main.f90 => main.F90} | 0 src/{material_header.f90 => material_header.F90} | 0 src/{mesh.f90 => mesh.F90} | 0 src/{mesh_header.f90 => mesh_header.F90} | 0 src/{mpi_routines.f90 => mpi_routines.F90} | 0 src/{output.f90 => output.F90} | 0 src/{particle_header.f90 => particle_header.F90} | 0 src/{physics.f90 => physics.F90} | 0 src/{plot.f90 => plot.F90} | 0 src/{random_lcg.f90 => random_lcg.F90} | 0 src/{search.f90 => search.F90} | 0 src/{source.f90 => source.F90} | 0 src/{source_header.f90 => source_header.F90} | 0 src/{string.f90 => string.F90} | 0 src/{tally.f90 => tally.F90} | 0 src/{tally_header.f90 => tally_header.F90} | 0 src/{timing.f90 => timing.F90} | 0 38 files changed, 2 insertions(+), 2 deletions(-) rename src/{bank_header.f90 => bank_header.F90} (100%) rename src/{constants.f90 => constants.F90} (100%) rename src/{cross_section.f90 => cross_section.F90} (100%) rename src/{cross_section_header.f90 => cross_section_header.F90} (100%) rename src/{datatypes.f90 => datatypes.F90} (100%) rename src/{datatypes_header.f90 => datatypes_header.F90} (100%) rename src/{doppler.f90 => doppler.F90} (100%) rename src/{endf.f90 => endf.F90} (100%) rename src/{endf_header.f90 => endf_header.F90} (100%) rename src/{energy_grid.f90 => energy_grid.F90} (100%) rename src/{error.f90 => error.F90} (100%) rename src/{fileio.f90 => fileio.F90} (100%) rename src/{fission.f90 => fission.F90} (100%) rename src/{geometry.f90 => geometry.F90} (100%) rename src/{geometry_header.f90 => geometry_header.F90} (100%) rename src/{global.f90 => global.F90} (100%) rename src/{initialize.f90 => initialize.F90} (100%) rename src/{input_xml.f90 => input_xml.F90} (100%) rename src/{interpolation.f90 => interpolation.F90} (100%) rename src/{logging.f90 => logging.F90} (100%) rename src/{main.f90 => main.F90} (100%) rename src/{material_header.f90 => material_header.F90} (100%) rename src/{mesh.f90 => mesh.F90} (100%) rename src/{mesh_header.f90 => mesh_header.F90} (100%) rename src/{mpi_routines.f90 => mpi_routines.F90} (100%) rename src/{output.f90 => output.F90} (100%) rename src/{particle_header.f90 => particle_header.F90} (100%) rename src/{physics.f90 => physics.F90} (100%) rename src/{plot.f90 => plot.F90} (100%) rename src/{random_lcg.f90 => random_lcg.F90} (100%) rename src/{search.f90 => search.F90} (100%) rename src/{source.f90 => source.F90} (100%) rename src/{source_header.f90 => source_header.F90} (100%) rename src/{string.f90 => string.F90} (100%) rename src/{tally.f90 => tally.F90} (100%) rename src/{tally_header.f90 => tally_header.F90} (100%) rename src/{timing.f90 => timing.F90} (100%) diff --git a/src/Makefile b/src/Makefile index c56418fa2..ead977335 100644 --- a/src/Makefile +++ b/src/Makefile @@ -165,10 +165,10 @@ neat: # Rules #=============================================================================== -.SUFFIXES: .f90 .o +.SUFFIXES: .F90 .o .PHONY: all xml-fortran clean neat distclean -%.o: %.f90 +%.o: %.F90 $(F90) -Ixml-fortran -Ixml-fortran/templates $(F90FLAGS) -c $< #=============================================================================== diff --git a/src/bank_header.f90 b/src/bank_header.F90 similarity index 100% rename from src/bank_header.f90 rename to src/bank_header.F90 diff --git a/src/constants.f90 b/src/constants.F90 similarity index 100% rename from src/constants.f90 rename to src/constants.F90 diff --git a/src/cross_section.f90 b/src/cross_section.F90 similarity index 100% rename from src/cross_section.f90 rename to src/cross_section.F90 diff --git a/src/cross_section_header.f90 b/src/cross_section_header.F90 similarity index 100% rename from src/cross_section_header.f90 rename to src/cross_section_header.F90 diff --git a/src/datatypes.f90 b/src/datatypes.F90 similarity index 100% rename from src/datatypes.f90 rename to src/datatypes.F90 diff --git a/src/datatypes_header.f90 b/src/datatypes_header.F90 similarity index 100% rename from src/datatypes_header.f90 rename to src/datatypes_header.F90 diff --git a/src/doppler.f90 b/src/doppler.F90 similarity index 100% rename from src/doppler.f90 rename to src/doppler.F90 diff --git a/src/endf.f90 b/src/endf.F90 similarity index 100% rename from src/endf.f90 rename to src/endf.F90 diff --git a/src/endf_header.f90 b/src/endf_header.F90 similarity index 100% rename from src/endf_header.f90 rename to src/endf_header.F90 diff --git a/src/energy_grid.f90 b/src/energy_grid.F90 similarity index 100% rename from src/energy_grid.f90 rename to src/energy_grid.F90 diff --git a/src/error.f90 b/src/error.F90 similarity index 100% rename from src/error.f90 rename to src/error.F90 diff --git a/src/fileio.f90 b/src/fileio.F90 similarity index 100% rename from src/fileio.f90 rename to src/fileio.F90 diff --git a/src/fission.f90 b/src/fission.F90 similarity index 100% rename from src/fission.f90 rename to src/fission.F90 diff --git a/src/geometry.f90 b/src/geometry.F90 similarity index 100% rename from src/geometry.f90 rename to src/geometry.F90 diff --git a/src/geometry_header.f90 b/src/geometry_header.F90 similarity index 100% rename from src/geometry_header.f90 rename to src/geometry_header.F90 diff --git a/src/global.f90 b/src/global.F90 similarity index 100% rename from src/global.f90 rename to src/global.F90 diff --git a/src/initialize.f90 b/src/initialize.F90 similarity index 100% rename from src/initialize.f90 rename to src/initialize.F90 diff --git a/src/input_xml.f90 b/src/input_xml.F90 similarity index 100% rename from src/input_xml.f90 rename to src/input_xml.F90 diff --git a/src/interpolation.f90 b/src/interpolation.F90 similarity index 100% rename from src/interpolation.f90 rename to src/interpolation.F90 diff --git a/src/logging.f90 b/src/logging.F90 similarity index 100% rename from src/logging.f90 rename to src/logging.F90 diff --git a/src/main.f90 b/src/main.F90 similarity index 100% rename from src/main.f90 rename to src/main.F90 diff --git a/src/material_header.f90 b/src/material_header.F90 similarity index 100% rename from src/material_header.f90 rename to src/material_header.F90 diff --git a/src/mesh.f90 b/src/mesh.F90 similarity index 100% rename from src/mesh.f90 rename to src/mesh.F90 diff --git a/src/mesh_header.f90 b/src/mesh_header.F90 similarity index 100% rename from src/mesh_header.f90 rename to src/mesh_header.F90 diff --git a/src/mpi_routines.f90 b/src/mpi_routines.F90 similarity index 100% rename from src/mpi_routines.f90 rename to src/mpi_routines.F90 diff --git a/src/output.f90 b/src/output.F90 similarity index 100% rename from src/output.f90 rename to src/output.F90 diff --git a/src/particle_header.f90 b/src/particle_header.F90 similarity index 100% rename from src/particle_header.f90 rename to src/particle_header.F90 diff --git a/src/physics.f90 b/src/physics.F90 similarity index 100% rename from src/physics.f90 rename to src/physics.F90 diff --git a/src/plot.f90 b/src/plot.F90 similarity index 100% rename from src/plot.f90 rename to src/plot.F90 diff --git a/src/random_lcg.f90 b/src/random_lcg.F90 similarity index 100% rename from src/random_lcg.f90 rename to src/random_lcg.F90 diff --git a/src/search.f90 b/src/search.F90 similarity index 100% rename from src/search.f90 rename to src/search.F90 diff --git a/src/source.f90 b/src/source.F90 similarity index 100% rename from src/source.f90 rename to src/source.F90 diff --git a/src/source_header.f90 b/src/source_header.F90 similarity index 100% rename from src/source_header.f90 rename to src/source_header.F90 diff --git a/src/string.f90 b/src/string.F90 similarity index 100% rename from src/string.f90 rename to src/string.F90 diff --git a/src/tally.f90 b/src/tally.F90 similarity index 100% rename from src/tally.f90 rename to src/tally.F90 diff --git a/src/tally_header.f90 b/src/tally_header.F90 similarity index 100% rename from src/tally_header.f90 rename to src/tally_header.F90 diff --git a/src/timing.f90 b/src/timing.F90 similarity index 100% rename from src/timing.f90 rename to src/timing.F90 From 7872d1912d8a477646a1eb2c16ebfda974bc8923 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 8 Dec 2011 20:56:20 +0000 Subject: [PATCH 63/70] Added Makefile option for IBM XL compiler. --- src/Makefile | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/Makefile b/src/Makefile index ead977335..5330a0123 100644 --- a/src/Makefile +++ b/src/Makefile @@ -106,6 +106,21 @@ ifeq ($(COMPILER),pgi) endif endif +#=============================================================================== +# IBM XL compiler options +#=============================================================================== + +ifeq ($(COMPILER),ibm) + F90 = xlf2003 + F90FLAGS := -WF,-DNO_F2008 + + # Debugging options + ifeq ($(DEBUG),yes) + F90FLAGS += -g + LDFLAGS += -g + endif +endif + #=============================================================================== # Cray compiler options #=============================================================================== From d1256629a9c2d9041600b2368b1aea6f21956cfd Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 8 Dec 2011 14:06:47 -0800 Subject: [PATCH 64/70] Modified options for PGI compiler in Makefile. --- src/Makefile | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/src/Makefile b/src/Makefile index 5330a0123..b881c7e40 100644 --- a/src/Makefile +++ b/src/Makefile @@ -81,14 +81,9 @@ endif ifeq ($(COMPILER),pgi) F90 = pgf90 - F90FLAGS := -Mpreprocess -Minform=inform + F90FLAGS := -Mpreprocess -DNO_F2008 -Minform=inform LDFLAGS = - # Since ERFC is currently not supported in the PGI compiler and this intrinsic - # is used in the doppler module (which is not actually used yet), it is - # removed from the source objects - objects := $(subst doppler.o, ,$(objects)) - # Debugging options ifeq ($(DEBUG),yes) F90FLAGS += -g -Mbounds -Mchkptr -Mchkstk -traceback From eeb95facb44cc0f87defd3ace7abf85faab92b04 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Fri, 9 Dec 2011 10:38:29 -0500 Subject: [PATCH 65/70] Added debugging, profiling, optimization options for IBM XL compiler. --- src/Makefile | 33 +++++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/src/Makefile b/src/Makefile index b881c7e40..a95443ce3 100644 --- a/src/Makefile +++ b/src/Makefile @@ -30,13 +30,13 @@ ifeq ($(COMPILER),intel) F90FLAGS := -fpp -warn -assume byterecl LDFLAGS = - # Debugging options + # Debugging ifeq ($(DEBUG),yes) F90FLAGS += -g -traceback -ftrapuv -fp-stack-check -check all LDFLAGS += -g endif - # Profiling options + # Profiling ifeq ($(PROFILE),yes) F90FLAGS += -pg LDFLAGS += -pg @@ -44,7 +44,7 @@ ifeq ($(COMPILER),intel) # Optimization ifeq ($(OPTIMIZE),yes) - F90FLAGS += -O3 # -ipo + F90FLAGS += -O3 -ipo endif endif @@ -57,19 +57,20 @@ ifeq ($(COMPILER),gfortran) F90FLAGS := -cpp -Wall LDFLAGS = - # Debugging options + # Debugging ifeq ($(DEBUG),yes) F90FLAGS += -g -pedantic -std=f2008 -fbacktrace -fbounds-check \ -ffpe-trap=invalid,zero,overflow,underflow LDFLAGS += -g endif - # Profiling options + # Profiling ifeq ($(PROFILE),yes) F90FLAGS += -pg LDFLAGS += -pg endif + # Optimization ifeq ($(OPTIMIZE),yes) F90FLAGS += -O3 endif @@ -84,18 +85,19 @@ ifeq ($(COMPILER),pgi) F90FLAGS := -Mpreprocess -DNO_F2008 -Minform=inform LDFLAGS = - # Debugging options + # Debugging ifeq ($(DEBUG),yes) F90FLAGS += -g -Mbounds -Mchkptr -Mchkstk -traceback LDFLAGS += -g endif - # Profiling options + # Profiling ifeq ($(PROFILE),yes) F90FLAGS += -pg LDFLAGS += -pg endif + # Optimization ifeq ($(OPTIMIZE),yes) F90FLAGS += -fast -Mipa endif @@ -109,11 +111,22 @@ ifeq ($(COMPILER),ibm) F90 = xlf2003 F90FLAGS := -WF,-DNO_F2008 - # Debugging options + # Debugging ifeq ($(DEBUG),yes) - F90FLAGS += -g + F90FLAGS += -g -C -qflag=i:i -u LDFLAGS += -g endif + + # Profiling + ifeq ($(PROFILE),yes) + F90FLAGS += -p + LDFLAGS += -p + endif + + # Optimization + ifeq ($(OPTIMIZE),yes) + F90FLAGS += -O3 + endif endif #=============================================================================== @@ -124,7 +137,7 @@ ifeq ($(COMPILER),cray) F90 = ftn F90FLAGS := -e Z -m 0 - # Debugging options + # Debugging ifeq ($(DEBUG),yes) F90FLAGS += -g -R abcnsp -O0 LDFLAGS += -g From 129d9a1cae60cdab99f5af28128f840f137949e4 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Fri, 9 Dec 2011 13:56:06 -0500 Subject: [PATCH 66/70] Reduced unnecessary calls to mesh_indices_to_bin. --- src/mesh.F90 | 10 +++++++--- src/tally.F90 | 26 ++++++++++++-------------- 2 files changed, 19 insertions(+), 17 deletions(-) diff --git a/src/mesh.F90 b/src/mesh.F90 index f88c5f1af..40354a72a 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -12,15 +12,15 @@ contains ! GET_MESH_BIN determines the tally bin for a particle in a structured mesh !=============================================================================== - subroutine get_mesh_bin(m, xyz, bin, in_mesh) + subroutine get_mesh_bin(m, xyz, bin) type(StructuredMesh), pointer :: m real(8), intent(in) :: xyz(:) integer, intent(out) :: bin - logical, intent(out) :: in_mesh integer :: n integer, allocatable :: ijk(:) + logical :: in_mesh ! Get number of dimensions n = m % n_dimension @@ -32,7 +32,11 @@ contains call get_mesh_indices(m, xyz(1:n), ijk, in_mesh) ! Convert indices to bin - bin = mesh_indices_to_bin(m, ijk) + if (in_mesh) then + bin = mesh_indices_to_bin(m, ijk) + else + bin = NO_BIN_FOUND + end if ! Release memory for ijk deallocate(ijk) diff --git a/src/tally.F90 b/src/tally.F90 index b31dd24ce..547f21269 100644 --- a/src/tally.F90 +++ b/src/tally.F90 @@ -333,7 +333,6 @@ contains real(8) :: wgt real(8) :: mu real(8) :: E_out - logical :: in_mesh logical :: has_energyout_bin logical :: analog type(TallyObject), pointer :: t @@ -356,6 +355,18 @@ contains ! ======================================================================= ! DETERMINE SCORING BIN COMBINATION + ! determine mesh bin + if (t % n_bins(T_MESH) > 0) then + m => meshes(t % mesh) + + ! Determine if we're in the mesh first + call get_mesh_bin(m, p % coord0 % xyz, mesh_bin) + if (mesh_bin == NO_BIN_FOUND) cycle + bins(T_MESH) = mesh_bin + else + bins(T_MESH) = 1 + end if + ! determine next universe bin if (t % n_bins(T_UNIVERSE) > 0) then bins(T_UNIVERSE) = get_next_bin(T_UNIVERSE, p % coord % universe, i) @@ -396,19 +407,6 @@ contains bins(T_SURFACE) = 1 end if - ! determine mesh bin - if (t % n_bins(T_MESH) > 0) then - m => meshes(t % mesh) - - ! Determine if we're in the mesh first - call get_mesh_bin(m, p % coord0 % xyz, mesh_bin, in_mesh) - if (.not. in_mesh) cycle - - bins(T_MESH) = mesh_bin - else - bins(T_MESH) = 1 - end if - ! determine incoming energy bin n = t % n_bins(T_ENERGYIN) if (n > 0) then From 0205125d7ba218c2682db74572de8036e194e4c0 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Fri, 9 Dec 2011 14:46:49 -0500 Subject: [PATCH 67/70] Improved performance of get_mesh_bin. --- src/input_xml.F90 | 4 ++++ src/mesh.F90 | 38 ++++++++++++++++++++++++++++---------- src/mesh_header.F90 | 1 + 3 files changed, 33 insertions(+), 10 deletions(-) diff --git a/src/input_xml.F90 b/src/input_xml.F90 index 634cb6b36..078b00bc7 100644 --- a/src/input_xml.F90 +++ b/src/input_xml.F90 @@ -662,6 +662,7 @@ contains allocate(m % dimension(n)) allocate(m % origin(n)) allocate(m % width(n)) + allocate(m % upper_right(n)) ! Read dimensions in each direction m % dimension = mesh_(i) % dimension @@ -682,6 +683,9 @@ contains end if m % width = mesh_(i) % width + ! Set upper right coordinate + m % upper_right = m % origin + m % dimension * m % width + ! Add mesh to dictionary call dict_add_key(mesh_dict, m % id, i) end do diff --git a/src/mesh.F90 b/src/mesh.F90 index 40354a72a..8e2de583b 100644 --- a/src/mesh.F90 +++ b/src/mesh.F90 @@ -18,18 +18,39 @@ contains real(8), intent(in) :: xyz(:) integer, intent(out) :: bin - integer :: n - integer, allocatable :: ijk(:) - logical :: in_mesh + integer :: n + integer :: ijk(3) + logical :: in_mesh ! Get number of dimensions n = m % n_dimension - ! Create indices array same size as xyz - allocate(ijk(n)) - + ! Check for cases where particle is outside of mesh + if (xyz(1) < m % origin(1)) then + bin = NO_BIN_FOUND + return + elseif (xyz(1) > m % upper_right(1)) then + bin = NO_BIN_FOUND + return + elseif (xyz(2) < m % origin(2)) then + bin = NO_BIN_FOUND + return + elseif (xyz(2) > m % upper_right(2)) then + bin = NO_BIN_FOUND + return + end if + if (n > 2) then + if (xyz(3) < m % origin(3)) then + bin = NO_BIN_FOUND + return + elseif (xyz(3) > m % upper_right(3)) then + bin = NO_BIN_FOUND + return + end if + end if + ! Determine indices - call get_mesh_indices(m, xyz(1:n), ijk, in_mesh) + call get_mesh_indices(m, xyz(1:n), ijk(1:n), in_mesh) ! Convert indices to bin if (in_mesh) then @@ -38,9 +59,6 @@ contains bin = NO_BIN_FOUND end if - ! Release memory for ijk - deallocate(ijk) - end subroutine get_mesh_bin !=============================================================================== diff --git a/src/mesh_header.F90 b/src/mesh_header.F90 index 3d6ba48d3..ff4d30cf3 100644 --- a/src/mesh_header.F90 +++ b/src/mesh_header.F90 @@ -13,6 +13,7 @@ module mesh_header integer :: n_dimension integer, allocatable :: dimension(:) real(8), allocatable :: origin(:) + real(8), allocatable :: upper_right(:) real(8), allocatable :: width(:) end type StructuredMesh From 02a727748f0465e9b5fc4732942bb2fa208c55d7 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Fri, 9 Dec 2011 16:09:52 -0500 Subject: [PATCH 68/70] Fixed binary_search when list value was same as search value. --- src/search.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/search.F90 b/src/search.F90 index 2d3c0cc3d..46bbd89f0 100644 --- a/src/search.F90 +++ b/src/search.F90 @@ -48,7 +48,7 @@ contains ! Find values at midpoint array_index = L + (R - L)/2 testval = array(array_index) - if (val > testval) then + if (val >= testval) then L = array_index elseif (val < testval) then R = array_index From 70e9ecf68e22e047dc2042f818c3f0e452e3e00a Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Fri, 9 Dec 2011 16:13:44 -0500 Subject: [PATCH 69/70] Pre-calculate microscopic nu-fission cross sections. --- src/DEPENDENCIES | 1 + src/cross_section.F90 | 38 ++++++++++++++++++++++++++++++++++++ src/cross_section_header.F90 | 1 + src/physics.F90 | 5 ++--- 4 files changed, 42 insertions(+), 3 deletions(-) diff --git a/src/DEPENDENCIES b/src/DEPENDENCIES index 5290410fc..c1a0c2c08 100644 --- a/src/DEPENDENCIES +++ b/src/DEPENDENCIES @@ -5,6 +5,7 @@ cross_section.o: datatypes_header.o cross_section.o: endf.o cross_section.o: error.o cross_section.o: fileio.o +cross_section.o: fission.o cross_section.o: global.o cross_section.o: material_header.o cross_section.o: output.o diff --git a/src/cross_section.F90 b/src/cross_section.F90 index 48998170a..86d15ef1d 100644 --- a/src/cross_section.F90 +++ b/src/cross_section.F90 @@ -9,6 +9,7 @@ module cross_section use endf, only: reaction_name use error, only: fatal_error use fileio, only: read_line, skip_lines + use fission, only: nu_total use global use material_header, only: Material use output, only: write_message @@ -322,12 +323,20 @@ contains nuc % kT = kT nuc % zaid = NXS(2) + ! read all blocks call read_esz(nuc) call read_nu_data(nuc) call read_reactions(nuc) call read_angular_dist(nuc) call read_energy_dist(nuc) call read_unr_res(nuc) + + ! for fissionable nuclides, precalculate microscopic nu-fission cross + ! sections so that we don't need to call the nu_total function during + ! cross section lookups + + if (nuc % fissionable) call generate_nu_fission(nuc) + case (ACE_THERMAL) sab => sab_tables(index_table) sab % name = name @@ -366,6 +375,7 @@ contains allocate(nuc % total(NE)) allocate(nuc % elastic(NE)) allocate(nuc % fission(NE)) + allocate(nuc % nu_fission(NE)) allocate(nuc % absorption(NE)) allocate(nuc % heating(NE)) @@ -373,6 +383,7 @@ contains nuc % total = ZERO nuc % elastic = ZERO nuc % fission = ZERO + nuc % nu_fission = ZERO nuc % absorption = ZERO nuc % heating = ZERO @@ -1106,6 +1117,33 @@ contains end subroutine read_unr_res +!=============================================================================== +! GENERATE_NU_FISSION precalculates the microscopic nu-fission cross section for +! a given nuclide. This is done so that the nu_total function does not need to +! be called during cross section lookups. +!=============================================================================== + + subroutine generate_nu_fission(nuc) + + type(Nuclide), pointer :: nuc + + integer :: i ! index on nuclide energy grid + real(8) :: E ! energy + real(8) :: nu ! # of neutrons per fission + + do i = 1, nuc % n_grid + ! determine energy + E = nuc % energy(i) + + ! determine total nu at given energy + nu = nu_total(nuc, E) + + ! determine nu-fission microscopic cross section + nuc % nu_fission(i) = nu * nuc % fission(i) + end do + + end subroutine generate_nu_fission + !=============================================================================== ! READ_THERMAL_DATA reads elastic and inelastic cross sections and corresponding ! secondary energy/angle distributions derived from experimental S(a,b) diff --git a/src/cross_section_header.F90 b/src/cross_section_header.F90 index 2977231f5..f2a64e306 100644 --- a/src/cross_section_header.F90 +++ b/src/cross_section_header.F90 @@ -81,6 +81,7 @@ module cross_section_header real(8), allocatable :: total(:) ! total cross section real(8), allocatable :: elastic(:) ! elastic scattering real(8), allocatable :: fission(:) ! fission + real(8), allocatable :: nu_fission(:) ! neutron production real(8), allocatable :: absorption(:) ! absorption (MT > 100) real(8), allocatable :: heating(:) ! heating diff --git a/src/physics.F90 b/src/physics.F90 index f27b67ef1..04c829ff8 100644 --- a/src/physics.F90 +++ b/src/physics.F90 @@ -231,7 +231,6 @@ contains real(8) :: f_sab ! interp factor on S(a,b) energy grid real(8) :: inelastic ! S(a,b) inelastic cross section real(8) :: elastic ! S(a,b) elastic cross section - real(8) :: nu ! total # of neutrons emitted per fission type(Nuclide), pointer :: nuc => null() type(SAB_Table), pointer :: sab => null() @@ -274,8 +273,8 @@ contains (ONE-f) * nuc % fission(IE) + f * nuc % fission(IE+1) ! Calculate microscopic nuclide nu-fission cross section - nu = nu_total(nuc, p % E) - micro_xs(index_nuclide) % nu_fission = nu * micro_xs(index_nuclide) % fission + micro_xs(index_nuclide) % nu_fission = & + (ONE-f) * nuc % nu_fission(IE) + f * nuc % nu_fission(IE+1) end if ! If there is S(a,b) data for this nuclide, we need to do a few From 8de5a99c1f84b58d463d0c046692ef40f8c278cb Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Sat, 10 Dec 2011 00:21:51 -0500 Subject: [PATCH 70/70] Updated user's guide to reflect all changes to input. --- docs/source/usersguide/input.rst | 239 ++++++++++++++++++----- src/xml-fortran/templates/geometry_t.xml | 2 +- 2 files changed, 186 insertions(+), 55 deletions(-) diff --git a/docs/source/usersguide/input.rst b/docs/source/usersguide/input.rst index b0f2d820d..9503196a3 100644 --- a/docs/source/usersguide/input.rst +++ b/docs/source/usersguide/input.rst @@ -94,6 +94,9 @@ could be written as:: +``surface`` Element +------------------- + Each ``surface`` element can have the following attributes or sub-elements: :id: @@ -118,6 +121,46 @@ Each ``surface`` element can have the following attributes or sub-elements: *Default*: ``reflective`` +The following quadratic surfaces can be modeled: + + :x-plane: + A plane perpendicular to the x axis, i.e. a surface of the form :math:`x - + x_0 = 0`. The coefficients specified are ":math:`x_0`". + + :y-plane: + A plane perpendicular to the y axis, i.e. a surface of the form :math:`y - + y_0 = 0`. The coefficients specified are ":math:`y_0`". + + :z-plane: + A plane perpendicular to the z axis, i.e. a surface of the form :math:`z - + z_0 = 0`. The coefficients specified are ":math:`z_0`". + + :plane: + An arbitrary plane of the form :math:`Ax + By + Cz = D`. The coefficients + specified are ":math:`A \: B \: C \: D`". + + :x-cylinder: + An infinite cylinder whose length is paralle to the x-axis. This is a + quadratic surface of the form :math:`(y - y_0)^2 + (z - z_0)^2 = R^2`. The + coefficients specified are ":math:`y_0 \: z_0 \: R`". + + :y-cylinder: + An infinite cylinder whose length is paralle to the y-axis. This is a + quadratic surface of the form :math:`(x - x_0)^2 + (z - z_0)^2 = R^2`. The + coefficients specified are ":math:`x_0 \: z_0 \: R`". + + :z-cylinder: + An infinite cylinder whose length is paralle to the z-axis. This is a + quadratic surface of the form :math:`(x - x_0)^2 + (y - y_0)^2 = R^2`. The + coefficients specified are ":math:`x_0 \: y_0 \: R`". + + :sphere: + A sphere of the form :math:`(x - x_0)^2 + (y - y_0)^2 + (z - z_0)^2 = + R^2`. The coefficients specified are ":math:`x_0 \: y_0 \: z_0 \: R`". + +``cell`` Element +---------------- + Each ``cell`` element can have the following attributes or sub-elements: :id: @@ -151,42 +194,43 @@ Each ``cell`` element can have the following attributes or sub-elements: *Default*: None -The following quadratic surfaces can be modeled: +``lattice`` Element +------------------- -:x-plane: - A plane perpendicular to the x axis, i.e. a surface of the form :math:`x - x_0 - = 0`. The coefficients specified are ":math:`x_0`". +The ``lattice`` can be used to represent repeating structures (e.g. fuel pins in +an assembly) or other geometry which naturally fits into a two-dimensional +structured mesh. Each cell within the lattice is filled with a specified +universe. A ``lattice`` accepts the following attributes or sub-elements: -:y-plane: - A plane perpendicular to the y axis, i.e. a surface of the form :math:`y - y_0 - = 0`. The coefficients specified are ":math:`y_0`". + :id: + A unique integer that can be used to identify the surface. -:z-plane: - A plane perpendicular to the z axis, i.e. a surface of the form :math:`z - z_0 - = 0`. The coefficients specified are ":math:`z_0`". + :type: + A string indicating the arrangement of lattice cells. Accepted options are + "rectangular" and "hexagonal". -:plane: - An arbitrary plane of the form :math:`Ax + By + Cz = D`. The coefficients - specified are ":math:`A \: B \: C \: D`". + *Default*: rectangular -:x-cylinder: - An infinite cylinder whose length is paralle to the x-axis. This is a - quadratic surface of the form :math:`(y - y_0)^2 + (z - z_0)^2 = R^2`. The - coefficients specified are ":math:`y_0 \: z_0 \: R`". + :dimension: + Two integers representing the number of lattice cells in the x- and y- + directions, respectively. -:y-cylinder: - An infinite cylinder whose length is paralle to the y-axis. This is a - quadratic surface of the form :math:`(x - x_0)^2 + (z - z_0)^2 = R^2`. The - coefficients specified are ":math:`x_0 \: z_0 \: R`". + *Default*: None -:z-cylinder: - An infinite cylinder whose length is paralle to the z-axis. This is a - quadratic surface of the form :math:`(x - x_0)^2 + (y - y_0)^2 = R^2`. The - coefficients specified are ":math:`x_0 \: y_0 \: R`". + :origin: + The coordinates of the lower-left corner of the lattice. -:sphere: - A sphere of the form :math:`(x - x_0)^2 + (y - y_0)^2 + (z - z_0)^2 = - R^2`. The coefficients specified are ":math:`x_0 \: y_0 \: z_0 \: R`". + *Default*: None + + :width: + The width of the lattice cell in the x- and y- directions. + + *Default*: None + + :universes: + A list of the universe numbers that fill each cell of the lattice. + + *Default*: None .. _constructive solid geometry: http://en.wikipedia.org/wiki/Constructive_solid_geometry @@ -196,8 +240,14 @@ The following quadratic surfaces can be modeled: Materials Specification -- materials.xml ---------------------------------------- +``material`` Element +-------------------- + Each ``material`` element can have the following attributes or sub-elements: + :id: + A unique integer that can be used to identify the material. + :density: An element with attributes/sub-elements called ``value`` and ``units``. The ``value`` attribute is the numeric value of the density while the ``units`` @@ -209,7 +259,6 @@ Each ``material`` element can have the following attributes or sub-elements: *Default*: None :nuclide: - An element with attributes/sub-elements called ``name``, ``xs``, and ``ao`` or ``wo``. The ``name`` attribute is the name of the cross-section for a desired nuclide while the ``xs`` attribute is the cross-section @@ -225,25 +274,35 @@ Each ``material`` element can have the following attributes or sub-elements: *Default*: None + :sab: + Associates an S(a,b) table with the material. This element has + attributes/sub-elements called ``name`` and ``xs``. The ``name`` attribute + is the name of the S(a,b) table that should be associated with the material, + and ``xs`` is the cross-section identifier for the table. + + *Default*: None + +``default_xs`` Element +---------------------- + +In some circumstances, the cross-section identifier may be the same for many or +all nuclides in a given problem. In this case, rather than specifying the +``xs=...`` attribute on every nuclide, a ``default_xs`` element can be used to +set the default cross-section identifier for any nuclide without an identifier +explicitly listed. This element has no attributes and accepts a 3-letter string +that indicates the default cross-section identifier, e.g. "70c". + + *Default*: None + -------------------------------------- Settings Specification -- settings.xml -------------------------------------- All simulation parameters and miscellaneous options are specified in the -settings.xml file. The following elements can be specified: +settings.xml file. -- ``cross_sections`` -- ``criticality`` -- ``verbosity`` -- ``source`` -- ``survival_biasing`` -- ``cutoff`` - -The ``cross_sections`` element has no attributes and simply indicates the path -to an XML cross section listing file (usually named ``cross_sections.xml``. If -this element is absent from the ``settings.xml`` file, the environment variable -``CROSS_SECTIONS`` will be used to find the path to the XML cross section -listing. +``criticality`` Element +----------------------- The ``criticality`` element indicates that a criticality calculation should be performed. It has the following attributes/sub-elements: @@ -266,14 +325,25 @@ performed. It has the following attributes/sub-elements: *Default*: None -The ``verbosity`` element tells the code how much information to display to the -standard output. A higher verbosity corresponds to more information being -displayed. This element takes the following attributes: +``cross_sections`` Element +-------------------------- - :value: - The specified verbosity between 1 and 10. +The ``cross_sections`` element has no attributes and simply indicates the path +to an XML cross section listing file (usually named cross_sections.xml). If this +element is absent from the settings.xml file, the environment variable +``CROSS_SECTIONS`` will be used to find the path to the XML cross section +listing. - *Default*: 5 +``cutoff`` Element +------------------ + +The ``cutoff`` element has no attributes and indicates the weight cutoff used +below which particles undergo Russian roulette. + + *Default*: 0.25 + +``source`` Element +------------------ The ``source`` element gives information on an initial source guess for criticality calculations. It takes the following attributes: @@ -288,16 +358,26 @@ criticality calculations. It takes the following attributes: and the last three of which specify the upper-right corner. Source sites are sampled uniformly through that parallelepiped. -The ``survival_biasing`` element as no attributes and assumes wither the +``survival_biasing`` Element +---------------------------- + +The ``survival_biasing`` element has no attributes and assumes wither the value ``on`` or ``off``. If turned on, this option will enable the use of survival biasing, otherwise known as implicit capture or absorption. *Default*: off -The ``cutoff`` element has no attributes and indicates the weight cutoff used -below which particles undergo Russian roulette. +``verbosity`` Element +--------------------- - *Default*: 0.25 +The ``verbosity`` element tells the code how much information to display to the +standard output. A higher verbosity corresponds to more information being +displayed. This element takes the following attributes: + + :value: + The specified verbosity between 1 and 10. + + *Default*: 5 ------------------------------------ Tallies Specification -- tallies.xml @@ -317,8 +397,12 @@ filters can be used for a tally. The following types of filter are available: cell, universe, material, surface, birth region, pre-collision energy, post-collision energy, and an arbitrary structured mesh. -The two valid elements in the tallies.xml file are ``tally`` and ``mesh``. The -``tally`` element accepts the following sub-elements: +The two valid elements in the tallies.xml file are ``tally`` and ``mesh``. + +``tally`` Element +----------------- + +The ``tally`` element accepts the following sub-elements: :filters: A list of filters to specify what region of phase space should contribute to @@ -398,6 +482,9 @@ The following responses can be tallied. :nu-fission: Total production of neutrons due to fission +``mesh`` Element +---------------- + If a structured mesh is desired as a filter for a tally, it must be specified in a separate element with the tag name ``mesh``. This element has the following attributes/sub-elements: @@ -415,3 +502,47 @@ attributes/sub-elements: :width: The width of mesh cells in each direction. + +------------------------------------------- +Geometry Plotting Specification -- plot.xml +------------------------------------------- + +A rudimentary plotting capability is available in OpenMC by specifying a +plot.xml file and subsequently running with the command-line flag ``-plot``. The +root element of the plot.xml is simply ```` and four sub-elements can be +defined to configure the plotting range and resolution. + +``origin`` Element +------------------ + +The ``origin`` element has no attributes/sub-elements and indicates the +Cartesian coordinates of the center of the plot. + + *Default*: None + +``width`` Element +----------------- + +The ``width`` element has no attributes/sub-elements and indicates the width of +the plot in each of the basis directions. + + *Default*: None + +``basis`` Element +----------------- + +The ``basis`` element has no attributes/sub-elements and indicates the specified +basis for plotting. + + .. note:: The only accepted option currently is "xy" + + *Default*: xy + +``pixel`` Element +----------------- + +The ``pixel`` element has no attributes/sub-elements and indicates the distance +between horizontal rays sent through the geometry to record surface crossings. A +smaller ``pixel`` will result in a higher-resolution plot. + + *Default*: 0.01 diff --git a/src/xml-fortran/templates/geometry_t.xml b/src/xml-fortran/templates/geometry_t.xml index 7aeec2a31..6e0a7a368 100644 --- a/src/xml-fortran/templates/geometry_t.xml +++ b/src/xml-fortran/templates/geometry_t.xml @@ -22,7 +22,7 @@ - +