module quaff_fracture_toughness_m
    use erloff, only: error_list_t, fatal_t, module_t, procedure_t
    use iso_varying_string, only: &
            varying_string, &
            assignment(=), &
            operator(==), &
            operator(//), &
            var_str
    use parff, only: &
            parse_result_t, &
            parsed_rational_t, &
            parser_output_t, &
            state_t, &
            either, &
            parse_end_of_input, &
            parse_rational, &
            parse_string, &
            parse_whitespace, &
            parse_with, &
            then_drop
    use quaff_conversion_factors_m, only: &
            MEGAPASCAL_ROOT_METER_PER_PASCAL_ROOT_METER, &
            KSI_ROOT_INCH_PER_PASCAL_ROOT_METER
    use quaff_utilities_m, only: &
            operator(.safeEq.), &
            equal_within_absolute, &
            equal_within_relative, &
            parse_space, &
            PARSE_ERROR, &
            UNKNOWN_UNIT
    use strff, only: join, to_string

    implicit none
    private
    public :: &
            fracture_toughness_t, &
            fallible_fracture_toughness_t, &
            fracture_toughness_unit_t, &
            fallible_fracture_toughness_unit_t, &
            fracture_toughness_simple_unit_t, &
            operator(.unit.), &
            parse_fracture_toughness, &
            parse_fracture_toughness_unit, &
            sum, &
            abs, &
            DEFAULT_OUTPUT_UNITS, &
            PROVIDED_UNITS, &
            PASCAL_ROOT_METER, &
            MEGAPASCAL_ROOT_METER, &
            KSI_ROOT_INCH

    type :: fracture_toughness_t
        double precision :: pascal_root_meter
    contains
        private
        procedure :: to_units
        generic, public :: operator(.in.) => to_units
        procedure, pass(fracture_toughness) :: double_times_fracture_toughness
        procedure, pass(fracture_toughness) :: integer_times_fracture_toughness
        procedure :: fracture_toughness_times_double
        procedure :: fracture_toughness_times_integer
        generic, public :: operator(*) => &
                double_times_fracture_toughness, &
                integer_times_fracture_toughness, &
                fracture_toughness_times_double, &
                fracture_toughness_times_integer
        procedure :: fracture_toughness_divided_by_double
        procedure :: fracture_toughness_divided_by_integer
        procedure :: fracture_toughness_divided_by_fracture_toughness
        generic, public :: operator(/) => &
                fracture_toughness_divided_by_double, &
                fracture_toughness_divided_by_integer, &
                fracture_toughness_divided_by_fracture_toughness
        procedure :: fracture_toughness_plus_fracture_toughness
        generic, public :: operator(+) => fracture_toughness_plus_fracture_toughness
        procedure :: fracture_toughness_minus_fracture_toughness
        generic, public :: operator(-) => fracture_toughness_minus_fracture_toughness
        procedure :: greater_than
        generic, public :: operator(>) => greater_than
        procedure :: less_than
        generic, public :: operator(<) => less_than
        procedure :: greater_than_or_equal
        generic, public :: operator(>=) => greater_than_or_equal
        procedure :: less_than_or_equal
        generic, public :: operator(<=) => less_than_or_equal
        procedure :: equal_
        generic, public :: operator(==) => equal_
        procedure :: equal_within_absolute_
        procedure :: equal_within_relative_
        generic, public :: equal => &
                equal_, equal_within_absolute_, equal_within_relative_
        procedure :: not_equal
        generic, public :: operator(/=) => not_equal
        procedure :: to_string_full_precision
        procedure :: to_string_with_precision
        generic, public :: to_string => &
                to_string_full_precision, to_string_with_precision
        procedure :: to_string_in_full_precision
        procedure :: to_string_in_with_precision
        generic, public :: to_string_in => &
                to_string_in_full_precision, to_string_in_with_precision
    end type

    type :: fallible_fracture_toughness_t
        private
        type(fracture_toughness_t) :: fracture_toughness_ = fracture_toughness_t(0.0d0)
        type(error_list_t) :: errors_
    contains
        private
        procedure, public :: failed => fallible_fracture_toughness_failed
        procedure, public :: fracture_toughness => fallible_fracture_toughness_fracture_toughness
        procedure, public :: errors => fallible_fracture_toughness_errors
    end type

    type, abstract :: fracture_toughness_unit_t
        double precision :: conversion_factor
    contains
        procedure(unit_to_string_i), deferred :: unit_to_string
        procedure(value_to_string_i), deferred :: value_to_string
        generic :: to_string => unit_to_string, value_to_string
        procedure(parse_as_i), deferred :: parse_as
    end type

    type :: fallible_fracture_toughness_unit_t
        private
        class(fracture_toughness_unit_t), allocatable :: unit_
        type(error_list_t) :: errors_
    contains
        private
        procedure, public :: failed => fallible_fracture_toughness_unit_failed
        procedure, public :: unit => fallible_fracture_toughness_unit_unit
        procedure, public :: errors => fallible_fracture_toughness_unit_errors
    end type

    type, extends(fracture_toughness_unit_t) :: fracture_toughness_simple_unit_t
        character(len=20) :: symbol
    contains
        procedure :: unit_to_string => simple_unit_to_string
        procedure :: value_to_string => simple_value_to_string
        procedure :: parse_as => simple_parse_as
    end type

    abstract interface
        elemental function unit_to_string_i(self) result(string)
            import :: fracture_toughness_unit_t, varying_string

            implicit none

            class(fracture_toughness_unit_t), intent(in) :: self
            type(varying_string) :: string
        end function

        pure function value_to_string_i(self, value_) result(string)
            import :: fracture_toughness_unit_t, varying_string

            implicit none

            class(fracture_toughness_unit_t), intent(in) :: self
            type(varying_string), intent(in) :: value_
            type(varying_string) :: string
        end function

        function parse_as_i(self, string) result(fallible_fracture_toughness)
            import :: fracture_toughness_unit_t, fallible_fracture_toughness_t, varying_string

            implicit none

            class(fracture_toughness_unit_t), intent(in) :: self
            type(varying_string), intent(in) :: string
            type(fallible_fracture_toughness_t) :: fallible_fracture_toughness
        end function
    end interface

    interface operator(.unit.)
        module procedure from_units
    end interface

    interface fallible_fracture_toughness_t
        module procedure fallible_fracture_toughness_from_fracture_toughness
        module procedure fallible_fracture_toughness_from_errors
        module procedure fallible_fracture_toughness_from_fallible_fracture_toughness
    end interface

    interface fallible_fracture_toughness_unit_t
        module procedure fallible_fracture_toughness_unit_from_unit
        module procedure fallible_fracture_toughness_unit_from_errors
        module procedure fallible_frct_toughness_unit_from_fallible_frct_toughness_unit
    end interface

    interface parse_fracture_toughness
        module procedure parse_fracture_toughness_c
        module procedure parse_fracture_toughness_s
        module procedure parse_fracture_toughness_with_units_c
        module procedure parse_fracture_toughness_with_units_s
    end interface

    interface parse_fracture_toughness_unit
        module procedure parse_fracture_toughness_unit_c
        module procedure parse_fracture_toughness_unit_s
        module procedure parse_fracture_toughness_unit_with_units_c
        module procedure parse_fracture_toughness_unit_with_units_s
    end interface

    interface abs
        module procedure abs_fracture_toughness
    end interface

    interface sum
        module procedure sum_fracture_toughness
    end interface

    type(fracture_toughness_simple_unit_t), parameter :: KSI_ROOT_INCH = &
            fracture_toughness_simple_unit_t( &
                    conversion_factor = KSI_ROOT_INCH_PER_PASCAL_ROOT_METER, &
                    symbol = "ksi in^0.5")
    type(fracture_toughness_simple_unit_t), parameter :: MEGAPASCAL_ROOT_METER = &
            fracture_toughness_simple_unit_t( &
                    conversion_factor = MEGAPASCAL_ROOT_METER_PER_PASCAL_ROOT_METER, &
                    symbol = "MPa m^0.5")
    type(fracture_toughness_simple_unit_t), parameter :: PASCAL_ROOT_METER = &
            fracture_toughness_simple_unit_t( &
                    conversion_factor = 1.0d0, &
                    symbol = "Pa m^0.5")

    type(fracture_toughness_simple_unit_t) :: DEFAULT_OUTPUT_UNITS = PASCAL_ROOT_METER

    type(fracture_toughness_simple_unit_t), parameter :: PROVIDED_UNITS(*) = &
            [KSI_ROOT_INCH, MEGAPASCAL_ROOT_METER, PASCAL_ROOT_METER]

    character(len=*), parameter :: MODULE_NAME = "quaff_fracture_toughness_m"
contains
    function parse_fracture_toughness_c(string) result(fallible_fracture_toughness)
        character(len=*), intent(in) :: string
        type(fallible_fracture_toughness_t) :: fallible_fracture_toughness

        fallible_fracture_toughness = fallible_fracture_toughness_t( &
                parse_fracture_toughness(var_str(string), PROVIDED_UNITS), &
                module_t(MODULE_NAME), &
                procedure_t("parse_fracture_toughness_c"))
    end function

    function parse_fracture_toughness_s(string) result(fallible_fracture_toughness)
        type(varying_string), intent(in) :: string
        type(fallible_fracture_toughness_t) :: fallible_fracture_toughness

        fallible_fracture_toughness = fallible_fracture_toughness_t( &
                parse_fracture_toughness(string, PROVIDED_UNITS), &
                module_t(MODULE_NAME), &
                procedure_t("parse_fracture_toughness_s"))
    end function

    function parse_fracture_toughness_with_units_c( &
            string, units) result(fallible_fracture_toughness)
        character(len=*), intent(in) :: string
        class(fracture_toughness_unit_t), intent(in) :: units(:)
        type(fallible_fracture_toughness_t) :: fallible_fracture_toughness

        fallible_fracture_toughness = fallible_fracture_toughness_t( &
                parse_fracture_toughness(var_str(string), units), &
                module_t(MODULE_NAME), &
                procedure_t("parse_fracture_toughness_with_units_c"))
    end function

    function parse_fracture_toughness_with_units_s( &
            string, units) result(fallible_fracture_toughness)
        type(varying_string), intent(in) :: string
        class(fracture_toughness_unit_t), intent(in) :: units(:)
        type(fallible_fracture_toughness_t) :: fallible_fracture_toughness

        integer :: i

        do i = 1, size(units)
            fallible_fracture_toughness = units(i)%parse_as(string)
            if (.not. fallible_fracture_toughness%failed()) return
        end do
        fallible_fracture_toughness = fallible_fracture_toughness_t(error_list_t(fatal_t( &
                PARSE_ERROR, &
                module_t(MODULE_NAME), &
                procedure_t("parse_fracture_toughness_with_units_s"), &
                "Unable to parse '" // string // "' as a fracture_toughness_t. Tried with units: " &
                // join(units%to_string(), ", "))))
    end function

    elemental function from_units(value_, units) result(fracture_toughness)
        double precision, intent(in) :: value_
        class(fracture_toughness_unit_t), intent(in) :: units
        type(fracture_toughness_t) :: fracture_toughness

        fracture_toughness%pascal_root_meter = value_ / units%conversion_factor
    end function

    elemental function to_units(self, units) result(fracture_toughness)
        class(fracture_toughness_t), intent(in) :: self
        class(fracture_toughness_unit_t), intent(in) :: units
        double precision :: fracture_toughness

        fracture_toughness = self%pascal_root_meter * units%conversion_factor
    end function

    elemental function double_times_fracture_toughness( &
            multiplier, fracture_toughness) result(new_fracture_toughness)
        double precision, intent(in) :: multiplier
        class(fracture_toughness_t), intent(in) :: fracture_toughness
        type(fracture_toughness_t) :: new_fracture_toughness

        new_fracture_toughness%pascal_root_meter = &
                multiplier * fracture_toughness%pascal_root_meter
    end function

    elemental function integer_times_fracture_toughness( &
            multiplier, fracture_toughness) result(new_fracture_toughness)
        integer, intent(in) :: multiplier
        class(fracture_toughness_t), intent(in) :: fracture_toughness
        type(fracture_toughness_t) :: new_fracture_toughness

        new_fracture_toughness%pascal_root_meter = &
                dble(multiplier) * fracture_toughness%pascal_root_meter
    end function

    elemental function fracture_toughness_times_double( &
            fracture_toughness, multiplier) result(new_fracture_toughness)
        class(fracture_toughness_t), intent(in) :: fracture_toughness
        double precision, intent(in) :: multiplier
        type(fracture_toughness_t) :: new_fracture_toughness

        new_fracture_toughness%pascal_root_meter = &
                fracture_toughness%pascal_root_meter * multiplier
    end function

    elemental function fracture_toughness_times_integer( &
            fracture_toughness, multiplier) result(new_fracture_toughness)
        class(fracture_toughness_t), intent(in) :: fracture_toughness
        integer, intent(in) :: multiplier
        type(fracture_toughness_t) :: new_fracture_toughness

        new_fracture_toughness%pascal_root_meter = &
                fracture_toughness%pascal_root_meter * dble(multiplier)
    end function

    elemental function fracture_toughness_divided_by_double( &
            fracture_toughness, divisor) result(new_fracture_toughness)
        class(fracture_toughness_t), intent(in) :: fracture_toughness
        double precision, intent(in) :: divisor
        type(fracture_toughness_t) :: new_fracture_toughness

        new_fracture_toughness%pascal_root_meter = &
                fracture_toughness%pascal_root_meter / divisor
    end function

    elemental function fracture_toughness_divided_by_integer( &
            fracture_toughness, divisor) result(new_fracture_toughness)
        class(fracture_toughness_t), intent(in) :: fracture_toughness
        integer, intent(in) :: divisor
        type(fracture_toughness_t) :: new_fracture_toughness

        new_fracture_toughness%pascal_root_meter = &
                fracture_toughness%pascal_root_meter / dble(divisor)
    end function

    elemental function fracture_toughness_divided_by_fracture_toughness( &
            numerator, denomenator) result(ratio)
        class(fracture_toughness_t), intent(in) :: numerator
        type(fracture_toughness_t), intent(in) :: denomenator
        double precision :: ratio

        ratio = numerator%pascal_root_meter / denomenator%pascal_root_meter
    end function

    elemental function fracture_toughness_plus_fracture_toughness( &
            lhs, rhs) result(sum_)
        class(fracture_toughness_t), intent(in) :: lhs
        type(fracture_toughness_t), intent(in) :: rhs
        type(fracture_toughness_t) :: sum_

        sum_%pascal_root_meter = lhs%pascal_root_meter + rhs%pascal_root_meter
    end function

    elemental function fracture_toughness_minus_fracture_toughness( &
            lhs, rhs) result(difference)
        class(fracture_toughness_t), intent(in) :: lhs
        type(fracture_toughness_t), intent(in) :: rhs
        type(fracture_toughness_t) :: difference

        difference%pascal_root_meter = lhs%pascal_root_meter - rhs%pascal_root_meter
    end function

    pure function abs_fracture_toughness(fracture_toughness) result(abs_)
        type(fracture_toughness_t), intent(in) :: fracture_toughness
        type(fracture_toughness_t) :: abs_

        abs_%pascal_root_meter = abs(fracture_toughness%pascal_root_meter)
    end function

    pure function sum_fracture_toughness(fracture_toughnesss) result(sum_)
        type(fracture_toughness_t), intent(in) :: fracture_toughnesss(:)
        type(fracture_toughness_t) :: sum_

        sum_%pascal_root_meter = sum(fracture_toughnesss%pascal_root_meter)
    end function

    elemental function greater_than(lhs, rhs)
        class(fracture_toughness_t), intent(in) :: lhs
        type(fracture_toughness_t), intent(in) :: rhs
        logical :: greater_than

        greater_than = lhs%pascal_root_meter > rhs%pascal_root_meter
    end function

    elemental function less_than(lhs, rhs)
        class(fracture_toughness_t), intent(in) :: lhs
        type(fracture_toughness_t), intent(in) :: rhs
        logical :: less_than

        less_than = lhs%pascal_root_meter < rhs%pascal_root_meter
    end function

    elemental function greater_than_or_equal(lhs, rhs)
        class(fracture_toughness_t), intent(in) :: lhs
        type(fracture_toughness_t), intent(in) :: rhs
        logical :: greater_than_or_equal

        greater_than_or_equal = lhs%pascal_root_meter >= rhs%pascal_root_meter
    end function

    elemental function less_than_or_equal(lhs, rhs)
        class(fracture_toughness_t), intent(in) :: lhs
        type(fracture_toughness_t), intent(in) :: rhs
        logical :: less_than_or_equal

        less_than_or_equal = lhs%pascal_root_meter <= rhs%pascal_root_meter
    end function

    elemental function equal_(lhs, rhs)
        class(fracture_toughness_t), intent(in) :: lhs
        type(fracture_toughness_t), intent(in) :: rhs
        logical :: equal_

        equal_ = lhs%pascal_root_meter .safeEq. rhs%pascal_root_meter
    end function

    elemental function equal_within_absolute_(lhs, rhs, within)
        class(fracture_toughness_t), intent(in) :: lhs
        type(fracture_toughness_t), intent(in) :: rhs
        type(fracture_toughness_t), intent(in) :: within
        logical :: equal_within_absolute_

        equal_within_absolute_ = equal_within_absolute( &
                lhs%pascal_root_meter, rhs%pascal_root_meter, within%pascal_root_meter)
    end function

    elemental function equal_within_relative_(lhs, rhs, within)
        class(fracture_toughness_t), intent(in) :: lhs
        type(fracture_toughness_t), intent(in) :: rhs
        double precision, intent(in) :: within
        logical :: equal_within_relative_

        equal_within_relative_ = equal_within_relative( &
                lhs%pascal_root_meter, rhs%pascal_root_meter, within)
    end function

    elemental function not_equal(lhs, rhs)
        class(fracture_toughness_t), intent(in) :: lhs
        type(fracture_toughness_t), intent(in) :: rhs
        logical :: not_equal

        not_equal = .not. lhs == rhs
    end function

    elemental function to_string_full_precision(self) result(string)
        class(fracture_toughness_t), intent(in) :: self
        type(varying_string) :: string

        string = self%to_string_in(DEFAULT_OUTPUT_UNITS)
    end function

    elemental function to_string_with_precision(self, significant_digits) result(string)
        class(fracture_toughness_t), intent(in) :: self
        integer, intent(in) :: significant_digits
        type(varying_string) :: string

        string = self%to_string_in(DEFAULT_OUTPUT_UNITS, significant_digits)
    end function

    elemental function to_string_in_full_precision(self, units) result(string)
        class(fracture_toughness_t), intent(in) :: self
        class(fracture_toughness_unit_t), intent(in) :: units
        type(varying_string) :: string

        string = units%to_string(to_string(self.in.units))
    end function

    elemental function to_string_in_with_precision( &
            self, units, significant_digits) result(string)
        class(fracture_toughness_t), intent(in) :: self
        class(fracture_toughness_unit_t), intent(in) :: units
        integer, intent(in) :: significant_digits
        type(varying_string) :: string

        string = units%to_string(to_string(self.in.units, significant_digits))
    end function

    function fallible_fracture_toughness_from_fracture_toughness( &
            fracture_toughness) result(fallible_fracture_toughness)
        type(fracture_toughness_t), intent(in) :: fracture_toughness
        type(fallible_fracture_toughness_t) :: fallible_fracture_toughness

        fallible_fracture_toughness%fracture_toughness_ = fracture_toughness
    end function

    function fallible_fracture_toughness_from_errors( &
            errors) result(fallible_fracture_toughness)
        type(error_list_t), intent(in) :: errors
        type(fallible_fracture_toughness_t) :: fallible_fracture_toughness

        fallible_fracture_toughness%errors_ = errors
    end function

    function fallible_fracture_toughness_from_fallible_fracture_toughness( &
            fallible_fracture_toughness, &
            module_, &
            procedure_) &
            result(new_fallible_fracture_toughness)
        type(fallible_fracture_toughness_t), intent(in) :: fallible_fracture_toughness
        type(module_t), intent(in) :: module_
        type(procedure_t), intent(in) :: procedure_
        type(fallible_fracture_toughness_t) :: new_fallible_fracture_toughness

        if (fallible_fracture_toughness%failed()) then
            new_fallible_fracture_toughness%errors_ = error_list_t( &
                    fallible_fracture_toughness%errors_, module_, procedure_)
        else
            new_fallible_fracture_toughness%fracture_toughness_ = fallible_fracture_toughness%fracture_toughness_
        end if
    end function

    elemental function fallible_fracture_toughness_failed( &
            self) result(failed)
        class(fallible_fracture_toughness_t), intent(in) :: self
        logical :: failed

        failed = self%errors_%has_any()
    end function

    elemental function fallible_fracture_toughness_fracture_toughness( &
            self) result(fracture_toughness)
        class(fallible_fracture_toughness_t), intent(in) :: self
        type(fracture_toughness_t) :: fracture_toughness

        fracture_toughness = self%fracture_toughness_
    end function

    impure elemental function fallible_fracture_toughness_errors( &
            self) result(errors)
        class(fallible_fracture_toughness_t), intent(in) :: self
        type(error_list_t) :: errors

        errors = self%errors_
    end function

    function fallible_fracture_toughness_unit_from_unit( &
            unit) result(fallible_fracture_toughness_unit)
        class(fracture_toughness_unit_t), intent(in) :: unit
        type(fallible_fracture_toughness_unit_t) :: fallible_fracture_toughness_unit

        allocate(fallible_fracture_toughness_unit%unit_, source = unit)
    end function

    function fallible_fracture_toughness_unit_from_errors( &
            errors) result(fallible_fracture_toughness_unit)
        type(error_list_t), intent(in) :: errors
        type(fallible_fracture_toughness_unit_t) :: fallible_fracture_toughness_unit

        fallible_fracture_toughness_unit%errors_ = errors
    end function

    function fallible_frct_toughness_unit_from_fallible_frct_toughness_unit( &
            fallible_fracture_toughness_unit, &
            module_, &
            procedure_) &
            result(new_fallible_fracture_toughness_unit)
        type(fallible_fracture_toughness_unit_t), intent(in) :: fallible_fracture_toughness_unit
        type(module_t), intent(in) :: module_
        type(procedure_t), intent(in) :: procedure_
        type(fallible_fracture_toughness_unit_t) :: new_fallible_fracture_toughness_unit

        if (fallible_fracture_toughness_unit%failed()) then
            new_fallible_fracture_toughness_unit%errors_ = error_list_t( &
                    fallible_fracture_toughness_unit%errors_, module_, procedure_)
        else
            allocate(new_fallible_fracture_toughness_unit%unit_, source = &
                    fallible_fracture_toughness_unit%unit_)
        end if
    end function

    elemental function fallible_fracture_toughness_unit_failed( &
            self) result(failed)
        class(fallible_fracture_toughness_unit_t), intent(in) :: self
        logical :: failed

        failed = self%errors_%has_any()
    end function

    function fallible_fracture_toughness_unit_unit( &
            self) result(unit)
        class(fallible_fracture_toughness_unit_t), intent(in) :: self
        class(fracture_toughness_unit_t), allocatable :: unit

        allocate(unit, source = self%unit_)
    end function

    impure elemental function fallible_fracture_toughness_unit_errors( &
            self) result(errors)
        class(fallible_fracture_toughness_unit_t), intent(in) :: self
        type(error_list_t) :: errors

        errors = self%errors_
    end function

    elemental function simple_unit_to_string(self) result(string)
        class(fracture_toughness_simple_unit_t), intent(in) :: self
        type(varying_string) :: string

        string = trim(self%symbol)
    end function

    pure function simple_value_to_string(self, value_) result(string)
        class(fracture_toughness_simple_unit_t), intent(in) :: self
        type(varying_string), intent(in) :: value_
        type(varying_string) :: string

        string = value_ // " " // self%to_string()
    end function

    function simple_parse_as(self, string) result(fallible_fracture_toughness)
        class(fracture_toughness_simple_unit_t), intent(in) :: self
        type(varying_string), intent(in) :: string
        type(fallible_fracture_toughness_t) :: fallible_fracture_toughness

        type(parse_result_t) :: parse_result

        parse_result = parse_with(the_parser, string)
        if (parse_result%ok) then
            select type (the_number => parse_result%parsed)
            type is (parsed_rational_t)
                fallible_fracture_toughness = fallible_fracture_toughness_t(the_number%value_.unit.self)
            end select
        else
            fallible_fracture_toughness = fallible_fracture_toughness_t(error_list_t(fatal_t( &
                    PARSE_ERROR, &
                    module_t(MODULE_NAME), &
                    procedure_t("simple_parse_as"), &
                    parse_result%message)))
        end if
    contains
        function the_parser(state_) result(result_)
            type(state_t), intent(in) :: state_
            type(parser_output_t) :: result_

            result_ = then_drop( &
                    then_drop(parse_rational, parse_space, state_), &
                    parse_unit)
        end function

        function parse_unit(state_) result(result_)
            type(state_t), intent(in) :: state_
            type(parser_output_t) :: result_

            result_ = then_drop( &
                    parse_string(trim(self%symbol), state_), &
                    parse_end)
        end function

        function parse_end(state_) result(result_)
            type(state_t), intent(in) :: state_
            type(parser_output_t) :: result_

            result_ = either(parse_end_of_input, parse_whitespace, state_)
        end function
    end function

    function parse_fracture_toughness_unit_c(string) result(fallible_fracture_toughness_unit)
        character(len=*), intent(in) :: string
        type(fallible_fracture_toughness_unit_t) :: fallible_fracture_toughness_unit

        fallible_fracture_toughness_unit = fallible_fracture_toughness_unit_t( &
                parse_fracture_toughness_unit(var_str(string), PROVIDED_UNITS), &
                module_t(MODULE_NAME), &
                procedure_t("parse_fracture_toughness_unit_c"))
    end function

    function parse_fracture_toughness_unit_s(string) result(fallible_fracture_toughness_unit)
        type(varying_string), intent(in) :: string
        type(fallible_fracture_toughness_unit_t) :: fallible_fracture_toughness_unit

        fallible_fracture_toughness_unit = fallible_fracture_toughness_unit_t( &
                parse_fracture_toughness_unit(string, PROVIDED_UNITS), &
                module_t(MODULE_NAME), &
                procedure_t("parse_fracture_toughness_unit_s"))
    end function

    function parse_fracture_toughness_unit_with_units_c( &
            string, units) result(fallible_fracture_toughness_unit)
        character(len=*), intent(in) :: string
        class(fracture_toughness_unit_t), intent(in) :: units(:)
        type(fallible_fracture_toughness_unit_t) :: fallible_fracture_toughness_unit

        fallible_fracture_toughness_unit = fallible_fracture_toughness_unit_t( &
                parse_fracture_toughness_unit(var_str(string), units), &
                module_t(MODULE_NAME), &
                procedure_t("parse_fracture_toughness_unit_with_units_c"))
    end function

    function parse_fracture_toughness_unit_with_units_s( &
            string, units) result(fallible_fracture_toughness_unit)
        type(varying_string), intent(in) :: string
        class(fracture_toughness_unit_t), intent(in) :: units(:)
        type(fallible_fracture_toughness_unit_t) :: fallible_fracture_toughness_unit

        integer :: i
        type(varying_string) :: unit_strings(size(units))

        do i = 1, size(units)
            if (string == units(i)%to_string()) then
                fallible_fracture_toughness_unit = fallible_fracture_toughness_unit_t(units(i))
                return
            end if
        end do
        do i = 1, size(units)
            unit_strings(i) = units(i)%to_string()
        end do
        fallible_fracture_toughness_unit = fallible_fracture_toughness_unit_t(error_list_t(fatal_t( &
                UNKNOWN_UNIT, &
                module_t(MODULE_NAME), &
                procedure_t("parse_fracture_toughness_unit_with_units_s"), &
                '"' // string // '", known units: [' // join(unit_strings, ', ') // ']')))
    end function
end module


      SUBROUTINE T2FED
C                                 PROCESS T2F
C                                 ------- ---
C
C  DOCUMENT DATE: 11 JANUARY 1987                                             69
C
C       PROCESS T2F CONVERTS TRACES FROM THE TIME DOMAIN TO THE FREQUENCY
C  DOMAIN.  EACH TRACE IS WINDOWED, PADDED WITH ZEROES TO A POWER OF 2,
C  TRANSFORMED, AND OPTIONALLY CONVERTED TO POLAR COORDINATES.  TRACES LEFT IN
C  RECTANGULAR COORDINATES ARE IN COMPLEX FORM SUCH THAT THE IMAGINARY PART
C  OF EACH FREQUENCY IMMEDIATELY FOLLOWS THE REAL (REAL-IMAGINARY PAIRS).
C  TRACES IN POLAR FORM HAVE THE FREQUENCY SPECTRUM IN THE FIRST HALF OF THE
C  OUTPUT TRACE WHILE THE WRAPPED PHASE SPECTRUM IS IN THE SECOND HALF OF THE
C  TRACE.
C       EACH OUTPUT TRACE WILL CONTAIN A POWER OF 2 + 2 NUMBER OF SAMPLES AND IS
C  THE NUMBER OF SAMPLES USED IN THE FFT (FFTLEN+2).  THERE ARE FFTLEN/2+1
C  FREQUENCIES IN THE OUTPUT TRACE REPRESENTING FREQUENCIES 0 (DC) TO THE
C  NYQUIST FREQUENCY (1./(2*SAMPLE INTERVAL)).
C       ANY SEISMIC PROCESS MAY BE USED ON FREQUENCY DATA, BUT SOME POST T2F
C  PROCESSES MAY NOT MAKE GEOPHYSICAL SENSE.  FREQUENCY DOMAIN PLOTS MAY BE
C  MADE USING POLAR COORDINATES AND PLOTTING THE FIRST HALF OF THE TRACE.
C  BANDPASS FILTER AND DECONVOLUTION SHOULD BE DONE IN THE TIME DOMAIN USING
C  PROCESSES FILTER AND DECON UNTIL THE FREQUENCY DOMAIN PROCESSES ARE WRITTEN.
C       A GOOD REVIEW OF THE FREQUENCY DOMAIN IS "A GUIDED TOUR OF THE FAST
C  FOURIER TRANSFORM" BY G.D.BERGLAND IN "IEEE SPECTRUM", JULY 1969.
C
C  THE PARAMETER DICTIONARY
C  --- --------- ----------
C  STIME  - START TIME, IN SECONDS, OF THE DATA TO TRANSFORM.  The use of STIME
c           causes the the deep water delay to be set to 0. and the first time
c           sample on an inverse transform (PROCESS F2T) to be 0.
C           PRESET = THE DELAY OF THE TRACE.  E.G.  STIM3 3.3
C  ETIME  - END TIME, IN SECONDS, OF THE DATA TO TRANSFORM.  THE DATA AFTER
C           ETIME WILL BE PADDED WITH ZEROES IN ORDER FOR THE DATA LENGTH BE
C           A POWER OF 2.
C           PRESET = THE ENTIRE DATA TRACE.    E.G.  ETIME 4.0
C  WINDOW - THE TYPE OF WINDOW TO APPLY BEFORE COMPUTING THE FFT.
C         =HAMM, HAMMING
C         =HANN, HANNING
C         =BART, BARTLETT (TRIANGULAR)
C         =RECT, RECTANGULAR (BOX CAR - NO WINDOW)
C         =BLAC, BLACKMAN
C         =EBLA, EXACT BLACKMAN
C         =BLHA, BLACKMAN HARRIS
C           PRESET=HAMM  E.G. WINDOW RECT
C  WINLEN - THE WINDOW LENGTH, IN SECONDS.  A WINDOW LENGTH OF ZERO CAUSES
C           THE ENTIRE TIME DOMAIN GATE TO BE WINDOWED.  A NON ZERO LENGTH
C           INDICATES THAT WINLEN DATA WILL BE MODIFIED AT BOTH ENDS OF EACH
C           DATA GATE.
C           PRESET=0  E.G. WINLEN .2
C  COORDS - THE COORDINATES OF THE OUTPUT TRACE.
C         =RECT, RECTANGULAR COORDINATES.  THE OUTPUT TRACE WILL BE COMPLEX.
C                THE TRACE VALUES WILL CONSIST OF REAL AND IMAGINARY PAIRS.
C                THE USE OF RECTANGULAR COORDINATES IS SLIGHTLY FASTER THAN
C                POLAR COORDINATES, AND IS UNDERSTOOD BY FREQUENCY DOMAIN
C                PROCESSES SUCH AS F2T.
C         =POLR, POLAR COORDINATES.  THE FIRST HALF OF THE OUTPUT TRACE WILL BE
C                THE AMPLITUDE SPECTRUM AND THE SECOND HALF OF THE TRACE WILL
C                BE THE PHASE SPECTRUM.
C           PRESET = RECT   E.G.  COORDS POLR
C  FFTLEN - THE NUMBER OF POINTS TO USE IN THE FFT.  T2F WILL MAKE THIS A
C           POWER OF 2 IF IT IS NOT.
C           PRESET = THE NUMBER OF POINTS IN THE TRACE.  E.G. FFTLEN 1024
C  END    - TERMINATES EACH PARAMETER LIST.
C
C  WRITTEN AND COPYRIGHTED (C) BY:
C  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, JANUARY 1984
C  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
C  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
C
c  mod 2 Oct. 2008 - Add coords AMPL
c
      PARAMETER (NPARS = 12)                                            ! /* THE NUMBER OF USER PARAMETERS
      PARAMETER (NWRDS = npars)                                         ! /* THE NUMBER OF WORDS IN EACH PARAMETER LIST
      CHARACTER*4 LWINDS(8)
      COMMON /T2F/ MUNIT,NLISTS
      INTEGER FFTLEN,FNO,FTR
      CHARACTER*4 WINDOW,COORDS
      CHARACTER*6 NAMES(NPARS)
      CHARACTER*1 TYPES(NPARS)
      DIMENSION LENGTH(NPARS)
      CHARACTER*80 TOKEN
      DIMENSION VALS(NPARS),LVALS(NPARS)
      EQUIVALENCE (VALS(1),LVALS(1))
      DIMENSION SCR(NWRDS),LSCR(111)
      EQUIVALENCE (SCR(1),LSCR(1))
      COMMON /EDITS/ IERROR,IWARN,IRUN,NOW,ICOMPT
C
C
      EQUIVALENCE (WINLEN,VALS(2)),
     3            (FFTLEN,LVALS(3)),
     5            (LPRINT,LVALS(5)),
     6            (FNO,LVALS(6)),
     7            (LNO,LVALS(7)),
     8            (FTR,LVALS(8)),
     9            (LTR,LVALS(9)),
     *            (ADDWB,LVALS(10)),
     1            (stime, vals(11)),
     2            (etime, vals(12))
      DATA LWINDS/'HAMM','HANN','GAUS','BART','RECT','BLAC',
     *  'EBLA','BLHA'/
      DATA NAMES/'WINDOW','WINLEN','FFTLEN','COORDS','LPRINT',
     *   'FNO   ','LNO   ','FTR   ','LTR   ','ADDWB ','STIME ',
     *   'ETIME '/
      DATA TYPES/'A','F','L','A','L',4*'L','A','F','F'/
      DATA LENGTH/6,6,6,6,6,4*3,3*5/
C****
C****      SET THE PRESETS
C****
      WINDOW='HAMM'
      WINLEN=0.
      FFTLEN=0.
      COORDS='RECT'
      LPRINT=0
      FNO=1
      LNO=9999999
      FTR=1
      LTR=9999
      IADDWB=0
      stime = -1.
      etime = -1.
      LLNO = 0
      NLISTS=0
      NS=0
C****
C****   GET A PARAMETER FILE
C****
      CALL GETFIL(1,MUNIT,TOKEN,ISTAT)
C****
C****   THE CURRENT COMMAND LINE IN THE SYSTEM BUFFER MAY HAVE THE PARAMETERS.
C****   GET A PARAMETER LIST FROM THE USER.
C****
      NTOKES=1
  100 CONTINUE
      CALL GETOKE(TOKEN,NCHARS)                                         ! /* GET A TOKEN FROM THE USER PARAMETER LINE
      CALL UPCASE(TOKEN,NCHARS)                                         ! /* CONVERT THE TOKEN TO UPPERCASE
      IF(NCHARS.GT.0) GO TO 150
      IF(NOW.EQ.1) PRINT 140
  140 FORMAT(' <  ENTER PARAMETERS  >')
      CALL RDLINE                                                       ! /* GET ANOTHER USER PARAMETER LINE
      NTOKES=0
      GO TO 100
  150 CONTINUE
      NTOKES=NTOKES+1
      DO 190 I=1,NPARS                                                  ! /* SEE IF IT IS A PARAMETER NAME
      LEN=LENGTH(I)                                                     ! /* GET THE LEGAL PARAMETER NAME LENGTH
      IPARAM=I                                                          ! /* SAVE THE INDEX
      IF(TOKEN(1:NCHARS).EQ.NAMES(I)(1:LEN).AND.NCHARS.EQ.LEN) GO TO 200
  190 CONTINUE                                                          ! /* STILL LOOKING FOR THE NAME
      IF(TOKEN(1:NCHARS).EQ.'END'.AND.NCHARS.EQ.3) GO TO 1000           ! /* END OF PARAM LIST?
      IF(NS.NE.0) GO TO 230
      PRINT 191, TOKEN(1:NCHARS)
  191 FORMAT(' ***  ERROR  *** T2F DOES NOT HAVE A PARAMETER ',
     *  'NAMED ',A10)
      IERROR=IERROR+1
      GO TO 100
C****
C****    FOUND THE PARAMETER NAME, NOW FIND THE VALUE
C****
  200 CONTINUE
      NS=0
      NPARAM=IPARAM
  210 CONTINUE                                                          ! /*  NOW FIND THE VALUE
      CALL GETOKE(TOKEN,NCHARS)
      CALL UPCASE(TOKEN,NCHARS)
      NTOKES=NTOKES+1
      IF(NCHARS.GT.0) GO TO 230                                         ! /* END OF LINE?
      IF(NOW.EQ.1) PRINT 140                                            ! /* THIS ALLOWS A PARAMETER TO BE ON A DIFFERENT LINE FROM THE NAME
      CALL RDLINE                                                       ! /* GET ANOTHER LINE
      NTOKES=0
      GO TO 210
  230 CONTINUE
      IF(TYPES(NPARAM).NE.'A') GO TO 240
      IF(NAMES(NPARAM).EQ.'ADDWB'.AND.TOKEN(1:NCHARS).EQ.'YES')
     *    IADDWB=1
      IF(NAMES(NPARAM).EQ.'COORDS') COORDS=TOKEN(1:NCHARS)
      IF(NAMES(NPARAM).EQ.'WINDOW') WINDOW=TOKEN(1:NCHARS)
      GO TO 100
  240 CONTINUE
      CALL DCODE(TOKEN,NCHARS,AREAL,ISTAT)                              ! /* TRY AND DECODE IT
      IF(ISTAT.EQ.2) GO TO 420                                          ! /* =2 MEANS IT IS A NUMERIC
      IERROR=IERROR+1                                                   ! /* DCODE PRINTED AN ERROR
      GO TO 100
  420 IF(TYPES(NPARAM).EQ.'L') GO TO 500
      VALS(NPARAM)=AREAL                                                ! /*  FLOATING POINT VALUES
      GO TO 100
  500 CONTINUE                                                          ! /*  32 BIT INTEGER VALUES
      LVALS(NPARAM)=AREAL
      GO TO 100
C****
C****   FINISHED A LIST, NOW DO THE ERROR AND VALIDITY CHECKS
C****
 1000 CONTINUE
      DO 1010 I=1,8
      ITEMP=I
      IF(WINDOW.EQ.LWINDS(I)) GO TO 1030
 1010 CONTINUE
      PRINT 1020,WINDOW
 1020 FORMAT(' ***  ERROR  ***  ',A4,' IS NOT A VALID WINDOW TYPE.')
      IERROR=IERROR+1
 1030 IWINDO=ITEMP
      IF(COORDS.EQ.'RECT'.OR.COORDS.EQ.'POLR' .OR. coords .EQ. 'AMPL' )
     &    GO TO 1050
      PRINT 1040,COORDS
 1040 FORMAT(' ***  ERROR  ***  ',A4,' IS NOT A VALID COORDINATE SYSTEM.
     *   ')
 1050 CONTINUE
      IF( stime .LT. -1. .OR. stime .GT. 50. ) THEN
          PRINT *,' ***  ERROR  ***  Illegal stime.'
          ierror = ierror + 1
      ENDIF
      IF( etime .LT. -1. .OR. etime .GT. 50. ) THEN
          PRINT *,' ***  ERROR  ***  Illegal etime.'
          ierror = ierror + 1
      ENDIF
      IF( etime .LE.stime.AND. stime.NE.-1. .AND.etime.NE.-1.) THEN
          PRINT *,' ***  ERROR  ***  STIME must be less that ETIME.'
          ierror = ierror + 1
      ENDIF
      IF( winlen .LT. 0 ) THEN
          PRINT *,' ***  ERROR  ***  Illegal WINLEN of',winlen
          ierror = ierror + 1
      ENDIF
c      IF( winlen .EQ. 0 ) THEN
c          PRINT *,' ***  WARNING  ***  WINLEN not given.'
c          iwarn = iwarn + 1
c      ENDIF
      LSCR(1)=FNO
      LSCR(2)=LNO
      LSCR(3)=FTR
      LSCR(4)=LTR
      LSCR(5)=IWINDO
      SCR(6)=WINLEN
      LSCR(7)=FFTLEN
      IF( coords .EQ. 'RECT' ) lscr(8) = 1
      IF(COORDS.EQ.'POLR') LSCR(8)=2
      IF( coords .EQ. 'AMPL' ) lscr(8) = 3
      LSCR(9)=LPRINT
      LSCR(10)=IADDWB
      scr(11) = stime
      scr(12) = etime
      IF(IAND(LPRINT,1).EQ.1) THEN
         PRINT *,' T2F PARAMETERS:',(LSCR(I),I=1,5),
     *   SCR(6),(LSCR(I),I=7,10),scr(11),scr(12)

      ENDIF
      CALL WRDISC(MUNIT,SCR,NWRDS)
      NLISTS=NLISTS+1
      LLNO=LNO
      LNO=9999999                                                       ! /* DEFAULT THE DEFAULTS
      NS=0                                                              ! /* SET THE NUMBER OF MULTI-VALUED PARAMETER ENTRIES BACK TO ZER0
 2020 CALL GETOKE(TOKEN,NCHARS)                                         ! /* GET THE NEXT TOKEN
      CALL UPCASE(TOKEN,NCHARS)
      NTOKES=NTOKES+1
      IF(NCHARS.GT.0) GO TO 2030                                        ! /* WAS IT THE END OF A LINE?
      IF(NOW.EQ.1) PRINT 140
      CALL RDLINE                                                       ! /* GET ANOTHER LINE
      NTOKES=0
      GO TO 2020
 2030 IF(TOKEN(1:NCHARS).NE.'END'.OR.NCHARS.NE.3) GO TO 150
      RETURN                                                            ! /*  FINISHED ALL OF THE PARAMETERS!!!
      END


      SUBROUTINE MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A,
     $                   LDA, E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANK, TOL,
     $                   IWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     Let A and E be M-by-N matrices with E in column echelon form.
C     Let AA and EE be the following submatrices of A and E:
C       AA := A(IFIRA : M ; IFICA : N)
C       EE := E(IFIRA : M ; IFICA : N).
C     Let Aj and Ej be the following submatrices of AA and EE:
C       Aj := A(IFIRA : M ; IFICA : IFICA + NCA - 1) and
C       Ej := E(IFIRA : M ; IFICA + NCA : N).
C
C     To transform (AA,EE) such that Aj is row compressed while keeping
C     matrix Ej in column echelon form (which may be different from the
C     form on entry).
C     In fact the routine performs the j-th step of Algorithm 3.2.1 in
C     [1]. Furthermore, it determines the rank RANK of the submatrix Ej,
C     which is equal to the number of corner points in submatrix Ej.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPDATQ  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix Q the orthogonal row transformations, as follows:
C             = .FALSE.: Do not form Q;
C             = .TRUE.:  The given matrix Q is updated by the orthogonal
C                        row transformations used in the reduction.
C
C     UPDATZ  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix Z the orthogonal column transformations, as
C             follows:
C             = .FALSE.: Do not form Z;
C             = .TRUE.:  The given matrix Z is updated by the orthogonal
C                        column transformations used in the reduction.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             M is the number of rows of the matrices A, E and Q.
C             M >= 0.
C
C     N       (input) INTEGER
C             N is the number of columns of the matrices A, E and Z.
C             N >= 0.
C
C     IFIRA   (input) INTEGER
C             IFIRA is the first row index of the submatrices Aj and Ej
C             in the matrices A and E, respectively.
C
C     IFICA   (input) INTEGER
C             IFICA and IFICA + NCA are the first column indices of the
C             submatrices Aj and Ej in the matrices A and E,
C             respectively.
C
C     NCA     (input) INTEGER
C             NCA is the number of columns of the submatrix Aj in A.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, A(IFIRA : M ; IFICA : IFICA + NCA - 1) contains
C             the matrix Aj.
C             On exit, it contains the matrix A with AA that has been
C             row compressed while keeping EE in column echelon form.
C
C     LDA     INTEGER
C             The leading dimension of array A. LDA >= MAX(1,M).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, E(IFIRA : M ; IFICA + NCA : N) contains the
C             matrix Ej which is in column echelon form.
C             On exit, it contains the transformed matrix EE which is
C             kept in column echelon form.
C
C     LDE     INTEGER
C             The leading dimension of array E. LDE >= MAX(1,M).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,*)
C             On entry, if UPDATQ = .TRUE., then the leading M-by-M
C             part of this array must contain a given matrix Q (e.g.
C             from a previous call to another SLICOT routine), and on
C             exit, the leading M-by-M part of this array contains the
C             product of the input matrix Q and the row transformation
C             matrix that has transformed the rows of the matrices A
C             and E.
C             If UPDATQ = .FALSE., the array Q is not referenced and
C             can be supplied as a dummy array (i.e. set parameter
C             LDQ = 1 and declare this array to be Q(1,1) in the calling
C             program).
C
C     LDQ     INTEGER
C             The leading dimension of array Q. If UPDATQ = .TRUE.,
C             LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,*)
C             On entry, if UPDATZ = .TRUE., then the leading N-by-N
C             part of this array must contain a given matrix Z (e.g.
C             from a previous call to another SLICOT routine), and on
C             exit, the leading N-by-N part of this array contains the
C             product of the input matrix Z and the column
C             transformation matrix that has transformed the columns of
C             the matrices A and E.
C             If UPDATZ = .FALSE., the array Z is not referenced and
C             can be supplied as a dummy array (i.e. set parameter
C             LDZ = 1 and declare this array to be Z(1,1) in the calling
C             program).
C
C     LDZ     INTEGER
C             The leading dimension of array Z. If UPDATZ = .TRUE.,
C             LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1.
C
C     ISTAIR  (input/output) INTEGER array, dimension (M)
C             On entry, ISTAIR contains information on the column
C             echelon form of the input matrix E as follows:
C             ISTAIR(i) = +j: the boundary element E(i,j) is a corner
C                             point;
C                         -j: the boundary element E(i,j) is not a
C                             corner point (where i=1,...,M).
C             On exit, ISTAIR contains the same information for the
C             transformed matrix E.
C
C     RANK    (output) INTEGER
C             Numerical rank of the submatrix Aj in A (based on TOL).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance used when considering matrix elements
C             to be zero.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
C
C     REFERENCES
C
C     [1] Beelen, Th.
C         New Algorithms for Computing the Kronecker structure of a
C         Pencil with Applications to Systems and Control Theory.
C         Ph.D.Thesis, Eindhoven University of Technology,
C         The Netherlands, 1987.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations and is backward stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MB04FZ by Th.G.J. Beelen,
C     Philips Glass Eindhoven, Holland.
C
C     REVISIONS
C
C     June 13, 1997, V. Sima.
C     November 24, 1997, A. Varga: array starting point A(KK,LL)
C                                  correctly set when calling DLASET.
C     December 08, 2016, V. Sima.
C
C     KEYWORDS
C
C     Echelon form, orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      LOGICAL           UPDATQ, UPDATZ
      INTEGER           IFICA, IFIRA, LDA, LDE, LDQ, LDZ, M, N, NCA,
     $                  RANK
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           ISTAIR(*), IWORK(*)
      DOUBLE PRECISION  A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL           LZERO
      INTEGER           I, IFICA1, IFIRA1, II, IP, IST1, IST2, ISTPVT,
     $                  ITYPE, JC1, JC2, JPVT, K, KK, L, LL, LSAV, MJ,
     $                  MK1, MXRANK, NJ
      DOUBLE PRECISION  BMX, BMXNRM, EIJPVT, SC, SS
C     .. External Functions ..
      INTEGER           IDAMAX
      EXTERNAL          IDAMAX
C     .. External Subroutines ..
      EXTERNAL          DLAPMT, DLASET, DROT, DROTG, DSWAP
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MIN
C     .. Executable Statements ..
C
      RANK = 0
      IF ( M.LE.0 .OR. N.LE.0 )
     $   RETURN
C
C     Initialisation.
C
C     NJ = number of columns in submatrix Aj,
C     MJ = number of rows in submatrices Aj and Ej.
C
      NJ = NCA
      MJ = M + 1 - IFIRA
      IFIRA1 = IFIRA - 1
      IFICA1 = IFICA - 1
C
      DO 20 I = 1, NJ
         IWORK(I) = I
   20 CONTINUE
C
      K = 1
      LZERO = .FALSE.
      RANK = MIN( NJ, MJ )
      MXRANK = RANK
C
C     WHILE ( K <= MXRANK ) and ( LZERO = FALSE ) DO
   40 IF ( ( K.LE.MXRANK ) .AND. ( .NOT.LZERO ) ) THEN
C
C        Determine column in Aj with largest max-norm.
C
         BMXNRM = ZERO
         LSAV = K
         KK = IFIRA1 + K
C
         DO 60 L = K, NJ
C
C           IDAMAX call gives the relative index in column L of Aj where
C           max element is found.
C           Note: the first element in column L is in row K of
C                 matrix Aj.
C
            LL = IFICA1 + L
            BMX = ABS( A(IDAMAX( MJ-K+1, A(KK,LL), 1 )+KK-1,LL) )
            IF ( BMX.GT.BMXNRM ) THEN
               BMXNRM = BMX
               LSAV = L
            END IF
   60    CONTINUE
C
         LL = IFICA1 + K
         IF ( BMXNRM.LE.TOL ) THEN
C
C           Set submatrix of Aj to zero.
C
            CALL DLASET( 'Full', MJ-K+1, NJ-K+1, ZERO, ZERO, A(KK,LL),
     $                   LDA )
            LZERO = .TRUE.
            RANK = K - 1
         ELSE
C
C           Check whether columns have to be interchanged.
C
            IF ( LSAV.NE.K ) THEN
C
C              Interchange the columns in A which correspond to the
C              columns lsav and k in Aj. Store the permutation in IWORK.
C
               CALL DSWAP( M, A(1,LL), 1, A(1,IFICA1+LSAV), 1 )
               IP = IWORK(LSAV)
               IWORK(LSAV) = IWORK(K)
               IWORK(K) = IP
            END IF
C
            K = K + 1
            MK1 = N - LL + 1
C
            DO 80 I = MJ, K, -1
C
C              II = absolute row number in A corresponding to row i in
C                   Aj.
C
               II = IFIRA1 + I
C
C              Construct Givens transformation to annihilate Aj(i,k).
C              Apply the row transformation to whole matrix A
C              (NOT only to Aj).
C              Update row transformation matrix Q, if needed.
C
               CALL DROTG( A(II-1,LL), A(II,LL), SC, SS )
               CALL DROT( MK1-1, A(II-1,LL+1), LDA, A(II,LL+1), LDA, SC,
     $                    SS )
               A(II,LL) = ZERO
               IF ( UPDATQ )
     $            CALL DROT( M, Q(1,II-1), 1, Q(1,II), 1, SC, SS )
C
C              Determine boundary type of matrix E at rows II-1 and II.
C
               IST1 = ISTAIR(II-1)
               IST2 = ISTAIR(II)
               IF ( ( IST1*IST2 ).GT.0 ) THEN
                  IF ( IST1.GT.0 ) THEN
C
C                    boundary form = (* x)
C                                    (0 *)
C
                     ITYPE = 1
                  ELSE
C
C                    boundary form = (x x)
C                                    (x x)
C
                     ITYPE = 3
                  END IF
               ELSE
                  IF ( IST1.LT.0 ) THEN
C
C                    boundary form = (x x)
C                                    (* x)
C
                     ITYPE = 2
                  ELSE
C
C                    boundary form = (* x)
C                                    (0 x)
C
                     ITYPE = 4
                  END IF
               END IF
C
C              Apply row transformation also to matrix E.
C
C              JC1 = absolute number of the column in E in which stair
C                    element of row i-1 of Ej is present.
C              JC2 = absolute number of the column in E in which stair
C                    element of row i of Ej is present.
C
C              Note: JC1 < JC2   if ITYPE = 1.
C                    JC1 = JC2   if ITYPE = 2, 3 or 4.
C
               JC1 = ABS( IST1 )
               JC2 = ABS( IST2 )
               JPVT = MIN( JC1, JC2 )
C
               CALL DROT( N-JPVT+1, E(II-1,JPVT), LDE, E(II,JPVT), LDE,
     $                    SC, SS )
               EIJPVT = E(II,JPVT)
C
               IF ( ITYPE.EQ.1 ) THEN
C
C                 Construct column Givens transformation to annihilate
C                 E(ii,jpvt).
C                 Apply column Givens transformation to matrix E
C                 (NOT only to Ej).
C
                  CALL DROTG( E(II,JPVT+1), E(II,JPVT), SC, SS )
                  CALL DROT( II-1, E(1,JPVT+1), 1, E(1,JPVT), 1, SC,
     $                       SS )
                  E(II,JPVT) = ZERO
C
C                 Apply this transformation also to matrix A
C                 (NOT only to Aj).
C                 Update column transformation matrix Z, if needed.
C
                  CALL DROT( M, A(1,JPVT+1), 1, A(1,JPVT), 1, SC, SS )
                  IF ( UPDATZ ) CALL DROT( N, Z(1,JPVT+1), 1, Z(1,JPVT),
     $                                     1, SC, SS )
C
               ELSE IF ( ITYPE.EQ.2 ) THEN
                  IF ( ABS( EIJPVT ).LE.TOL ) THEN
C
C                                                        (x x)    (* x)
C                    Boundary form has been changed from (* x) to (0 x).
C
                     ISTPVT = ISTAIR(II)
                     ISTAIR(II-1) = ISTPVT
                     ISTAIR(II) = -(ISTPVT+1 )
                     E(II,JPVT) = ZERO
                  END IF
C
               ELSE IF ( ITYPE.EQ.4 ) THEN
                  IF ( ABS( EIJPVT ).GT.TOL ) THEN
C
C                                                        (* x)    (x x)
C                    Boundary form has been changed from (0 x) to (* x).
C
                     ISTPVT = ISTAIR(II-1)
                     ISTAIR(II-1) = -ISTPVT
                     ISTAIR(II) = ISTPVT
                  END IF
               END IF
   80       CONTINUE
C
         END IF
         GO TO 40
      END IF
C     END WHILE 40
C
C     Permute columns of Aj to original order.
C
      CALL DLAPMT( .FALSE., IFIRA1+RANK, NJ, A(1,IFICA), LDA, IWORK )
C
      RETURN
C *** Last line of MB04TT ***
      END


      subroutine genxpkg(nx,x,xpkg,iper,imsg,itol,ztol,ialg,ier)
c
c  from an x axis assemble a "package":
c
c  MOD DMC Feb 2010: handle very small grids: nx=2, nx=3...
c  interchanged meaning of xpkg(1,4) and xpkg(3,4);
c  xpkg(3,4) only set if nx.ge.3;
c  xpkg(4,4) only set if nx.ge.4.
c
c  there are corresponding changes in xlookup: simplified code lookup
c  code for the cases nx=2 and nx=3.
c
c     xpkg(j,1) = x(j), j = 1 to nx    ... nx.ge.2
c
c     if(abs(ialg).ne.3) then...
c       for j=1:nx-1
c       xpkg(j,2) = h(j) = x(j+1)-x(j), j=1 to nx-1
c     else
c       for j=1:nx-1
c       xpkg(j,2) = index location, with linear offset, of
c                   xpkg(1,1)+<h>*(j-1) in the original x(1:nx)
c            (piecewise linear indexing function)
c     endif
c     xpkg(nx,2) = <h> = (x(nx)-x(1))/(nx-1)
c
c     xpkg(j,3) = 1/h(j)
c     xpkg(nx,3) = 1/<h>
c
c     xpkg(1,4) = +/- tolerance epsilon for out-of-range warnings/errors
c                 +if message is to be written on out of range errors
c                 -if no message to be written.  In either case, a
c                        warning flag is set.
c
c     xpkg(2,4) = 1.0 if x is *periodic*, else 0.0
c
c  only set if nx.ge.3:
c     xpkg(3,4) = 0.0 if x is *evenly spaced* (to ztol or 5.e-7 rel) else:
c                   = 1.0 => use (1/h) newton's method like search algorithm
c                   = 2.0 => use binary search algorithm
c                   = 3.0 => use piecewise-linear indexing function...
c
c  only set if nx.ge.4:
c     xpkg(4,4) = 0.0 -- do not use past search result as start point
c                        for next search;
c               = 1.0 -- do use past search result as start point for
c                        next search.
c
c  tolerance epsilon means:
c     if xtest is within epsilon*max(abs(x(1)),abs(x(nx))) outside the
c     range [x(1),x(nx)] treat xtest as being at the endpoint x(1) or
c     x(nx) whichever is closer.
c
c input arguments:
c
      integer nx                        ! length of x, .ge.4
      real x(nx)                        ! x axis vector, strict ascending
c
      integer iper                      ! =1 if x is periodic
      integer imsg                      ! =1 for range error messages
      integer itol                      ! =1 to specify tolerance, else default
c
c default tolerance is 5.0e-7
c
      real ztol                         ! range tolerance, if itol=1
c
c lookup algorithm selection for uneven grids:
c
      integer ialg                      ! = +/- 1:  <1/h(j)> "Newton" method
c                                       ! = +/- 2:  binary search
c                                       ! = +/- 3:  indexing function
c
c       to use past search result as init. cond. for next search, give
c       ialg .lt. 0; otherwise give ialg .gt. 0.
c
c output arguments:
c
      real xpkg(nx,4)                   ! xpkg, as described above
      integer ier                       ! completion code, 0=OK
c
c------------------------------------------------
c
      if(nx.lt.2) then
         write(6,*) ' %genxpkg:  nx.ge.2 required!'
         ier=1
         return
      else
         ier=0
      endif
c
      ialgu=ialg
      if(ialgu.eq.0) ialgu=3
      if(iabs(ialgu).gt.3) ialgu=3
c
c  get tolerance for end point range check & even spacing check
c
      if(itol.eq.1) then
         ztolr=abs(ztol)
      else
         ztolr=5.0e-7
      endif
c
      ztola=max(abs(x(1)),abs(x(nx)))*ztolr
c
c  assume even spacing for now...
c
      if(nx.ge.3) then
         xpkg(3,4)=0.0
      endif
c
c  mark if x axis is a periodic coordinate
c
      if(iper.eq.1) then
         xpkg(2,4)=1.0
      else
         xpkg(2,4)=0.0
      endif
c
c  store tolerance parameter
c
      xpkg(1,4)=ztola
c
c  mark if messages are to be written if range lookup errors occur
c
      if(imsg.eq.1) then
         continue                       ! xpkg(1,4) left .gt. 0.0
      else
         xpkg(1,4)=-xpkg(1,4)
      endif
c
c  OK check linearity and spacing
c
      ier=0
c
      xpkg(nx,2)=(x(nx)-x(1))/(nx-1)    ! average spacing
c
      do ix=1,nx
         xpkg(ix,1)=x(ix)
         if((ier.eq.0).and.(ix.lt.nx)) then
            if(x(ix+1).le.x(ix)) then
               ier=1
               write(6,*) ' %genxpkg:  x axis not strict ascending!'
            else
               zh=x(ix+1)-x(ix)
c
c  checking even spacing now...
c
               if(nx.ge.3) then
                  if(abs(zh-xpkg(nx,2)).gt.ztola) xpkg(3,4)=1.0
               endif
c
               xpkg(ix,2)=zh
               xpkg(ix,3)=1.0/zh
c
            endif
         endif
      enddo
c
      if(ier.ne.0) return
c
c  OK, store inverse average spacing
c
      xpkg(nx,3)=1.0/xpkg(nx,2)
c
c  if even spacing is detected, redefine x axis slightly, for
c  improved regularity of behaviour
c
      if(nx.ge.3) then
c
         if(xpkg(3,4).eq.0.0) then
            do ix=1,nx-2
               ixp=ix+1
               xpkg(ixp,1)=xpkg(1,1)+ix*xpkg(nx,2)
            enddo
            if(nx.gt.3) then
               if(ialgu.lt.0) then
                  xpkg(4,4)=1.0 ! check init guess
               else
                  xpkg(4,4)=0.0
               endif
            endif
         endif
c
c  if uneven spacing is detected, must use an algorithm...
c
         if(xpkg(3,4).ne.0.0) then
            xpkg(3,4)=abs(ialgu)
            if(nx.gt.3) then
               if(ialgu.lt.0) then
                  xpkg(4,4)=1.0 ! check init guess
               else
                  xpkg(4,4)=0.0
               endif
            endif
c
            if(abs(ialgu).eq.3) then
c
c  construct a piecewise linear indexing function
c
               xpkg(1,2)=1.0
               xtest=xpkg(1,1)
               itest=1
               do i=2,nx-1
                  xtest=xtest+xpkg(nx,2) ! x1 + (i-1)*<h>
 10               continue
                  if((xpkg(itest,1).le.xtest).and.
     >                 (xtest.le.xpkg(itest+1,1))) then
                     xpkg(i,2)=itest+(xtest-xpkg(itest,1))/
     >                    (xpkg(itest+1,1)-xpkg(itest,1))
                  else
                     itest=itest+1
                     go to 10
                  endif
               enddo
c
c  (implicitly, xpkg(nx,2)=nx*1.0; but we leave <h> in xpkg(nx,2)
c   instead...)
c
            endif
         endif
c
      endif  ! nx.ge.3
c
      return
      end


      subroutine anfm02(q,iq,r,ir,n,m,icol,io)
C     SUBROUTINE ANFM02(Q,IQ,R,IR,N,M,ICOL,IO)
C
C***********************************************************************
C                                                                      *
C                                                                      *
C     Copyright:        Eduardo Casas Renteria                         *
C                       Cecilia Pola Mendez                            *
C                                                                      *
C       Departamento de Matematicas,Estadistica y Computacion          *
C       -----------------------------------------------------          *
C                       UNIVERSIDAD DE CANTABRIA                       *
C                       ------------------------                       *
C                            FEBRERO 1987                              *
C                                                                      *
C***********************************************************************
C
C     OBJETIVO:
C        Esta subrutina modifica la factorizacion QR de una matriz,
C        cuando a esta se le quita una columna.
C
C     LISTA DE LLAMADA:
C     DE ENTRADA:
C
C        Q      Matriz de dimension (IQ,N).En sus N primeras filas
C               contiene a la matriz " q " de la factorizacion QR
C               inicial.
C
C        IQ     Primera dimension de Q. IQ >= N.
C
C        R      Matriz de dimension (IR,N).En sus N primeras filas
C               se tiene a la matriz " r " de la factorizacion QR
C               inicial.
C
C        IR     Primera dimension de R. IR >= N.
C
C        N      Numero de filas de R,numero de filas y columnas de Q.
C
C        M      Numero de columnas de R.
C
C        ICOL   Numero de columna que se desea quitar en la matriz.
C
C        IO     Numero de canal de salida de resultados.
C
C     DE SALIDA:
C
C        Q      Recoge la matriz ortogonal correspondiente a la nueva
C               factorizacion QR.
C
C        R      En R se tiene la matriz triangular superior de la nueva
C               factorizacion QR.
C
C        Esta subrutina trabaja en doble precision via una sentencia
C     "implicit":
C                Implicit double precision (a-h,o-z)
C
C     SUBPROGRAMAS AUXILIARES: daxpy, dcopy,ddot,dscal,d1mach
C     FUNCIONES FORTRAN INTRINSECAS: mod,sign
C
C
      implicit double precision (a-h,o-z)
      dimension q(iq,*),r(ir,*)
C
C     Se comprueba si los valores de las variables son correctos
C
      if(m.lt.icol .or. m.lt.2 .or. icol.lt.1 .or. iq.lt.n .or.
     &   ir.lt.n) then
         write(io,'(10x,A)') 'INCORRECT LIST OF CALLING IN ANFM02.'
         stop
      end if
C
C     Si la columna que se desea quitar ocupa el ultimo lugar en la
C     matriz,el proceso finaliza
C
      if(m.eq.icol) return
C
C     Se modifican adecuadamente las ultimas columnas de R y la matriz Q
C
css      epsmch=d1mach(4)
      epsmch=dlamch('p')

      do 15 i=icol+1,m
         if(r(i,i).ne.0.d0) then
            i1=i-1
            a=dnrm2(2,r(i1,i),1)
            if(a.gt.epsmch) then
               if(r(i1,i).ne.0.d0) a=sign(a,r(i1,i))
               call dscal(2,1.d0/a,r(i1,i),1)
               r(i1,i)=1.d0+r(i1,i)
               s1=r(i1,i)
               s2=r(i,i)
               s=s2/s1
               do 10 j=1,n
                  t=-q(j,i1)-q(j,i)*s
                  q(j,i1)=q(j,i1)+t*s1
                  q(j,i)=q(j,i)+t*s2
10             continue
               do 12 j=i+1,m
                  t=-r(i1,j)-r(i,j)*s
                  r(i1,j)=r(i1,j)+t*s1
                  r(i,j)=r(i,j)+t*s2
12             continue
               r(i1,i)=-a
            end if
         end if
15    continue
C
C     Se coloca en las M-1 primeras columnas la matriz R resultante
C
      do 20 j=icol+1,m
         i1=j-1
         call dcopy(i1,r(1,j),1,r(1,i1),1)
20    continue
      end


! { dg-do  run }
! { dg-options "-ffrontend-optimize -fdump-tree-original" }
! PR 66041 - this used to ICE with an incomplete fix for the PR.
program main
  implicit none
  real, dimension(1,-2:0) :: a1
  real, dimension(3,2) :: b1
  real, dimension(2) :: c1

  data a1 /17., -23., 29./
  data b1 / 2.,  -3.,  5.,  -7., 11., -13./

  c1 = matmul(a1(1,:), b1)
  if (any (c1-[248., -749.] /= 0.)) call abort
end program main

! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "original" } }


SUBROUTINE rdcurv(stype,curname)
!     Read data for curves
USE curv_db
USE c_input ,ONLY: listen, exists, lures, getint, getrea, words, param
IMPLICIT NONE

  CHARACTER (len=*),INTENT(IN) :: stype
  CHARACTER (len=mnam),INTENT(IN) :: curname

  !--- Local variables
  INTEGER(kind=4)::  ltype, npts, k, ndim
  TYPE(curpar),POINTER ::  cur

  CALL listen('RDCUR1')
  IF (exists('CURVED')) THEN

    ltype=getint('LTYPE ',0,'!Time Function Type ...............')
    SELECT CASE (ltype)
    CASE( 1 )            ! Constant
      ndim = 5

    CASE( 2 )          ! A + B sin[ W(t-t0)]
      ndim = 8

    CASE( 3 )          ! Multilinear
      npts=getint('NUMPTS',0,'!Number of Sample Points .........')
      ndim = 2*npts+5

    CASE( 4 )          ! Cosine
      ndim = 6

    CASE( 5 )          ! Cosine until maximum, then constant
      ndim = 6

    CASE( 6 )
      CALL runend('RDCURV: CURVE TYPE 6 not ALLOWED.')
      !ndim = 7

    CASE( 7 )          ! slope-constant
      ndim = 6

    CASE( 8 )          ! A + B cos(Wt)
      ndim = 8

    CASE( 9 )          ! cosinusoidal increment over a constant
      ndim = 8

    CASE( 10)          ! linear decay after an initial delay
      ndim = 6

    CASE( 11)          ! hat over a constant
      ndim = 7

    CASE    ( 12)            ! Linear
      ndim = 5

    CASE DEFAULT
      CALL runend('RDCUR1: ERROR IN CURVE TYPE .......')
    END SELECT
  ELSE
      CALL runend('RDCUR1: CURVE_DATA CARD EXPECTED   ')
  END IF

  ALLOCATE (cur)                 !Allocation of pointer to curv N
  ALLOCATE (cur%vec(ndim))       !memory for parameters
  cur%vec(1) = REAL(ltype,8)       ! type of curve (ltype)
  cur%dim    = ndim                !storage size
  cur%name   = curname             !curve name

  SELECT CASE (TRIM(stype))
  CASE('VELOC')
    cur%vec(2) = -1d0 ! type of curve (stype)
  CASE('FORCE')
    cur%vec(2) =  1d0 ! type of curve (stype)
  CASE('COUTP')
    cur%vec(2) =  0d0 ! type of curve (stype)
  CASE DEFAULT
    CALL RUNEND('RDCURV: not recognizable STYPE ')
  END SELECT

  SELECT CASE (ltype)
  CASE( 1 )            ! Constant
    cur%vec(3) = getrea('START ',0d0,' Starting Time ..... <T0> .........')
    cur%vec(4) = getrea('END   ',1d9,' Ending Time ....... <TEND> .......')
    cur%vec(5) = getrea('CONST ',1d0,' Function Value .... <A> ..........')

  CASE( 2 )          ! A + B sin[ W(t-t0)]
    cur%vec(3) = getrea('START ',0d0,' Starting Time ..... <T0> .........')
    cur%vec(4) = getrea('END   ',1d9,' Ending Time ....... <TEND> .......')
    cur%vec(5) = getrea('CONST ',0d0,' Medium Value ...... <A> ..........')
    cur%vec(6) = getrea('AMPLI ',1d0,' Amplitude ......... <B> ..........')
    cur%vec(7) = getrea('FREQ  ',0d0,'!Circular Frequency  <W> ..........')
    cur%vec(8) = getrea('PHASE ',0d0,' Initial phase <PHASE> ............')

  CASE( 3 )          ! Multilinear
    DO k=1,npts
      CALL listen('RDCUR1')
      IF (exists('TIME  ')) THEN
        cur%vec(2*k+4) = getrea('TIME  ',0d0,'!-Time Instant  .....................')
        cur%vec(2*k+5) = getrea('VALUE ',0d0,'!-Function Value at Time Instant ...')
      ELSE IF( LEN_TRIM(words(1)) == 0 )THEN  !no key-word in line
        cur%vec(2*k+4) = param(1)
        cur%vec(2*k+5) = param(2)
      ELSE
        CALL runend('RDCUR1: Error in the curve input.  ')
      END IF
      WRITE (lures,"('  Sample Point ',I4,' TIME ',e12.4,' VALUE ',e12.4 )", &
                   ERR=9999) k,cur%vec(2*k+4), cur%vec(2*k+5)
      IF( k > 1 )THEN
        IF(cur%vec(2*k+4) <= cur%vec(2*k+2)) THEN
          WRITE (lures,"('  ERROR, TIME values must grow monotically',/,      &
              & 'Time_k <= Time_k-1',e12.4 ,'<=',e12.4 )", ERR=9999) cur%vec(2*k+4), cur%vec(2*k+2)
          CALL runend ('RDCURV: ERROR IN CURVE DATA .......')
        END IF
      END IF
    END DO
    WRITE (lures,"(/)")
    cur%vec(3) = cur%vec(6)          ! START
    cur%vec(4) = cur%vec(2*npts+4)   ! END
    cur%vec(5) = 1                   ! first interval

  CASE( 4 )          ! Cosine
    cur%vec(3) = getrea('START ',0d0,' Starting Time ..... <T0> .........')
    cur%vec(4) = getrea('END   ',1d9,' Ending Time ....... <TEND> .......')
    cur%vec(5) = getrea('AMPLI ',1d0,' Amplitude ......... <A> ..........')
    cur%vec(6) = getrea('FREQ  ',0d0,'!Circular Frequency  <W> ..........')

  CASE( 5 )          ! Cosine until maximum, then constant
    cur%vec(3) = getrea('START ',0d0,' Starting Time ..... <T0> .........')
    cur%vec(4) = getrea('END   ',1d9,' Ending Time ....... <TEND> .......')
    cur%vec(5) = getrea('AMPLI ',1d0,' Amplitude ......... <A> ..........')
    cur%vec(6) = getrea('FREQ  ',0d0,'!Circular Frequency  <W> ..........')

  !CASE( 6 )
  !  cur%vec(3) = getrea('START ',0d0,' Starting Time ..... <T0> .........')
  !  cur%vec(4) = getrea('END   ',1d9,' Ending Time ....... <TEND> .......')
  !  cur%vec(5) = getrea('AMPLI ',1d0,' Amplitude ......... <B> ..........')
  !  cur%vec(6) = getrea('FREQ  ',0d0,'!Circular Frequency. <W> ..........')
  !  cur%vec(7) = getrea('TSTOP ',0d0,'!Cut time .......... <TSTOP> ......')

  CASE( 7 )          ! slope-constant
    cur%vec(3) = getrea('START ',0d0,' Starting Time ..... <T0> .........')
    cur%vec(4) = getrea('END   ',1d9,' Ending Time ....... <TEND> .......')
    cur%vec(5) = getrea('AMPLI ',1d0,' Amplitude ......... <A> ..........')
    cur%vec(6) = getrea('FREQ  ',0d0,'!Duration of slope part <FREQ> ....')

  CASE( 8 )          ! A + B cos(Wt)
    cur%vec(3) = getrea('START ',0d0,' Starting Time ..... <T0> .........')
    cur%vec(4) = getrea('END   ',1d9,' Ending Time ....... <TEND> .......')
    cur%vec(5) = getrea('CONST ',0d0,' Constant part ..... <A> ..........')
    cur%vec(6) = getrea('AMPLI ',1d0,' Amplitude ......... <B> ..........')
    cur%vec(7) = getrea('FREQ  ',0d0,'!Frequency ......... <W> ..........')
    cur%vec(8) = getrea('PHASE ',0d0,' Initial phase <PHASE> ............')

  CASE( 9 )          ! cosinusoidal increment over a constant
    cur%vec(3) = getrea('START ',0d0,' Starting Time ..... <T0> .........')
    cur%vec(4) = getrea('END   ',1d9,' Ending Time ....... <TEND> .......')
    cur%vec(5) = getrea('CONST ',1d0,' Constant part ..... <A> ..........')
    cur%vec(6) = getrea('AMPLI ',0d0,'!Amplitude [%] of inc. <B> ........')
    cur%vec(7) = getrea('STINC ',0d0,'!Start time of increm. <TC> .......')
    cur%vec(8) = getrea('FREQ  ',0d0,'!Duration of increment <W> ........')

  CASE( 10)          ! linear decay after an initial delay
    cur%vec(3) = getrea('START ',0d0,' Starting Time ..... <T0> .........')
    cur%vec(4) = getrea('END   ',1d9,' Ending Time ....... <TEND> .......')
    cur%vec(5) = getrea('AMPLI ',1d0,' Initial Amplitude . <A> ..........')
    cur%vec(6) = getrea('FREQ  ',0d0,'!Duration of decay . <W> ..........')

  CASE( 11)          ! hat over a constant
    cur%vec(3) = getrea('START ',0d0,' Starting Time ..... <T0> .........')
    cur%vec(4) = getrea('END   ',1d9,' Ending Time ....... <TEND> .......')
    cur%vec(5) = getrea('CONST ',0d0,' Constant part ..... <A> ..........')
    cur%vec(6) = getrea('AMPLI ',1d0,' Amplitude of funct. <B> ..........')
    cur%vec(7) = getrea('FREQ  ',0d0,'!Frequency ........  <W> ..........')

  CASE( 12)          ! linear
    cur%vec(3) = getrea('START ',0d0,' Starting Time ..... <T0> .........')
    cur%vec(4) = getrea('END   ',1d20,' Ending Time ....... <TEND> .......')
    cur%vec(5) = getrea('TANGT ',1d0,' Tangent Value ..... <C> ..........')

  CASE DEFAULT
      WRITE (lures,"(//                                                  &
    & '   ---- A V A I L A B L E   F U N C T I O N   T Y P E S ----',//  &
    & '  For All  Functions   F = 0       if  T < T0  or   T > TEND ',/  &
    & '  Code           Function Form ',/                                &
    & '    1      Constant Function   F = B                       ',/    &
    & '    2      F = A+B*SIN(W*(T-T0)+PHASE)                     ',/    &
    & '    3      Function Defined with its M discrete values',/         &
    & '              (T1,V1),(T2,V2) ...(TM,VM)',/                       &
    & '    4      F= B*(0.5-0.5*COS(W*(T-T0)))                      ',/  &
    & '    5      F= B*(0.5-0.5*COS(W*(T-T0)))   if   W*(T-T0) =< PI',/  &
    & '           F= B                           if   W*(T-T0) >  PI',/  &
      )",ERR=9999)
!    & '    6      F= B*(0.5-0.5*COS(W*(T-T0)))   if   W*(T-T0) =< PI',/  &
!    & '                                          or W*(TSTOP-T)=< PI',/  &
!    & '           F= B                    otherwise')",ERR=9999)
      WRITE (lures,"(//                                                  &
    & '    7      F= A*(T-Tc)/W                  if   T < Tc  ',/,       &
    & '           F= A                           if   T > Tc  ',/,       &
    & '    8      F= A+B*COS(W*(T-T0))',/,                               &
    & '    9      F= A*(1+B*(1-COS(2PI*(T-T0)/W))) if T0 < T < T0+W',/,  &
    & '           F= A                             otherwise       ',/,  &
    & '   10      F= A*(1-(T-T0)/W)                if T0 < T < T0+W',/,  &
    & '           F= 0                             otherwise       ',/,  &
    & '   11      Defininig Arg = MODULO((T-T0)/W,1)',/,                 &
    & '           F= A + 2*b*Arg                   if Arg <= 0.5',/,     &
    & '           F= A + 2*b*(1-Arg)               if Arg >= 0.5',/,     &
    & '   12      F= C * T ',//)",ERR=9999)
    CALL runend('RDCURV: ERROR IN CURVE TYPE .......')

  END SELECT
  CALL add_cur(cur,headcp,tailcp)
  WRITE (lures,"(/)")

RETURN
 9999 CALL runen2('')
END SUBROUTINE rdcurv


module precision
   use, intrinsic :: iso_fortran_env
   use, intrinsic :: IEEE_ARITHMETIC
   implicit none
   public
   ! precision of simulations
   integer, parameter :: dp = real64 ! preferred over selected_real_kind(15,307)
   ! only available as of fortran 2008
   real(dp), parameter :: eps = 0.00000001_dp
   real(dp), parameter :: epsApprox = 0.001_dp  ! for compairison but allows for more ronding error
   real(dp), parameter :: pi = 4.0_dp*atan(1.0_dp)

   real(dp) :: nan
   real(dp) :: inf
contains

   subroutine setup_runtime_floats()
      inf = ieee_value(inf, ieee_positive_inf)
      nan = ieee_value(nan, ieee_quiet_nan)
   end subroutine

end module precision


INTEGER, PARAMETER ::  i8 = SELECTED_INT_KIND(2)
INTEGER, PARAMETER :: i16 = SELECTED_INT_KIND(4)
INTEGER, PARAMETER :: i32 = SELECTED_INT_KIND(8)
INTEGER, PARAMETER :: i64 = SELECTED_INT_KIND(16)
INTEGER(i8)  :: onebyte = 0
INTEGER(i16) :: twobytes = 0
INTEGER(i32) :: fourbytes = 0
INTEGER(i64) :: eightbytes = 0

WRITE (*,*) BIT_SIZE(onebyte), DIGITS(onebyte)             ! prints 8 and 7
WRITE (*,*) BIT_SIZE(twobytes), DIGITS(twobytes)           ! prints 16 and 15
WRITE (*,*) BIT_SIZE(fourbytes),  DIGITS(fourbytes)        ! prints 32 and 31
WRITE (*,*) BIT_SIZE(eightbytes),  DIGITS(eightbytes)      ! prints 64 and 63
WRITE (*,*) DIGITS(0.0), DIGITS(0d0)                       ! prints 24 and 53


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 02.03.03/06                           *
C  *    TEST TITLE : Modelling transformation and clipping *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

C clipping indicator
C                noclip      clip
      INTEGER    PNCLIP,     PCLIP
      PARAMETER (PNCLIP = 0, PCLIP = 1)

C modelling clipping operator
      INTEGER    PMCREP,     PMCINT
      PARAMETER (PMCREP = 1, PMCINT = 2)

C composition type
C                preconcatenate  postconcatenate  replace
      INTEGER    PCPRE,          PCPOST,          PCREPL
      PARAMETER (PCPRE = 0,      PCPOST = 1,      PCREPL = 2)

      INTEGER     IPTHSZ
      PARAMETER  (IPTHSZ = 20)

      INTEGER     M1LEN,M2LEN, PMLEN, STPATH(2,5), IDUM1, IDUM(2)
      INTEGER     FPTHSZ,FPATH(2,IPTHSZ), EXLEN,EXPATH(2,IPTHSZ)
      INTEGER     FALEN

      REAL        M1(4,4), M2(4,4), PMLOCX(5), PMLOCY(5), PMLOCZ(5)
      REAL        FALOCX(10), FALOCY(10), FALOCZ(10), TX,TY,TZ
      REAL        TPLOCX(10), TPLOCY(10), TPLOCZ(10), RDUM
      REAL        MCOMP(4,4), EXLOCX,EXLOCY,EXLOCZ, SDIST, PTREGD
      REAL        SRPX,SRPY,SRPZ, HALFSP(6,10), NVECX,NVECY,NVECZ
      REAL        CLPTX,CLPTY,CLPTZ, CLVCX,CLVCY,CLVCZ
      REAL        DVECX,DVECY,DVECZ, NVECL, VECL

      LOGICAL     IAREQL, SPHDIS

      CALL INITGL ('02.03.03/06')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)

      IF (.NOT. SPHDIS(123)) THEN
         CALL INMSG ('Skipping test because implementation '     //
     1               'apparently uses non-Euclidean metric for ' //
     2               'search distance.')
         GOTO 666
      ENDIF

C  m1 = random transformation matrix
C     =   1.43  -2.41  3.25 -1.15
C        -3.25  -3.13  2.54 -1.35
C        -2.43  -1.54  2.31  1.42
C         3.51  -2.32  2.41  3.25

      CALL SETRVS (' 1.43,  -3.25, -2.43,  3.51,  ' //
     1             '-2.41,  -3.13, -1.54, -2.32,  ' //
     2             ' 3.25,   2.54,  2.31,  2.41,  ' //
     3             '-1.15,  -1.35,  1.42,  3.25', M1, M1LEN)

C  m2 = random transformation matrix
C     =   -1.23   1.23  -1.02   9.30
C          1.28  -9.34   0.93  -4.89
C          2.03   9.85   4.01  -9.23
C          4.18  -0.12  -9.34   8.01

      CALL SETRVS ( '-1.23,  1.28,  2.03,  4.18, ' //
     1              ' 1.23, -9.34,  9.85, -0.12, ' //
     2              '-1.02,  0.93,  4.01, -9.34, ' //
     3              ' 9.30, -4.89, -9.23,  8.01', M2, M2LEN)

C  *** *** *** ***   Modelling transformations   *** *** *** ***
C
C  set up structure #101:
C  1. set local transformation = m1
C  2. execute structure 102
      CALL POPST  (101)
      CALL PSLMT3 (M1, PCREPL)
      CALL PEXST  (102)
      CALL PCLST

C  pmloc = polymarker location = -6.347, 4.637, 1.082
      PMLOCX(1) = -6.347
      PMLOCY(1) =  4.637
      PMLOCZ(1) =  1.082

C  set up structure #102:
C  1. set global transformation = m2
C  2. polymarker at pmloc
      CALL POPST  (102)
      CALL PSGMT3 (M2)
      CALL PPM3   (1, PMLOCX, PMLOCY, PMLOCZ)
      CALL PCLST

C  exloc = expected WC location = m2 X m1 X pmloc
      CALL ECOM3 (M2,M1, MCOMP)
      CALL ETP3  (PMLOCX(1),PMLOCY(1),PMLOCZ(1), MCOMP,
     1            EXLOCX,EXLOCY,EXLOCZ)

      SDIST = 0.1
      SRPX = EXLOCX + SDIST
      SRPY = EXLOCY
      SRPZ = EXLOCZ

      CALL SETMSG ('2 3 4 5 6 8 10', 'ISS should detect a primitive ' //
     1             'according to its location in world coordinates, ' //
     2             'computed with the current composite modelling '   //
     3             'transformation, including the effect of '         //
     4             'inherited transformations.')

C  ISS twice with SRP, varying search distance
C    starting path:  101,1, 102,1
C    search ceiling: 2
C    expected path:  101,1, 102,2

      CALL ISSAB (SRPX,SRPY,SRPZ, SDIST, '101,1, 102,1', PNCLIP, 2,
     1            '101,1, 102,2')

C  exloc = expected WC location = m2 X pmloc
      CALL ETP3  (PMLOCX(1),PMLOCY(1),PMLOCZ(1), M2,
     1            EXLOCX,EXLOCY,EXLOCZ)

      SDIST = 0.1
      SRPX = EXLOCX + SDIST
      SRPY = EXLOCY
      SRPZ = EXLOCZ

      CALL SETMSG ('2 3 4 5 6 10', 'ISS should detect a primitive '   //
     1             'according to its location in world coordinates, ' //
     2             'computed with the current composite modelling '   //
     3             'transformation when there are no inherited '      //
     4             'transformations.')

C  ISS twice with SRP, varying search distance
C    starting path:  102,1
C    search ceiling: 1
C    expected path:  102,2

      CALL ISSAB (SRPX,SRPY,SRPZ, SDIST, '102,1', PNCLIP, 1, '102,2')

C  *** *** *** ***   Modelling clipping   *** *** *** ***
C
C  clear CSS
      CALL PDAS

C  set up structure #101:
C    1. set modelling clipping CLIP
C    2. set modelling clipping volume with:
C          point         =  5, 5, 5
C          normal vector = -1,-1,-1
C    3. set local transformation = shift by +3,+3,+3
C    4. polymarker at MC: 4,4,4 (WC will be 7,7,7)
C    5. polymarker at MC: 1,1,1 (WC will be 4,4,4)

      CALL POPST  (101)
      CALL PSMCLI (PCLIP)
      CALL SETRVS ('5,5,5, -1,-1,-1', HALFSP, IDUM1)
      CALL PSMCV3 (PMCREP, 1, HALFSP)
      CALL ETR3   (3.0,3.0,3.0, M2)
      CALL PSLMT3 (M2, PCREPL)
      CALL SETRVS ('4,1', PMLOCX, PMLEN)
      CALL SETRVS ('4,1', PMLOCY, PMLEN)
      CALL SETRVS ('4,1', PMLOCZ, PMLEN)
      CALL PPM3   (1, PMLOCX(1), PMLOCY(1), PMLOCZ(1))
      CALL PPM3   (1, PMLOCX(2), PMLOCY(2), PMLOCZ(2))

      CALL SETMSG ('2 3 4 5 6 10', 'If the modelling clip flag is '   //
     1             'NOCLIP, ISS should detect a primitive whether '   //
     2             'or not its location in world coordinates is '     //
     3             'outside the current modelling clipping volume, '  //
     4             'even if the current modelling clipping '          //
     5             'indicator is CLIP.')

C  ISS twice with
C    modelling clip flag: NOCLIP
C    SRP:                 5.5,5.5,5.5
C    search distance:     1.02*1.5
C
C  pass/fail depending on
C    (found at 101,4 with starting path = 101,0  and
C     found at 101,5 with starting path = 101,4)

      CALL SETVS ('101,0', STPATH, IDUM1)
      CALL SETVS ('101,4', EXPATH, EXLEN)
      CALL PISS3 (5.5,5.5,5.5, 1.02*1.5, 1, STPATH, PNCLIP, 1,
     1            0,IDUM,IDUM,IDUM,IDUM, 0,IDUM,IDUM,IDUM,IDUM,
     2            IPTHSZ, ERRIND, FPTHSZ, FPATH)

      IF (ERRIND .EQ. 0 .AND. IAREQL(2*FPTHSZ,FPATH, EXLEN,EXPATH)) THEN
C        OK so far
      ELSE
         CALL FAIL
         GOTO 300
      ENDIF

      CALL SETVS ('101,4', STPATH, IDUM1)
      CALL SETVS ('101,5', EXPATH, EXLEN)
      CALL PISS3 (5.5,5.5,5.5, 1.02*1.5, 1, STPATH, PNCLIP, 1,
     1            0,IDUM,IDUM,IDUM,IDUM, 0,IDUM,IDUM,IDUM,IDUM,
     2            IPTHSZ, ERRIND, FPTHSZ, FPATH)

      CALL IFPF (ERRIND.EQ.0 .AND. IAREQL(2*FPTHSZ,FPATH, EXLEN,EXPATH))

300   CONTINUE

C  change element #1 of structure 101 to:
C    1. set modelling clipping NOCLIP
      CALL PSEP (1)
      CALL PDEL
      CALL PSMCLI (PNCLIP)
      CALL PCLST

      CALL SETMSG ('2 3 4 5 6 10', 'If the modelling clip flag is '   //
     1             'CLIP, ISS should detect only those primitives '   //
     2             'whose location in world coordinates is inside '   //
     3             'the current modelling clipping volume, even if '  //
     4             'the current modelling clipping indicator is '     //
     5             'NOCLIP.')

C  ISS with
C    modelling clip flag: CLIP
C    SRP:                 5.5,5.5,5.5
C    search distance:     1.02*1.5
C
C  pass/fail depending on
C    (found at 101,5 with starting path = 101,0)

      CALL SETVS ('101,0', STPATH, IDUM1)
      CALL SETVS ('101,5', EXPATH, EXLEN)
      CALL PISS3 (5.5,5.5,5.5, 1.02*1.5, 1, STPATH, PCLIP, 1,
     1            0,IDUM,IDUM,IDUM,IDUM, 0,IDUM,IDUM,IDUM,IDUM,
     2            IPTHSZ, ERRIND, FPTHSZ, FPATH)

      CALL IFPF (ERRIND.EQ.0 .AND. IAREQL(2*FPTHSZ,FPATH, EXLEN,EXPATH))

C  *** *** *** ***   Complex primitive   *** *** *** ***
C
C  clear CSS
      CALL PDAS

C  set up vertices for complex fill area:
C
C     1----------2    p1: 0, 1
C     |          |    p2: 3, 1
C     |  5---6   |    p3: 3,-2
C     |  |   |   |    p4: 1,-2
C     |  |   |   |    p5: 1, 0
C     8--+---7   |    p6: 2, 0
C        |       |    p7: 2,-1
C        4-------3    p8: 0,-1

      CALL SETRVS (' 0, 3, 3, 1, 1, 2, 2, 0', FALOCX, FALEN)
      CALL SETRVS (' 1, 1,-2,-2, 0, 0,-1,-1', FALOCY, FALEN)
      CALL SETRVS (' 0, 0, 0, 0, 0, 0, 0, 0', FALOCZ, FALEN)

C  tp1-tp8 = WC vertices = m1 X p1-p8
      CALL ARRTP3 (FALEN, FALOCX, FALOCY, FALOCZ, M1,
     1                    TPLOCX, TPLOCY, TPLOCZ)

C  nvec = unit vector normal to WC plane of fill area
      CALL PTSPL (FALEN, TPLOCX,TPLOCY,TPLOCZ, TX,TY,TZ, RDUM)
      CALL VEC1  (TX,TY,TZ, NVECX,NVECY,NVECZ)

C  set up structure #101:
C  1. set global transformation = m1
C  2. fill area at p1-p8
      CALL POPST  (101)
      CALL PSGMT3 (M1)
      CALL PFA    (FALEN, FALOCX,FALOCY)
      CALL PCLST

C  SRP   = point over hole in fill area = average of pt5,pt6,pt7 + 0.02*nvec
      SRPX = (TPLOCX(5)+TPLOCX(6)+TPLOCX(7)) / 3 + 0.02 * NVECX
      SRPY = (TPLOCY(5)+TPLOCY(6)+TPLOCY(7)) / 3 + 0.02 * NVECY
      SRPZ = (TPLOCZ(5)+TPLOCZ(6)+TPLOCZ(7)) / 3 + 0.02 * NVECZ
C  Note: the particular values chosen for FALOC preserve the "hole"
C  at p5-7, but since M1 is a distorting transformation, this will
C  not always be the case with other values for FALOC.

C  sdist = distance from SRP to fill area, as computed by PTREGD
      SDIST = PTREGD (SRPX,SRPY,SRPZ, FALEN, TPLOCX,TPLOCY,TPLOCZ)

      CALL SETMSG ('2 3 4 5 6 10 13', 'ISS should detect a complex ' //
     1             'primitive according to its location in world '   //
     2             'coordinates.')

C  ISS twice with SRP, NOCLIP, varying search distance
C    starting path:  101,0
C    search ceiling: 1
C    expected path:  101,2

      CALL ISSAB (SRPX,SRPY,SRPZ, SDIST, '101,0', PNCLIP, 1, '101,2')

C  *** *** *** ***   Complex clipping   *** *** *** ***
C
C  set up vertices for fill area:
C
C        1----------2     p1: 3,2
C       /           /     p2: 6,2
C      /           /      p3: 4,-1
C     4           /       p4: 1,1
C      \         /
C       \       /
C        \     /
C         \   /
C          \ /
C           3

      CALL SETRVS ('3,6, 4,1', FALOCX, FALEN)
      CALL SETRVS ('2,2,-1,1', FALOCY, FALEN)
      CALL SETRVS ('0,0, 0,0', FALOCZ, FALEN)

C  tp1-tp4 = WC vertices = m1 X p1-p4
      CALL ARRTP3 (FALEN, FALOCX, FALOCY, FALOCZ, M1,
     1                    TPLOCX, TPLOCY, TPLOCZ)

C  clpt  = WC clip point  = point on tp2:tp4 line segment closest to tp1
C    (tp1 normal projection onto line segment)
      CALL PTLNDS ( TPLOCX(1),TPLOCY(1),TPLOCZ(1),
     1  TPLOCX(2)-TPLOCX(4), TPLOCY(2)-TPLOCY(4), TPLOCZ(2)-TPLOCZ(4),
     2  TPLOCX(4),TPLOCY(4),TPLOCZ(4), CLPTX,CLPTY,CLPTZ, RDUM)

C  clvec = WC clip vector = vector from clpt to tp1 (in WC plane of
C     fill area, normal to line between tp2 and tp4, towards tp1).
      CLVCX = TPLOCX(1) - CLPTX
      CLVCY = TPLOCY(1) - CLPTY
      CLVCZ = TPLOCZ(1) - CLPTZ

C  nvec  = unit vector normal to WC fill area plane
      CALL PTSPL (FALEN, TPLOCX,TPLOCY,TPLOCZ, TX,TY,TZ, RDUM)
      CALL VEC1  (TX,TY,TZ, NVECX,NVECY,NVECZ)

C  set up structure #102:
C  1. set modelling clipping volume with:
C        point         = clpt
C        normal vector = clvec
C  2. set global transformation = m1
C  3. fill area at p1-p4
      CALL POPST  (102)

      HALFSP (1,1) = CLPTX
      HALFSP (2,1) = CLPTY
      HALFSP (3,1) = CLPTZ
      HALFSP (4,1) = CLVCX
      HALFSP (5,1) = CLVCY
      HALFSP (6,1) = CLVCZ
      CALL PSMCV3 (PMCREP, 1, HALFSP)

      CALL PSGMT3 (M1)
      CALL PFA    (FALEN, FALOCX,FALOCY)
      CALL PCLST

C  dvec = vector away from clipping volume and up from fill area plane
      NVECL = VECL(CLVCX, CLVCY, CLVCZ) / 10
      DVECX = NVECL*NVECX - CLVCX/2
      DVECY = NVECL*NVECY - CLVCY/2
      DVECZ = NVECL*NVECZ - CLVCZ/2

C  SRP = clpt + dvec (outside clipping volume)
      SRPX = CLPTX + DVECX
      SRPY = CLPTY + DVECY
      SRPZ = CLPTZ + DVECZ

C  sdist = length of dvec
      SDIST = VECL (DVECX,DVECY,DVECZ)
C  Note: this is not a general-purpose formula - only works when
C  clip point is inside transformed quadrilateral.  Since M1 is a
C  distorting transformation, this will not always be the case,
C  although it is for the particular values chosen for FALOC.

      CALL SETMSG ('2 3 4 5 6 10 13', 'If the modelling clip flag '   //
     1             'is CLIP, ISS should detect only those portions '  //
     2             'of a complex primitive whose location in world '  //
     3             'coordinates is inside the current modelling '     //
     4             'clipping volume.')

C  ISS twice with SRP, CLIP, varying search distance
C    starting path:  102,0
C    search ceiling: 1
C    expected path:  102,3
      CALL ISSAB (SRPX,SRPY,SRPZ, SDIST, '102,0', PCLIP, 1, '102,3')

666   CONTINUE
      CALL ENDIT
      END


      subroutine scaleset_m345(p,mu0)
c--- subroutine to calculate dynamic scale equal to
c--- invariant mass of particles 3, 4 and 5
      implicit none
      include 'constants.f'
      include 'process.f'
      double precision p(mxpart,4),mu0

      if((case .eq. 'Wgamma') .or.
     &   (case .eq. 'Zgamma') .or.
     &   (case .eq. 'Wgajet') .or.
     &   (case .eq. 'trigam') .or.
     &   (case .eq. 'Zgajet')) then
        mu0=(p(3,4)+p(4,4)+p(5,4))**2-(p(3,1)+p(4,1)+p(5,1))**2
     &     -(p(3,2)+p(4,2)+p(5,2))**2-(p(3,3)+p(4,3)+p(5,3))**2
        mu0=dsqrt(dabs(mu0))
      else
        write(6,*) 'dynamicscale m(345) not supported for this process.'
        stop
      endif

      return
      end


*DECK DQWGTS
      DOUBLE PRECISION FUNCTION DQWGTS (X, A, B, ALFA, BETA, INTEGR)
C***BEGIN PROLOGUE  DQWGTS
C***SUBSIDIARY
C***PURPOSE  This function subprogram is used together with the
C            routine DQAWS and defines the WEIGHT function.
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (QWGTS-S, DQWGTS-D)
C***KEYWORDS  ALGEBRAICO-LOGARITHMIC, END POINT SINGULARITIES,
C             WEIGHT FUNCTION
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***SEE ALSO  DQK15W
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   810101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DQWGTS
C
      DOUBLE PRECISION A,ALFA,B,BETA,BMX,X,XMA
      INTEGER INTEGR
C***FIRST EXECUTABLE STATEMENT  DQWGTS
      XMA = X-A
      BMX = B-X
      DQWGTS = XMA**ALFA*BMX**BETA
      GO TO (40,10,20,30),INTEGR
   10 DQWGTS = DQWGTS*LOG(XMA)
      GO TO 40
   20 DQWGTS = DQWGTS*LOG(BMX)
      GO TO 40
   30 DQWGTS = DQWGTS*LOG(XMA)*LOG(BMX)
   40 RETURN
      END


!----------------------------------------------------------------------*
!  SUBROUTINE SUBCD2                                                    *
!  Purpose: This subroutine calculates number of days below a certain  *
!           average temperature (TAV), which is used to terminate the  *
!           simulation after a maximum number of cold days the crop    *
!           can survive.                                               *
! Adapted from version 1, March 2006, Bouman                           *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning (unit)                                     class *
! ----   ---- ---------------                                    ----- *
! COLDMIN I4 lower T threshold for growth                           I  *
! CROPSTA I4  Crop stage (-)                                        I  *
! TAV     R4  Average daily temperature (oC)                        I  *
! TIME    R4  Time of simulation (d)                                T  *
! NCOLD   R4  Number of cold days (-)                               O  *
!                                                                      *
!  FILE usage : none                                                   *
!----------------------------------------------------------------------*
      SUBROUTINE SUBCD2 (COLDMIN, CROPSTA,TAV,TIME,NCOLD)

      IMPLICIT NONE
!-----Formal parameters
      REAL    COLDMIN, TAV, TIME, NCOLD
      INTEGER CROPSTA
      SAVE         ! TAOLI

      IF (CROPSTA .EQ. 3) NCOLD = 0.
      IF (TAV.LT.COLDMIN) THEN
         NCOLD = NCOLD+1.
      ELSE
         NCOLD = 0.
      END IF
      RETURN
      END


c***********************************************************************
c  Copyright 2006 John A. Trangenstein
c
c  This software is made available for research and instructional use
c  only.
c  You may copy and use this software without charge for these
c  non-commercial purposes, provided that the copyright notice and
c  associated text is reproduced on all copies.
c  For all other uses (including distribution of modified versions),
c  please contact the author at
c    John A. Trangenstein
c    Department of Mathematics
c    Duke University
c    Durham, NC 27708-0320
c    USA
c  or
c    johnt@math.duke.edu
c
c  This software is made available "as is" without any assurance that it
c  is completely correct, or that it will work for your purposes.
c  Use the software at your own risk.
c***********************************************************************
      program linaddmain
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      integer ncells
!      parameter (ncells=100)
!      parameter (ncells=10000)
      parameter (ncells=100000)
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      include "linearad.i"
      include "const.i"
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      double precision stabledt
      external stabledt

      double precision
     &  u(-2:ncells+1),
     &  x(0:ncells),
     &  flux(0:ncells),
     &  dfdu(-2:ncells+1)
c    &  flux_cell(-2:ncells+1),
c    &  uside(0:ncells)
      integer nsteps
      double precision tmax,cfl

      integer i,fc,lc,fm,lm,fs,ls,ifirst,ilast
      integer istep
      double precision dt,t
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      roundoff=1.d-14
      small=1.d-20
      huge=1.d300
      undefind=1.d300
      lnrndoff=14.d0
      lnsmall=20.d0

c     problem-specific parameters:
      jump=0
      x_left=-0.2d0
      x_right=1.d0
      statelft=2.d0
      statergt=0.d0
      velocity=1.d0

      nsteps=10000
      tmax=0.8d0
      cfl=0.9d0

c     array bounds for subroutine calls:
      fc=-2
      lc=ncells+1
      fm=0
      lm=ncells-1
      fs=0
      ls=ncells-1
      ifirst=0
      ilast=ncells-1

c     initialization:
      call initsl(ncells,fc,lc,fm,lm,ifirst,ilast, u,x)
c     do i=0,ncells
c       print *,"x(",i,") = ",x(i)
c     enddo
c     do i=-2,ncells+1
c       print *,"u(",i,") = ",u(i)
c     enddo
      call bcmesh(fm,lm,ncells, x)
      call bccells(fc,lc,ncells, u)
      call fluxderv(fc,lc,fc,lc, u, dfdu)

      istep=0
      t=0.d0
      do while (istep.lt.nsteps .and. t.lt.tmax)
        call bccells(fc,lc,ncells, u)
        call fluxderv(fc,lc,fc,lc, u, dfdu)
        dt=cfl*stabledt(fc,lc,fm,lm,ifirst,ilast, u, dfdu,x)
        call method(dt,fc,lc,fm,lm,fs,ls,ifirst,ilast, u, flux)
        call consdiff(fc,lc,fs,ls,fm,lm,ifirst,ilast, x,flux, u)
        t=t+dt
        istep=istep+1
      enddo

c     write results, plot later
      do i=0,ncells-1
!        print *,(x(i)+x(i+1))*0.5d0,u(i)
      enddo

      stop
      end