diff --git a/src/distribution_univariate.F90 b/src/distribution_univariate.F90 index 736b7081bb..6d85038212 100644 --- a/src/distribution_univariate.F90 +++ b/src/distribution_univariate.F90 @@ -1,9 +1,12 @@ module distribution_univariate - use constants, only: ZERO, HALF, HISTOGRAM, LINEAR_LINEAR + use constants, only: ZERO, HALF, HISTOGRAM, LINEAR_LINEAR, MAX_LINE_LEN, & + MAX_WORD_LEN use error, only: fatal_error use math, only: maxwell_spectrum, watt_spectrum use random_lcg, only: prn + use string, only: to_lower + use xml_interface !=============================================================================== ! DISTRIBUTION type defines a probability density function @@ -232,4 +235,109 @@ contains this%c(:) = this%c(:)/this%c(n) end subroutine tabular_initialize + subroutine distribution_from_xml(dist, node_dist) + class(Distribution), allocatable, intent(inout) :: dist + type(Node), pointer :: node_dist + + character(MAX_WORD_LEN) :: type + character(MAX_LINE_LEN) :: temp_str + integer :: temp_int + real(8), allocatable :: temp_real(:) + + if (check_for_node(node_dist, "type")) then + ! Determine type of distribution + call get_node_value(node_dist, "type", type) + + ! Determine number of parameters specified + if (check_for_node(node_dist, "parameters")) then + n = get_arraysize_double(node_dist, "parameters") + else + n = 0 + end if + + ! Allocate extension of Distribution + select case (to_lower(type)) + case ('uniform') + allocate (Uniform :: dist) + if (n /= 2) then + call fatal_error('Uniform distribution must have two & + ¶meters specified.') + end if + + case ('maxwell') + allocate (Maxwell :: dist) + if (n /= 1) then + call fatal_error('Maxwell energy distribution must have one & + ¶meter specified.') + end if + + case ('watt') + allocate(Watt :: dist) + if (n /= 2) then + call fatal_error('Watt energy distribution must have two & + ¶meters specified.') + end if + + case ('discrete') + allocate(Discrete :: dist) + + case ('tabular') + allocate(Tabular :: dist) + + case default + call fatal_error('Invalid distribution type: ' // trim(type) // '.') + + end select + + ! Read parameters and interpolation for distribution + select type (dist) + type is (Uniform) + allocate(temp_real(2)) + call get_node_array(node_dist, "parameters", temp_real) + dist%a = temp_real(1) + dist%b = temp_real(2) + deallocate(temp_real) + + type is (Maxwell) + call get_node_value(node_dist, "parameters", dist%theta) + + type is (Watt) + allocate(temp_real(2)) + call get_node_array(node_dist, "parameters", temp_real) + dist%a = temp_real(1) + dist%b = temp_real(2) + deallocate(temp_real) + + type is (Discrete) + allocate(temp_real(n)) + call get_node_array(node_dist, "parameters", temp_real) + call dist%initialize(temp_real(1:n/2), temp_real(n/2+1:n)) + deallocate(temp_real) + + type is (Tabular) + ! Read interpolation + if (check_for_node(node_dist, "interpolation")) then + call get_node_value(node_dist, "interpolation", temp_str) + select case(to_lower(temp_str)) + case ('histogram') + temp_int = HISTOGRAM + case ('linear-linear') + temp_int = LINEAR_LINEAR + case default + call fatal_error("Unknown interpolation type for distribution: " & + // trim(temp_str)) + end select + else + temp_int = HISTOGRAM + end if + + ! Read and initialize tabular distribution + allocate(temp_real(n)) + call get_node_array(node_dist, "parameters", temp_real) + call dist%initialize(temp_real(1:n/2), temp_real(n/2+1:n), temp_int) + deallocate(temp_real) + end select + end if + end subroutine distribution_from_xml + end module distribution_univariate diff --git a/src/string.F90 b/src/string.F90 index ce130a212d..b51763a611 100644 --- a/src/string.F90 +++ b/src/string.F90 @@ -3,7 +3,6 @@ module string use constants, only: MAX_WORDS, MAX_LINE_LEN, ERROR_INT, ERROR_REAL, & OP_LEFT_PAREN, OP_RIGHT_PAREN, OP_COMPLEMENT, OP_INTERSECTION, OP_UNION use error, only: fatal_error, warning - use global, only: master use stl_vector, only: VectorInt implicit none @@ -50,8 +49,8 @@ contains if (i_end > 0) then n = n + 1 if (i_end - i_start + 1 > len(words(n))) then - if (master) call warning("The word '" // string(i_start:i_end) & - &// "' is longer than the space allocated for it.") + call warning("The word '" // string(i_start:i_end) & + // "' is longer than the space allocated for it.") end if words(n) = string(i_start:i_end) ! reset indices