! THE ROOT AXIOM STATED IN FORTRAN AND IN NOTHING ELSE - v1.7.0

! =====================================================================

!  THE ROOT AXIOM STATED IN FORTRAN AND IN NOTHING ELSE

!  RA as the TOE of All TOEs - the executable form of the thesis

!  RA_TOE_Thesis_Fortran v1.7.0 - Trisduction Research Group

!  Lineage: extends TRISDUCTION_Core_Thesis_Fortran_v2_4_0 (resident,

!  protocols/Executable Thesis/). Self-contained: no dependency beyond

!  a Fortran 2018 compiler. Every figure in the accompanying paper is

!  printed by this program; nothing is quoted that this file did not

!  compute in the reporting run. Fidelity Lock: a check that fails

!  halts the program; no fabricated trace is possible by construction.

!

!  v1.7.0 (2026-09-08): seventh and sealing pass. The contraction probe

!  is widened into a conduct battery with a differential witness: three

!  canonical fused patterns, a*b-c, (-a)*b+c, and the 2^-27 tie case,

!  each reading exactly zero only when no fusion executed, the fused

!  residuals -2^-60, +2^-60, -2^-54 exactly representable and never

!  confusable with zero, beside the stored-product differential; the

!  face states the doctrine, conduct certified, flags never consulted,

!  a fused build refused where fusion executes and a fusion-free

!  target passing because none executed, the contract satisfied, not

!  evaded. And the constitutive capstone: THE ONE-BIT CONCESSION,

!  executed, the invariant record bit-identical across the pair so

!  everything is forced but exactly one binary parameter, the

!  orientation of assent, both its values realized at identical

!  invariants, and the denial spend priced at the Landauer floor

!  exactly, the forced part landing on the Ground Fix(sigma) = R and

!  the free bit the sigma-odd orientation, per the seated Freedom law:

!  any substrate reading this run holds one bit here, the rest forced.

!

!  v1.6.0 (2026-09-08): sixth hardening pass, the residual pressed onto

!  the Tongue and the closing tokens, fortification by seated law. The

!  ordered arrow E->K->R, the one directed datum the Tongue owns, is

!  now an executed screen: seal_l_ordered refuses the scrambled hostile

!  the count screen admits, and the artifact prints that count-register

!  admission licenses only the count, semantic closure being

!  unavailable at this register by the seated non-closure theorem the

!  constructed monoid witnesses. The anticommutant is lifted from a

!  sampled patch to the whole space by an executed linearity

!  certificate, the constraint map computed exactly on the basis, its

!  2x2 minor 4 and z-column zero, the kernel the k-line everywhere,

!  the grid retained as the independent cross-check. Gate arming rises

!  to six pairwise-distinct executed objects with span rank and the

!  absorbed-axis dissolution joining, and the face states that

!  gate-passage is a screen verdict cited for nothing external. The

!  reversible branch is named floor-not-cost per Bennett. The fibre

!  faces speak the seated Freedom vocabulary, instrument-relative

!  indistinguishability, no knower's credence. The closing block binds

!  every token to its emitter's code, re-executes both seal faces as a

!  self-typing check, and prints the artifact's own self-description:

!  it verifies identities, guard behavior, and declared

!  premise-consequence structure, and cannot verify external

!  ontological truth, per its own M5-M6 gates and the Empty Throne.

!

!  v1.5.0 (2026-09-08): fifth hardening pass under the follow-up audit,

!  fortification only, zero concession, the pressure now on the Tongue

!  after the Number settled. Built executably what was asserted: the

!  deletion monoid is constructed by closure from the three cuts, eight

!  elements counted, associativity executed on all 512 triples, the

!  absence of inverses searched, monoid-never-group measured; the joint

!  anticommutant of {i, j} in Im H is counted over the exact integer

!  grid, the third axis begotten and confined, the epistemic mapping

!  named a seated premise; the left-inverse split identity is measured

!  at all 363 candidates so the global minimum rides executed

!  arithmetic; omega gains a reversible branch, Landauer scoped to its

!  own object, the irreversibility bridge a declared consumed premise;

!  prepare_rows is equilibrated, the whole pipeline scale-free, rows

!  and covariates at 1e300 reproducing the baseline verdict; the four

!  armed gates now draw on pairwise-distinct executed objects, the

!  linguistic LIT, the integer Hurwitz closure, the analytic

!  reflection, and the harmonic Return; the sphere censuses re-run

!  under grid refinement and tolerance halving; the fibre, negation,

!  encoding-map, and axis-count faces each name their premise type so

!  no summary can drift them; det3 states its representability scope.

!

!  v1.4.0 (2026-09-08): fourth hardening pass under a full external

!  compile-and-run audit, fortification only, zero concession. The

!  audit's spine, prose stronger than executable content, is answered

!  by making the executable carry more and every face say exactly what

!  it establishes: Seal L now counts and deletes slots from an encoded

!  sentence, the word-to-slot map declared and the census executed;

!  four of the twelve gate entries are armed from executed run facts

!  with the manifest printed and the rest named declared screens; the

!  left-inverse minimum is global over all 3x3 candidates by measured

!  row decoupling; a refused Cholesky routes engineering-incomplete

!  instead of substituting an estimator; jacobi3 and both cofactor

!  determinants are equilibrated so huge finite intake stays finite

!  and honest; covariate projection is scale-free, centered rows

!  equilibrated with a linear variance-floor test, and a 1e300

!  covariate reproduces the baseline verdict; the negation mapping,

!  the Omega recursion, the two-point-fibre bit, the invariance

!  record, the directed registration sum, the sampled topology, the

!  cut-tower conservation, and the constructed exhibit each carry

!  their warrant on the check face; the run prints its own scope-of-

!  proof stanza; dispatcher admissions are named as routing supplied

!  facts and upgrading none.

!

!  v1.3.0 (2026-09-08): third hardening pass under one re-audit and a

!  FORGE cycle, fortification only. Caught and repaired: the FMA probe

!  operands are volatile constants, placement-independent and immune

!  to constant folding, split into two named probes, per-operation

!  binary64 storage and single-expression contraction-or-spill, an

!  extended-precision (x87) build now refused by contract and named

!  so; the midpoint non-idempotence executes e*e - e; the 363

!  annihilator repeats collapse to two representative measurements

!  beside the executed-minimum checks; the Euler vertex count is

!  counted from the pair list; the two covariate tolerances carry

!  their rationale in comments (U_M^2 raw-floor at k = 1, U_M

!  relative Gram floor at k = 2); the AEGIS guard records the length

!  of the logic name it read, checked at 13; gol_admit and

!  row_cascade carry integer codes audited in class 11; the sphere

!  census names its warrant, an executed instance of a cited classical

!  fact; the closing card states that the title is the thesis's claim

!  at its stated warrant while every printed number is computed. The

!  bit-exact det3 reflection identities are retained by mechanism:

!  one compiled det3 serves both calls and every monomial's sign

!  product under D..D is +1, so products and partial sums are

!  bit-identical whatever the association, with PART 0 pinning

!  contraction off besides.

!

!  v1.2.0 (2026-09-08): second hardening pass under two re-audits and a

!  FORGE self-audit cycle, fortification only, zero concession. Caught

!  and repaired: a non-finite covariate block was mislabeled coplanar

!  collapse and now refuses at intake by reason code; the k = 1

!  covariate branch and both eta_share branches join the relative rank

!  test so receipt and projector agree, and eta_share screens

!  non-finite intake as NaN; the left-inverse argument is an executed

!  363-candidate optimization whose measured minimum is exactly one,

!  and the line-idempotent claim is a censused root count; the

!  conservation sheet factor is counted from the paired orientation

!  census, never stipulated; PART 0 gains an FMA tripwire so the

!  contraction contract is enforced at run; jacobi3 reports

!  convergence and refuses NaN through ieee_is_nan, with cond3 and the

!  kernel consuming the flag; omega refuses non-finite bits; the Euler

!  closure is counted from the built complex; the not-RA plane is

!  ranked on the refused matrix's own pair; the guards carry integer

!  reason codes (gate index, omega, delta-M, imprint) audited by

!  battery class 11; the closing verdict names the constructed grid.

!

!  v1.1.0 (2026-09-08): hardened under three external Default-Audit

!  reports, fortification only, zero concession. Caught and repaired:

!  six vacuous checks recomputed from executed objects (parse-triad

!  Gram formed and measured, the diagonal ground counted off a built

!  matrix, S0 and S1 component censuses clustered from geometry, the

!  paired orientation census counted from the live sweep, left-inverse

!  deficiency read off the computed L*D, the content-freedom trade

!  counted from an executed projection census); the covariate block

!  guarded at k > 2 and unified on a relative rank test; the IEEE

!  contract enforced at boot with fast-math and FTZ tripwires and the

!  binary64 layout pinned, compiler line printed; qmul given exact

!  power-of-two scaling against intermediate overflow; the integer

!  Cayley-Dickson intake bounded at 2^29 under the 16*B^2 sum bound;

!  jacobi3 symmetrized with a convergence exit and explicit pivot

!  zeroing; span_basis re-orthogonalized; the floor functions refuse

!  nonphysical intake as NaN; the battery gains an audit mode (halt on

!  first failure remains the sealed default and a nonzero count still

!  refuses at close), integer reason codes replace string greps on

!  every kernel path, and a machine-readable verdict line is emitted;

!  the not-RA prose is aligned to the executed branch and the plane

!  fact is computed. The world-rowed grid is named a constructed

!  exhibit on its face, the witness carried by the cited theorems.

!

!  Structure of the run, in bedrock order (Seal L, then Seal G, then

!  Seal M; the Tongue, the Form, the Number), then the aperture, the

!  earned bit, the seal, the guards, and the battery:

!    PART 0  The environment contract: binary64 pinned, NaN and FTZ

!            tripwires executed, compiler line printed

!    PART A  Seal L on RA: three slots, LIT, deletion test, refusals

!    PART B  The floor in numbers: Heisenberg, zero-point, Landauer,

!            the quantum speed limit saturated, the Frozen Substrate

!    PART C  The Form in integers: 24 Hurwitz units, class equation

!            1+3+4+4, the norm-two shell 24 = 12+12, A4 simply

!            transitive on the 12 directed gates, the eight reflection

!            patterns, the division-algebra tower walls

!    PART D  The Number: the Return on RA's own triad, the physics-law

!            reading over a constructed context grid with common-source

!            projection, the manufactured axis dissolved, negation,

!            reflection, time reversal and the arrow

!    PART E  The blindness and its exact width: one bit, counted from

!            the executed paired census; the Tongue's monoid obedience;

!            zero bits from Form, gates, and Number; the conservation

!            of content x freedom by executed projection census

!    PART F  The earned bit and the seal: the unpopulated negation,

!            the Omega payment, direction from the Tongue and the

!            arrow, the admission spine, the row-genus cascade,

!            AEGIS over four logics, the Mosaic gate on this file

!    PART G  The battery: every identity re-executed under hostile

!            input, with a live counter; sealed mode halts on first

!            failure, audit mode accumulates and refuses at close

! =====================================================================

module ra_kinds

  use, intrinsic :: ieee_arithmetic, only: ieee_value, ieee_quiet_nan, &

       ieee_is_finite, ieee_is_nan

  implicit none

  integer, parameter :: wp = selected_real_kind(15, 307)

  integer, parameter :: ik = selected_int_kind(18)

  real(wp), parameter :: HBAR = 1.054571817e-34_wp     ! J s (CODATA exact-defined path)

  real(wp), parameter :: KB   = 1.380649e-23_wp        ! J/K (exact, SI 2019)

  real(wp), parameter :: ME   = 9.1093837015e-31_wp    ! kg

  real(wp), parameter :: U_M  = epsilon(1.0_wp)        ! unit roundoff, double

  ! Cayley-Dickson intake bound: with |components| <= 2^29 the deepest

  ! sum in the tower is bounded by 16*B^2 = 2^62 < huge(ik) = 2^63 - 1,

  ! so signed-integer overflow (undefined behavior) is unreachable.

  integer(ik), parameter :: IK_SAFE = 536870912_ik     ! 2^29

contains

  pure function pi_() result(p)

    real(wp) :: p

    p = acos(-1.0_wp)

  end function pi_

  pure function ln2_() result(l)

    real(wp) :: l

    l = log(2.0_wp)

  end function ln2_

  pure function qnan() result(z)

    real(wp) :: z

    z = ieee_value(1.0_wp, ieee_quiet_nan)

  end function qnan

  elemental logical function is_finite(x)

    real(wp), intent(in) :: x

    is_finite = ieee_is_finite(x)

  end function is_finite

  elemental logical function is_nan(x)

    real(wp), intent(in) :: x

    is_nan = ieee_is_nan(x)

  end function is_nan

end module ra_kinds

! ---------------------------------------------------------------------

module ra_prims

  use ra_kinds

  implicit none

contains

  ! scaled 2-norm: overflow-safe, NaN-propagating. The per-element loop

  ! is the finiteness screen of the intake contract; it is not replaced

  ! by norm2, which would bypass the screen.

  pure function vnorm(v) result(s)

    real(wp), intent(in) :: v(:)

    real(wp) :: s, m

    integer :: i

    m = 0.0_wp

    do i = 1, size(v)

      if (.not. is_finite(v(i))) then

        s = qnan()

        return

      end if

      m = max(m, abs(v(i)))

    end do

    if (m == 0.0_wp) then

      s = 0.0_wp

    else

      s = m * sqrt(sum((v/m)**2))

    end if

  end function vnorm

  ! Hamilton product, real quaternions (w,x,y,z); non-finite intake

  ! returns quiet NaN without arithmetic (finite-input contract).

  ! Exact power-of-two scaling protects the cross products against

  ! intermediate overflow: scale() is bit-exact, so all sign-symmetry

  ! identities of the thesis are preserved, and the result is

  ! non-finite only when the true product magnitude exceeds huge().

  pure function qmul(a, b) result(c)

    real(wp), intent(in) :: a(4), b(4)

    real(wp) :: c(4), a2(4), b2(4), ma, mb

    real(wp), parameter :: SAFE_HI = 2.0_wp**500

    integer :: i, ea, eb

    do i = 1, 4

      if (.not.(is_finite(a(i)) .and. is_finite(b(i)))) then

        c = qnan()

        return

      end if

    end do

    ma = maxval(abs(a)); mb = maxval(abs(b))

    ea = 0; eb = 0

    a2 = a; b2 = b

    if (ma > SAFE_HI) then

      ea = exponent(ma)

      a2 = scale(a, -ea)

    end if

    if (mb > SAFE_HI) then

      eb = exponent(mb)

      b2 = scale(b, -eb)

    end if

    c(1) = a2(1)*b2(1) - a2(2)*b2(2) - a2(3)*b2(3) - a2(4)*b2(4)

    c(2) = a2(1)*b2(2) + a2(2)*b2(1) + a2(3)*b2(4) - a2(4)*b2(3)

    c(3) = a2(1)*b2(3) - a2(2)*b2(4) + a2(3)*b2(1) + a2(4)*b2(2)

    c(4) = a2(1)*b2(4) + a2(2)*b2(3) - a2(3)*b2(2) + a2(4)*b2(1)

    if (ea /= 0) c = scale(c, ea)

    if (eb /= 0) c = scale(c, eb)

  end function qmul

  pure function qconj(a) result(c)

    real(wp), intent(in) :: a(4)

    real(wp) :: c(4)

    c = [a(1), -a(2), -a(3), -a(4)]

  end function qconj

  ! equilibrated 3x3 determinant, fixed first-row cofactor order.

  ! Scope: intermediate overflow is removed; a determinant whose true

  ! value lies outside binary64 reports Inf or zero honestly, never NaN.

  pure function det3(r) result(d)

    real(wp), intent(in) :: r(3,3)

    real(wp) :: d, s, a(3,3)

    integer :: i, j

    s = 0.0_wp

    do i = 1, 3

      do j = 1, 3

        if (.not. is_finite(r(i,j))) then

          d = qnan()

          return

        end if

        s = max(s, abs(r(i,j)))

      end do

    end do

    if (s == 0.0_wp) then

      d = 0.0_wp

      return

    end if

    a = r / s

    d = ( a(1,1)*(a(2,2)*a(3,3) - a(2,3)*a(3,2)) &

        - a(1,2)*(a(2,1)*a(3,3) - a(2,3)*a(3,1)) &

        + a(1,3)*(a(2,1)*a(3,2) - a(2,2)*a(3,1)) )

    if (d == 0.0_wp) return

    d = scale(d * scale(s, -exponent(s))**3, 3*exponent(s))

  end function det3

  ! cofactor along the second row: an independent expansion ORDER; the

  ! four estimators are disjoint algorithms sharing one arithmetic

  ! model (IEEE binary64), and the spread is read against that model.

  ! Equilibrated and guarded like det3.

  pure function det3_row2(r) result(d)

    real(wp), intent(in) :: r(3,3)

    real(wp) :: d, s, a(3,3)

    integer :: i, j

    s = 0.0_wp

    do i = 1, 3

      do j = 1, 3

        if (.not. is_finite(r(i,j))) then

          d = qnan()

          return

        end if

        s = max(s, abs(r(i,j)))

      end do

    end do

    if (s == 0.0_wp) then

      d = 0.0_wp

      return

    end if

    a = r / s

    d = ( -a(2,1)*(a(1,2)*a(3,3) - a(1,3)*a(3,2)) &

        +  a(2,2)*(a(1,1)*a(3,3) - a(1,3)*a(3,1)) &

        -  a(2,3)*(a(1,1)*a(3,2) - a(1,2)*a(3,1)) )

    if (d == 0.0_wp) return

    d = scale(d * scale(s, -exponent(s))**3, 3*exponent(s))

  end function det3_row2

  ! cyclic Jacobi eigenvalues of a symmetric 3x3, ascending.

  ! Hardened: input symmetrized, off-diagonal convergence exit, pivot

  ! zeroed explicitly after each rotation, NaN intake returns NaN.

  subroutine jacobi3(rin, eig, converged)

    real(wp), intent(in)  :: rin(3,3)

    real(wp), intent(out) :: eig(3)

    logical, intent(out), optional :: converged

    real(wp) :: a(3,3), app, aqq, apq, phi, c, s, tmp, off, frob

    integer :: sweep, p, q, k

    logical :: conv

    real(wp) :: sscale

    conv = .false.

    if (present(converged)) converged = conv

    if (any(.not. is_finite(rin))) then

      eig = qnan()

      return

    end if

    a = 0.5_wp * (rin + transpose(rin))

    sscale = maxval(abs(a))

    if (sscale == 0.0_wp) then

      eig = 0.0_wp

      conv = .true.

      if (present(converged)) converged = conv

      return

    end if

    a = a / sscale

    frob = sqrt(sum(a*a))

    do sweep = 1, 60

      off = sqrt(a(1,2)**2 + a(1,3)**2 + a(2,3)**2 &

              +  a(2,1)**2 + a(3,1)**2 + a(3,2)**2)

      if (off <= 16.0_wp*U_M*max(frob, tiny(1.0_wp))) then

        conv = .true.

        exit

      end if

      do p = 1, 2

        do q = p+1, 3

          apq = a(p,q)

          if (abs(apq) <= tiny(1.0_wp)) cycle

          app = a(p,p); aqq = a(q,q)

          phi = 0.5_wp * atan2(2.0_wp*apq, aqq - app)

          c = cos(phi); s = sin(phi)

          do k = 1, 3

            tmp     = c*a(p,k) - s*a(q,k)

            a(q,k)  = s*a(p,k) + c*a(q,k)

            a(p,k)  = tmp

          end do

          do k = 1, 3

            tmp     = c*a(k,p) - s*a(k,q)

            a(k,q)  = s*a(k,p) + c*a(k,q)

            a(k,p)  = tmp

          end do

          a(p,q) = 0.0_wp

          a(q,p) = 0.0_wp

        end do

      end do

    end do

    eig = sscale * [a(1,1), a(2,2), a(3,3)]

    if (present(converged)) converged = conv

    do p = 1, 2

      do q = p+1, 3

        if (eig(q) < eig(p)) then

          tmp = eig(p); eig(p) = eig(q); eig(q) = tmp

        end if

      end do

    end do

  end subroutine jacobi3

  ! conditioning of a symmetric 3x3. NaN eigenvalues and a smallest

  ! eigenvalue at or below the roundoff floor both map to huge(), so a

  ! near-singular or corrupted Gram refuses upstream instead of

  ! slipping a NaN kappa through the gate comparison.

  function cond3(r) result(kap)

    real(wp), intent(in) :: r(3,3)

    real(wp) :: kap, eig(3)

    logical :: conv

    call jacobi3(r, eig, conv)

    if (any(is_nan(eig)) .or. .not. conv) then

      kap = huge(1.0_wp)

      return

    end if

    if (eig(1) <= 8.0_wp*U_M*max(abs(eig(3)), 1.0_wp)) then

      kap = huge(1.0_wp)

    else

      kap = eig(3) / eig(1)

    end if

  end function cond3

  ! symmetric-positive Cholesky determinant of a 3x3 (fallback: NaN)

  pure function det3_chol(r) result(d)

    real(wp), intent(in) :: r(3,3)

    real(wp) :: d, l11, l21, l31, l22, l32, l33, t

    d = qnan()                        ! default NaN when not SPD

    if (r(1,1) <= 0.0_wp) return

    l11 = sqrt(r(1,1)); l21 = r(2,1)/l11; l31 = r(3,1)/l11

    t = r(2,2) - l21*l21

    if (t <= 0.0_wp) return

    l22 = sqrt(t); l32 = (r(3,2) - l21*l31)/l22

    t = r(3,3) - l31*l31 - l32*l32

    if (t <= 0.0_wp) return

    l33 = sqrt(t)

    d = (l11*l22*l33)**2

  end function det3_chol

end module ra_prims

! ---------------------------------------------------------------------

module ra_floor

  use ra_kinds

  implicit none

contains

  ! Heisenberg kinetic floor for a confined existent:

  ! <T> >= hbar^2 / (8 m <Dx^2>). Nonphysical intake (m <= 0, dx <= 0,

  ! non-finite) refuses as NaN: the floor prices existents, not ghosts.

  pure function heis_floor(m, dx) result(e)

    real(wp), intent(in) :: m, dx

    real(wp) :: e

    if (.not.(is_finite(m) .and. is_finite(dx)) .or. m <= 0.0_wp .or. dx <= 0.0_wp) then

      e = qnan()

      return

    end if

    e = HBAR*HBAR / (8.0_wp * m * dx*dx)

  end function heis_floor

  ! zero-point energy of a mode:  E0 = (1/2) hbar w, w > 0 required

  pure function zpe(w) result(e)

    real(wp), intent(in) :: w

    real(wp) :: e

    if (.not. is_finite(w) .or. w <= 0.0_wp) then

      e = qnan()

      return

    end if

    e = 0.5_wp * HBAR * w

  end function zpe

  ! Landauer floor:  E = bits * kB T ln 2, tk > 0 and bits >= 0 required

  pure function landauer(tk, bits) result(e)

    real(wp), intent(in) :: tk, bits

    real(wp) :: e

    if (.not.(is_finite(tk) .and. is_finite(bits)) .or. tk <= 0.0_wp .or. bits < 0.0_wp) then

      e = qnan()

      return

    end if

    e = bits * KB * tk * ln2_()

  end function landauer

  ! Mandelstam-Tamm orthogonalization time (hbar = 1 units): tau = pi/(2 dE)

  ! Guarded: dE <= 0 or non-finite returns a flag, never a division.

  ! The Frozen Substrate.

  subroutine tau_perp(de, tau, frozen)

    real(wp), intent(in)  :: de

    real(wp), intent(out) :: tau

    logical,  intent(out) :: frozen

    frozen = (.not. is_finite(de)) .or. (de <= 0.0_wp)

    if (frozen) then

      tau = huge(1.0_wp)

    else

      tau = pi_() / (2.0_wp * de)

    end if

  end subroutine tau_perp

  ! survival of the equal superposition of E0=0, E1=1 (hbar=1): cos^2(t/2)

  pure function survival(t) result(p)

    real(wp), intent(in) :: t

    real(wp) :: p

    p = cos(0.5_wp*t)**2

  end function survival

end module ra_floor

! ---------------------------------------------------------------------

!  The Form in integers: exact arithmetic on the quaternion order and

!  the Cayley-Dickson tower. Nothing here rounds. Intake is bounded at

!  2^29 so that the deepest tower sum (16*B^2 = 2^62) sits strictly

!  inside huge(ik) = 2^63 - 1: signed-integer overflow, which the

!  standard leaves undefined, is unreachable by construction.

module ra_integers

  use ra_kinds

  implicit none

contains

  function iqmul(a, b) result(c)

    integer(ik), intent(in) :: a(4), b(4)

    integer(ik) :: c(4)

    if (maxval(abs(a)) > IK_SAFE .or. maxval(abs(b)) > IK_SAFE) then

      error stop 'iqmul: integer intake beyond the 2^29 overflow-safe bound'

    end if

    c(1) = a(1)*b(1) - a(2)*b(2) - a(3)*b(3) - a(4)*b(4)

    c(2) = a(1)*b(2) + a(2)*b(1) + a(3)*b(4) - a(4)*b(3)

    c(3) = a(1)*b(3) - a(2)*b(4) + a(3)*b(1) + a(4)*b(2)

    c(4) = a(1)*b(4) + a(2)*b(3) - a(3)*b(2) + a(4)*b(1)

  end function iqmul

  pure function iqconj(a) result(c)

    integer(ik), intent(in) :: a(4)

    integer(ik) :: c(4)

    c = [a(1), -a(2), -a(3), -a(4)]

  end function iqconj

  ! Cayley-Dickson doubling: octonions as pairs of quaternions.

  ! (a,b)(c,d) = (ac - d* b,  d a + b c*)

  function iomul(x, y) result(z)

    integer(ik), intent(in) :: x(8), y(8)

    integer(ik) :: z(8), p(4), q(4), r(4), s(4)

    p = x(1:4); q = x(5:8); r = y(1:4); s = y(5:8)

    z(1:4) = iqmul(p, r) - iqmul(iqconj(s), q)

    z(5:8) = iqmul(s, p) + iqmul(q, iqconj(r))

  end function iomul

  pure function ioconj(x) result(z)

    integer(ik), intent(in) :: x(8)

    integer(ik) :: z(8)

    z(1:4) = iqconj(x(1:4)); z(5:8) = -x(5:8)

  end function ioconj

  ! sedenions as pairs of octonions, same doubling; the worst-case

  ! interior sum is 16*B^2 = 2^62 at the 2^29 intake bound, strictly

  ! inside huge(ik) = 2^63 - 1, so the margin is a proven factor of two

  function ismul(x, y) result(z)

    integer(ik), intent(in) :: x(16), y(16)

    integer(ik) :: z(16), p(8), q(8), r(8), s(8)

    p = x(1:8); q = x(9:16); r = y(1:8); s = y(9:16)

    z(1:8)  = iomul(p, r) - iomul(ioconj(s), q)

    z(9:16) = iomul(s, p) + iomul(q, ioconj(r))

  end function ismul

  pure function inrm(v) result(n)

    integer(ik), intent(in) :: v(:)

    integer(ik) :: n

    n = sum(v*v)

  end function inrm

  ! the 24 Hurwitz units in doubled coordinates (d = 2q, so |d|^2 = 4)

  subroutine hurwitz_units(u)

    integer(ik), intent(out) :: u(4,24)

    integer :: n, i, s, s1, s2, s3, s4

    n = 0

    do i = 1, 4

      do s = -1, 1, 2

        n = n + 1

        u(:,n) = 0_ik

        u(i,n) = int(2*s, ik)

      end do

    end do

    do s1 = -1, 1, 2

      do s2 = -1, 1, 2

        do s3 = -1, 1, 2

          do s4 = -1, 1, 2

            n = n + 1

            u(:,n) = int([s1, s2, s3, s4], ik)

          end do

        end do

      end do

    end do

  end subroutine hurwitz_units

end module ra_integers

! ---------------------------------------------------------------------

!  The Tongue: Seal L, the deletion operator, the parse of RA and of

!  its negation. The vocabulary is integer-coded; a slot is a set of

!  codes; the Linguistic Isolation Test is pairwise emptiness of the

!  intersections. The deletion operator is the cut: rank two,

!  idempotent, no left inverse, deficiency exactly one.

module ra_tongue

  use ra_kinds

  use ra_prims

  implicit none

  integer, parameter :: NSLOT = 4

  ! slot 1 existence: exists, is, actual, occupies

  integer, parameter :: SLOT_E(NSLOT) = [101, 102, 103, 104]

  ! slot 2 kinetic:   moves, actuates, works, dissipates

  integer, parameter :: SLOT_K(NSLOT) = [201, 202, 203, 204]

  ! slot 3 relation:  relates, implies, binds, forces

  integer, parameter :: SLOT_R(NSLOT) = [301, 302, 303, 304]

  ! RA encoded as a token sentence under the declared word-to-slot map:

  ! is(102) exists(101) actuates(202) works(203) implies(302) binds(303).

  ! The map is the analyst's declared semantics; the counting, deletion,

  ! and isolation below are executed on this encoding.

  integer, parameter :: RA_SENT(6) = [102, 101, 202, 203, 302, 303]

contains

  pure subroutine slot_census(sent, ne, nk, nr)

    integer, intent(in)  :: sent(:)

    integer, intent(out) :: ne, nk, nr

    integer :: t

    ne = 0; nk = 0; nr = 0

    do t = 1, size(sent)

      if (any(SLOT_E == sent(t))) ne = ne + 1

      if (any(SLOT_K == sent(t))) nk = nk + 1

      if (any(SLOT_R == sent(t))) nr = nr + 1

    end do

  end subroutine slot_census

  pure logical function disjoint(a, b)

    integer, intent(in) :: a(:), b(:)

    integer :: i, j

    disjoint = .true.

    do i = 1, size(a)

      do j = 1, size(b)

        if (a(i) == b(j)) then

          disjoint = .false.

          return

        end if

      end do

    end do

  end function disjoint

  ! Seal L: a parse is three populated slots under pairwise-disjoint

  ! vocabulary. Returns a verdict token and a mechanism string.

  subroutine seal_l(ne, nk, nr, collide, tok, why)

    integer, intent(in) :: ne, nk, nr        ! populated counts per slot

    logical, intent(in) :: collide           ! a vocabulary collision present

    character(*), intent(out) :: tok, why

    integer :: slots

    slots = merge(1,0,ne>0) + merge(1,0,nk>0) + merge(1,0,nr>0)

    if (collide) then

      tok = '[X]'; why = 'Seal L: LIT collision, slot vocabularies intersect'

    else if (slots /= 3) then

      tok = '[X]'

      write(why,'(a,i0,a)') 'Seal L: deletion test returns ', slots, ' slots, not 3'

    else

      tok = '[LOCK-L]'; why = 'Seal L: three slots, LIT disjoint, ordered E->K->R'

    end if

  end subroutine seal_l

  ! the ordered arrow E -> K -> R is the one directed datum the Tongue

  ! owns at this register (Bedrock: the Tongue fixes the sign). This

  ! screen executes it: every existence token must precede every kinetic

  ! token, and every kinetic token every relational one. What it cannot

  ! do, by the seated non-closure theorem, is judge meaning; a

  ! well-ordered recoding passes at the count register and only there.

  subroutine seal_l_ordered(sent, tok, why)

    integer, intent(in) :: sent(:)

    character(*), intent(out) :: tok, why

    integer :: ne, nk, nr, t, laste, firstk, lastk, firstr

    call slot_census(sent, ne, nk, nr)

    if (ne == 0 .or. nk == 0 .or. nr == 0) then

      call seal_l(ne, nk, nr, .false., tok, why)

      return

    end if

    laste = 0; firstk = size(sent)+1; lastk = 0; firstr = size(sent)+1

    do t = 1, size(sent)

      if (any(SLOT_E == sent(t))) laste = t

      if (any(SLOT_K == sent(t))) then

        if (t < firstk) firstk = t

        if (t > lastk) lastk = t

      end if

      if (any(SLOT_R == sent(t))) then

        if (t < firstr) firstr = t

      end if

    end do

    if (.not. (laste < firstk .and. lastk < firstr)) then

      tok = '[X]'; why = 'Seal L: the ordered arrow E->K->R is broken in the encoding'

      return

    end if

    call seal_l(ne, nk, nr, .false., tok, why)

  end subroutine seal_l_ordered

  ! the cut D = diag(1,1,0) applied to 3-vectors: the deletion operator

  pure function cut3(v) result(w)

    real(wp), intent(in) :: v(3)

    real(wp) :: w(3)

    w = [v(1), v(2), 0.0_wp]

  end function cut3

end module ra_tongue

! ---------------------------------------------------------------------

!  The Number: the shared quaternionic kernel with common-source

!  projection, four determinant estimators, the conditioning gate,

!  margins, and the source-share receipt. Rows in, verdict out; the

!  kernel derives no row from any proposition. Every exit carries an

!  integer reason code beside the token and the mechanism string, so

!  the battery adjudicates on codes and never on string drift.

module ra_kernel

  use ra_kinds

  use ra_prims

  implicit none

  integer, parameter :: RC_OK        = 0

  integer, parameter :: RC_SHORTFALL = 1

  integer, parameter :: RC_INTAKE    = 2

  integer, parameter :: RC_ZEROVAR   = 3

  integer, parameter :: RC_COVBLOCK  = 4

  integer, parameter :: RC_ABSORBED  = 5

  integer, parameter :: RC_COPLANAR  = 6

  integer, parameter :: RC_COLLAPSE  = 7

  integer, parameter :: RC_KAPPA     = 8

  integer, parameter :: RC_ENGINC    = 9

  integer, parameter :: RC_LOCK      = 10

contains

  ! center + unit-variance + unit-norm rows; flags a contentless row

  subroutine prepare_rows(m, q, ok, why, code)

    real(wp), intent(in)  :: m(:,:)          ! (3,N)

    real(wp), intent(out) :: q(size(m,1), size(m,2))

    logical,  intent(out) :: ok

    character(*), intent(out) :: why

    integer, intent(out) :: code

    integer :: i, n, j2

    real(wp) :: mu, sd, nrm, rmax

    n = size(m,2); ok = .true.; why = 'rows prepared'; code = RC_OK

    do i = 1, 3

      do j2 = 1, n

        if (.not. is_finite(m(i,j2))) then

          ok = .false.; why = 'non-finite row at intake'; code = RC_INTAKE

          return

        end if

      end do

      rmax = maxval(abs(m(i,:)))

      if (rmax > 0.0_wp) then

        q(i,:) = m(i,:) / rmax

      else

        q(i,:) = m(i,:)

      end if

      mu = sum(q(i,:)) / real(n, wp)

      q(i,:) = q(i,:) - mu

      sd = sqrt(sum(q(i,:)**2) / real(n-1, wp))

      if (sd <= 0.0_wp) then

        ok = .false.; why = 'zero-variance row: axis carries no content'

        code = RC_ZEROVAR

        return

      end if

      q(i,:) = q(i,:) / sd

      nrm = vnorm(q(i,:))

      q(i,:) = q(i,:) / nrm

    end do

  end subroutine prepare_rows

  ! project the span of centered covariates out of prepared rows.

  ! Guarded at k > 2 (refused, named); rank deficiency and

  ! ill-conditioning unify on one relative test and one phrase, so the

  ! refusal is decided by structure and not by which side of a

  ! floating-point zero an exact dependence happens to land on.

  subroutine project_cov(q, c, qf, ok, why, code, kcc)

    real(wp), intent(in)  :: q(:,:)          ! (3,N) prepared

    real(wp), intent(in)  :: c(:,:)          ! (k,N) covariates, k = 0..2

    real(wp), intent(out) :: qf(size(q,1), size(q,2))

    logical,  intent(out) :: ok

    character(*), intent(out) :: why

    integer, intent(out) :: code

    real(wp), intent(out) :: kcc

    real(wp) :: cc(2,2), cm(2, size(q,2)), rhs(2), beta(2), det, mu, tolrk

    integer :: i, j, n, k

    n = size(q,2); k = size(c,1); qf = q; ok = .true.; why = 'no covariates'

    code = RC_OK

    kcc = 1.0_wp

    if (k == 0) return

    if (k > 2) then

      ok = .false.; code = RC_COVBLOCK

      why = 'covariate block: more than two covariates, not implemented'

      return

    end if

    do i = 1, k

      do j = 1, n

        if (.not. is_finite(c(i,j))) then

          ok = .false.; code = RC_INTAKE

          why = 'non-finite covariate at intake'

          return

        end if

      end do

    end do

    ! centering, then the linear variance floor: a covariate whose centered

    ! amplitude sits at the rounding floor of its raw magnitude carries no

    ! projectable content and refuses. The test is linear in U_M and

    ! overflow-free at any finite scale. Rows that pass are equilibrated

    ! to unit max amplitude; the projection onto their span is invariant

    ! under per-row scaling, so huge finite covariates behave like O(1).

    do i = 1, k

      mu = sum(c(i,:)) / real(n, wp)

      cm(i,1:n) = c(i,:) - mu

      det = maxval(abs(cm(i,1:n)))

      if (det <= 32.0_wp * U_M * max(maxval(abs(c(i,:))), tiny(1.0_wp))) then

        ok = .false.; code = RC_COVBLOCK

        why = 'covariate block rank-deficient or ill-conditioned'

        return

      end if

      cm(i,1:n) = cm(i,1:n) / det

    end do

    if (k == 1) then

      det = sum(cm(1,1:n)**2)

      kcc = 1.0_wp

      do i = 1, 3

        beta(1) = sum(qf(i,:)*cm(1,1:n)) / det

        qf(i,:) = qf(i,:) - beta(1)*cm(1,1:n)

      end do

      why = 'one covariate projected'

      return

    end if

    cc(1,1) = sum(cm(1,1:n)**2); cc(2,2) = sum(cm(2,1:n)**2)

    cc(1,2) = sum(cm(1,1:n)*cm(2,1:n)); cc(2,1) = cc(1,2)

    ! k = 2 test on equilibrated rows: Gram determinant against its own

    ! relative rounding floor (U_M scale): near-dependence refuses. This is

    ! a direction test and the equilibration has made it scale-free.

    det = cc(1,1)*cc(2,2) - cc(1,2)*cc(2,1)

    tolrk = 64.0_wp * U_M * max(cc(1,1)*cc(2,2), tiny(1.0_wp))

    if (det <= tolrk) then

      ok = .false.; code = RC_COVBLOCK

      why = 'covariate block rank-deficient or ill-conditioned'

      return

    end if

    ! conditioning of CC^T via its two eigenvalues

    block

      real(wp) :: tr, dd, l1, l2

      tr = cc(1,1) + cc(2,2)

      dd = sqrt(max(0.0_wp, tr*tr - 4.0_wp*det))

      l1 = 0.5_wp*(tr - dd); l2 = 0.5_wp*(tr + dd)

      if (l1 <= 0.0_wp) then

        kcc = huge(1.0_wp)

      else

        kcc = l2 / l1

      end if

    end block

    if (kcc >= 1.0e6_wp) then

      ok = .false.; code = RC_COVBLOCK

      why = 'covariate block rank-deficient or ill-conditioned'

      return

    end if

    do i = 1, 3

      rhs(1) = sum(qf(i,:)*cm(1,1:n)); rhs(2) = sum(qf(i,:)*cm(2,1:n))

      beta(1) = ( cc(2,2)*rhs(1) - cc(1,2)*rhs(2)) / det

      beta(2) = (-cc(2,1)*rhs(1) + cc(1,1)*rhs(2)) / det

      do j = 1, n

        qf(i,j) = qf(i,j) - beta(1)*cm(1,j) - beta(2)*cm(2,j)

      end do

    end do

    why = 'two covariates projected (common-source projection)'

  end subroutine project_cov

  ! orthonormal basis of the row space by modified Gram-Schmidt with a

  ! second re-orthogonalization pass (twice is enough), row count

  ! generalized so a two-row pair can be ranked directly.

  subroutine span_basis(q, b, rank)

    real(wp), intent(in)  :: q(:,:)

    real(wp), intent(out) :: b(size(q,1), size(q,2))

    integer,  intent(out) :: rank

    real(wp) :: v(size(q,2)), nrm

    integer :: i, j, pass

    rank = 0; b = 0.0_wp

    do i = 1, size(q,1)

      v = q(i,:)

      do pass = 1, 2

        do j = 1, rank

          v = v - sum(v*b(j,:)) * b(j,:)

        end do

      end do

      nrm = vnorm(v)

      if (nrm > 1.0e-12_wp) then

        rank = rank + 1

        b(rank,:) = v / nrm

      end if

    end do

  end subroutine span_basis

  ! lambda = Re( q1 q2 q3 ) with qi the pure quaternions of the span

  ! coordinates of the three rows in a supplied basis (fixed-basis law)

  function lambda_of(q, b) result(lam)

    real(wp), intent(in) :: q(:,:), b(:,:)

    real(wp) :: lam, co(3,3), quat(4,3), t(4)

    integer :: i

    do i = 1, 3

      co(i,1) = sum(q(i,:)*b(1,:))

      co(i,2) = sum(q(i,:)*b(2,:))

      co(i,3) = sum(q(i,:)*b(3,:))

      quat(:,i) = [0.0_wp, co(i,1), co(i,2), co(i,3)]

    end do

    t = qmul(qmul(quat(:,1), quat(:,2)), quat(:,3))

    lam = t(1)

  end function lambda_of

  ! source-share receipt: R^2 of one raw row on the centered covariates.

  ! k = 1 implemented; k > 2 refuses as NaN so misuse surfaces loudly.

  function eta_share(row, c) result(eta)

    real(wp), intent(in) :: row(:), c(:,:)

    real(wp) :: eta, cm(2,size(row)), rm(size(row))

    real(wp) :: cc(2,2), rhs(2), beta(2), det, sst, ssf, mu

    integer :: i, n, k

    n = size(row); k = size(c,1)

    if (any(.not. is_finite(row))) then

      eta = qnan()

      return

    end if

    if (k >= 1) then

      if (any(.not. is_finite(c))) then

        eta = qnan()

        return

      end if

    end if

    mu = sum(row)/real(n,wp); rm = row - mu

    sst = sum(rm*rm)

    eta = 0.0_wp

    if (sst <= 0.0_wp .or. k == 0) return

    if (k > 2) then

      eta = qnan()

      return

    end if

    do i = 1, k

      mu = sum(c(i,:))/real(n,wp); cm(i,:) = c(i,:) - mu

      det = maxval(abs(cm(i,:)))

      if (det <= 32.0_wp*U_M*max(maxval(abs(c(i,:))), tiny(1.0_wp))) then

        eta = qnan()

        return

      end if

      cm(i,:) = cm(i,:) / det

    end do

    if (k == 1) then

      det = sum(cm(1,:)**2)

      beta(1) = sum(rm*cm(1,:)) / det

      ssf = beta(1)*beta(1)*det

      eta = ssf/sst

      return

    end if

    cc(1,1)=sum(cm(1,:)**2); cc(2,2)=sum(cm(2,:)**2)

    cc(1,2)=sum(cm(1,:)*cm(2,:)); cc(2,1)=cc(1,2)

    det = cc(1,1)*cc(2,2)-cc(1,2)*cc(2,1)

    if (det <= 64.0_wp*U_M*max(cc(1,1)*cc(2,2), tiny(1.0_wp))) then

      eta = qnan()

      return

    end if

    rhs(1)=sum(rm*cm(1,:)); rhs(2)=sum(rm*cm(2,:))

    beta(1)=( cc(2,2)*rhs(1)-cc(1,2)*rhs(2))/det

    beta(2)=(-cc(2,1)*rhs(1)+cc(1,1)*rhs(2))/det

    ssf = sum((beta(1)*cm(1,:)+beta(2)*cm(2,:))**2)

    eta = ssf/sst

  end function eta_share

  ! the full kernel: verdict, reason code, lambda, detR (four

  ! estimators), kappa, margins, spread, identity residual. Strict

  ! precedence: intake, variance, projection admissibility, absorbed

  ! axis, collapse, conditioning, then the lock.

  subroutine kernel_full(m, c, tok, why, rcode, lam, detr, kap, spread, resid, &

                         marg_c, marg_k, detfour)

    real(wp), intent(in) :: m(:,:), c(:,:)

    character(*), intent(out) :: tok, why

    integer, intent(out) :: rcode

    real(wp), intent(out) :: lam, detr, kap, spread, resid, marg_c, marg_k

    real(wp), intent(out) :: detfour(4)

    real(wp) :: q(3,size(m,2)), qf(3,size(m,2)), b(3,size(m,2))

    real(wp) :: r(3,3), eig(3), eps, kgate, kcc, dvar, tol

    integer :: n, k, i, rank, pcode, nest

    logical :: ok, jconv

    character(len=96) :: w2

    n = size(m,2); k = size(c,1)

    lam = 0.0_wp; detr = 0.0_wp; kap = 0.0_wp; spread = 0.0_wp

    resid = 0.0_wp; marg_c = 0.0_wp; marg_k = 0.0_wp; detfour = 0.0_wp

    rcode = RC_OK

    if (size(m,1) /= 3) then

      tok = '[?]'; why = 'row count is not three at intake'; rcode = RC_INTAKE

      return

    end if

    if (n - k < 4) then

      tok = '[?]'; why = 'N-k < 4 dimensional shortfall'; rcode = RC_SHORTFALL

      return

    end if

    call prepare_rows(m, q, ok, w2, pcode)

    if (.not. ok) then

      tok = '[?]'; why = trim(w2); rcode = pcode

      return

    end if

    call project_cov(q, c, qf, ok, w2, pcode, kcc)

    if (.not. ok) then

      tok = '[?]'; why = trim(w2); rcode = pcode

      return

    end if

    do i = 1, 3

      dvar = sum(qf(i,:)**2)

      if (dvar < 1.0e-9_wp) then                        ! post-projection axis absorbed by a covariate

        tok = '[?]'; why = 'post-projection axis absorbed by a covariate'

        rcode = RC_ABSORBED

        return

      end if

      qf(i,:) = qf(i,:) / vnorm(qf(i,:))

    end do

    r = matmul(qf, transpose(qf))

    detfour(1) = det3(r)

    call jacobi3(r, eig, jconv)

    detfour(2) = eig(1)*eig(2)*eig(3)

    ! four estimators, disjoint algorithms sharing one IEEE model: two

    ! cofactor expansion orders, the eigenvalue product, the Cholesky

    ! square. No estimator ever substitutes for another; a refused

    ! Cholesky routes engineering-incomplete rather than narrowing the

    ! spread it was meant to widen.

    detfour(3) = det3_chol(r)

    detfour(4) = det3_row2(r)

    nest = 4

    if (.not. is_finite(detfour(3))) nest = 3

    detr = detfour(1)

    if (nest == 4) then

      spread = maxval(detfour) - minval(detfour)

    else

      spread = max(detfour(1), detfour(2), detfour(4)) &

             - min(detfour(1), detfour(2), detfour(4))

    end if

    kap = cond3(r)

    if (.not. jconv) then

      tok = '[?]'; why = 'engineering-incomplete: eigensolver unconverged'; rcode = RC_ENGINC

      return

    end if

    call span_basis(qf, b, rank)

    if (rank < 3) then

      tok = '[X]'; why = 'coplanar collapse: rank(rows) < 3, line not point'

      rcode = RC_COPLANAR

      detr = 0.0_wp

      return

    end if

    lam = lambda_of(qf, b)

    resid = abs(lam*lam - detr)

    eps = 100.0_wp * U_M * real(n, wp)

    kgate = min(1.0e6_wp, sqrt(27.0_wp / (100.0_wp*U_M*real(n,wp))))

    tol = 4.0_wp * kap * U_M

    if (detr <= eps) then

      tok = '[X]'; why = 'collapse: det(R) <= eps'; rcode = RC_COLLAPSE

      return

    end if

    if (kap >= kgate) then

      tok = '[?]'; why = 'kappa(R) >= gate'; rcode = RC_KAPPA

      return

    end if

    marg_c = log10(detr/eps)

    marg_k = log10(kgate/kap)

    if (spread > tol .or. resid > max(tol, 8.0_wp*U_M)) then

      tok = '[?]'; why = 'engineering-incomplete: spread or identity outside tol'

      rcode = RC_ENGINC

      return

    end if

    if (nest < 4) then

      tok = '[?]'; why = 'engineering-incomplete: estimator shortfall (Cholesky refused SPD)'

      rcode = RC_ENGINC

      return

    end if

    tok = '[LOCK]'

    why = 'determination: three independent axes, one point'

    rcode = RC_LOCK

  end subroutine kernel_full

end module ra_kernel

! ---------------------------------------------------------------------

!  The guards and the admission spine. Nothing here computes a number

!  toward any verdict; everything here gates what a verdict may claim.

!  The two-spine law executable: delete a research-tier boolean and

!  the emitter refuses rather than weakens.

module ra_guards

  use ra_kinds

  implicit none

  integer :: aegis_deeds = 0        ! every adjudication is itself an act

  integer :: aegis_last_len = -1    ! length of the last logic name read

contains

  ! Omega Boundary, executable: registering any denial costs bits, and

  ! bits cost energy. Zero bits registered is no denial at all. A

  ! nonphysical temperature is refused, never priced.

  subroutine omega_boundary(bits, tk, joules, verdict, ocode, irreversible)

    real(wp), intent(in) :: bits, tk

    real(wp), intent(out) :: joules

    character(*), intent(out) :: verdict

    integer, intent(out), optional :: ocode

    logical, intent(in), optional :: irreversible

    logical :: irr

    irr = .true.

    if (present(irreversible)) irr = irreversible

    if (.not.(is_finite(tk) .and. is_finite(bits)) .or. tk <= 0.0_wp) then

      joules = qnan()

      verdict = 'refused: intake invalid, the floor prices only finite bits at tk > 0'

      if (present(ocode)) ocode = 0

      return

    end if

    if (bits <= 0.0_wp) then

      joules = 0.0_wp

      verdict = 'no denial registered; nothing to adjudicate'

      if (present(ocode)) ocode = 1

    else if (.not. irr) then

      joules = 0.0_wp

      verdict = 'reversibly registered: floor-zero never cost-zero; Landauer bounds '// &

                'only the irreversible (Bennett), and nothing here commits against the axiom'

      if (present(ocode)) ocode = 3

    else

      joules = bits * KB * tk * ln2_()

      verdict = 'the denial paid the floor; the registered act is an act, the recursion closes per the seated theorem'

      if (present(ocode)) ocode = 2

    end if

  end subroutine omega_boundary

  ! AEGIS, the Alien Guard, executable: the refusal is a function of

  ! the deed bit, never of the logic parameter. Any call increments

  ! the deed counter, because calling is doing.

  subroutine aegis_guard(logic_mode, refusal)

    character(*), intent(in)  :: logic_mode

    character(*), intent(out) :: refusal

    aegis_deeds = aegis_deeds + 1

    refusal = 'p(G) /= G: precisification is an actuation, G is a '// &

              'non-actuation, and no logic makes a deed a non-deed'

    aegis_last_len = len_trim(logic_mode)   ! the parameter is read; the refusal never varies with it

  end subroutine aegis_guard

  ! deed-counter reset for re-entrant harnesses; the count itself is

  ! thesis content and stays module state in the single-image program.

  subroutine aegis_reset()

    aegis_deeds = 0

  end subroutine aegis_reset

  ! GOL admission: magnitude from the Form-and-Number, direction from

  ! the Tongue. A magnitude lock without the linguistic seal routes

  ! under-determined for want of direction.

  subroutine gol_admit(magnitude, ling, tok, why, gcode)

    character(*), intent(in)  :: magnitude, ling

    character(*), intent(out) :: tok, why

    integer, intent(out), optional :: gcode

    integer :: gc_l

    if (magnitude == 'broken') then

      tok = '[X]'; why = 'geometric/math magnitude reports broken geometry; no GOL'; gc_l = 1

    else if (magnitude /= 'lock') then

      tok = '[?]'; why = 'no geometric/math lock: orthogonal volume unestablished'; gc_l = 2

    else if (ling /= 'lock') then

      tok = '[?]'; why = 'magnitude locks but Seal L open: determinant carries no direction'; gc_l = 3

    else

      tok = '[GOL-OK]'; why = 'magnitude plus direction; proceed to witness and asymmetry'; gc_l = 4

    end if

    if (present(gcode)) gcode = gc_l

  end subroutine gol_admit

  ! the four-guard imprint emitter: Seal L, the twelve gates, the lock

  ! asymmetry, and a supplied determinacy witness. Defaults absent, so

  ! an under-specified call never seals.

  subroutine imprint_seal(lock_p, lock_n, sl_p, sl_n, g_p, g_n, wit_p, wit_n, tok, why, icode)

    logical, intent(in) :: lock_p, lock_n, sl_p, sl_n, g_p, g_n, wit_p, wit_n

    character(*), intent(out) :: tok, why

    integer, intent(out), optional :: icode

    logical :: clean_p, clean_n

    integer :: ic_l

    clean_p = lock_p .and. sl_p .and. g_p

    clean_n = lock_n .and. sl_n .and. g_n

    if (clean_p .and. clean_n) then

      tok = '[X]'; why = 'PLATONIC GHOST: both directions clean-lock, no imprint'; ic_l = 1

    else if (clean_p .and. .not. clean_n) then

      if (wit_p) then

        tok = '[SEAL]'; why = 'only P clean-locks; determinacy witness supplied'; ic_l = 2

      else

        tok = '[?]'; why = 'residence: P clean-locks, imprint unproven (no witness)'; ic_l = 3

      end if

    else if (clean_n .and. .not. clean_p) then

      if (wit_n) then

        tok = '[SEAL]'; why = 'only not-P clean-locks; determinacy witness supplied'; ic_l = 2

      else

        tok = '[?]'; why = 'residence: not-P clean-locks, imprint unproven (no witness)'; ic_l = 3

      end if

    else if (.not. lock_p .and. .not. lock_n) then

      tok = '[?]'; why = 'flat: neither direction populated'; ic_l = 4

    else

      tok = '[?]'; why = 'uncertified: lock present but Seal L / gate screen unconfirmed'; ic_l = 5

    end if

    if (present(icode)) icode = ic_l

  end subroutine imprint_seal

  ! the row-genus cascade of sPSP-GOL-ROW-GENUS-01: a lock is always a

  ! determination and total about its object; the compartment names

  ! what its rows determined about. F-0 non-vacuity, R-3 register

  ! routing, S-1 population, S-2 row provenance, S-3 term closure,

  ! S-4 frame closure, and the mandatory RA rider. An unannotated

  ! absolute is void.

  subroutine row_cascade(nonvacuous, ve_live, forward, populated, worldly_row, &

                         terms_closed, term_worldly, frame_closed, annotate, tok, why, ccode)

    logical, intent(in) :: nonvacuous, ve_live, forward, populated, worldly_row

    logical, intent(in) :: terms_closed, term_worldly, frame_closed, annotate

    character(*), intent(out) :: tok, why

    integer, intent(out), optional :: ccode

    integer :: cc_l

    if (.not. nonvacuous) then

      tok = '[REFUSED]'; why = 'F-0: contentless; a contentless residence verifies nothing'

      cc_l = 1

    else if (ve_live .or. forward) then

      tok = '[III]'; why = 'R-3: V_E live or Forward; world-rowed, revisability in the rows'

      cc_l = 3

    else if (.not. populated) then

      tok = '[II]'; why = 'S-1: third axis unpopulated; two planes meet in a line, no lock'

      cc_l = 2

    else if (worldly_row) then

      tok = '[III]'; why = 'S-2: a load-bearing row is furnished by the world'

      cc_l = 3

    else if (.not. terms_closed) then

      if (term_worldly) then

        tok = '[III]'; why = 'S-3: an unclosed term is worldly'

        cc_l = 3

      else

        tok = '[II]'; why = 'S-3: an unclosed term is formal; no closure-rowed lock'

        cc_l = 2

      end if

    else if (.not. frame_closed) then

      tok = '[III]'; why = 'S-4: existential import leaks past the closure'

      cc_l = 3

    else if (.not. annotate) then

      tok = '[VOID]'; why = 'RA rider absent: an unannotated absolute is void'

      cc_l = 5

    else

      tok = '[A|RA]'

      why = 'compartment I, closure-rowed: [seal A . RA], conditional at the act'

      cc_l = 4

    end if

    if (present(ccode)) ccode = cc_l

  end subroutine row_cascade

  ! the positive-mass admission cascade, M1..M8. M5 and M6 are the two

  ! gates no internal reasoning can set true.

  subroutine delta_m(object_level, name_strip, lit_clear, not_two_line, &

                     witness, independent, artifact, gap_closed, tok, why, mcode)

    logical, intent(in) :: object_level, name_strip, lit_clear, not_two_line

    logical, intent(in) :: witness, independent, artifact, gap_closed

    character(*), intent(out) :: tok, why

    integer, intent(out), optional :: mcode

    integer :: mc_l

    mc_l = 9

    if (.not. object_level) then

      tok = '[Mosaic dM=0]'; why = 'M1: meta-work, no mass by definition'; mc_l = 1

    else if (.not. name_strip) then

      tok = '[?]'; why = 'M2: new vocabulary is not new mass'; mc_l = 2

    else if (.not. lit_clear) then

      tok = '[?]'; why = 'M3: possibly resident in the literature'; mc_l = 3

    else if (.not. not_two_line) then

      tok = '[?]'; why = 'M4: two-line corollary'; mc_l = 4

    else if (.not. witness) then

      tok = '[?]'; why = 'M5: no external witness; never seals on internal reasoning'; mc_l = 5

    else if (.not. independent) then

      tok = '[?]'; why = 'M6: verifier is the claimant; self-check is not a witness'; mc_l = 6

    else if (.not. artifact) then

      tok = '[?]'; why = 'M7: no reproducible artifact'; mc_l = 7

    else if (.not. gap_closed) then

      tok = '[?]'; why = 'M8: adversarial gap-audit open'; mc_l = 8

    else

      tok = '[dM>0]'; why = 'authored mass, external witness, defeasible-final'

    end if

    if (present(mcode)) mcode = mc_l

  end subroutine delta_m

  ! the twelve directed gates as a screen: first failure terminates

  ! with the gate named. Booleans are supplied by executed facts where

  ! executable and by declared screens otherwise; the roster is a

  ! filter and never a score.

  subroutine gate_screen(pass, tok, why, gidx)

    logical, intent(in) :: pass(12)

    character(*), intent(out) :: tok, why

    integer, intent(out), optional :: gidx

    character(len=6), parameter :: nm(12) = [ 'SREP  ','REG   ','SGEG  ', &

      'CAUSAL','MIG   ','PTB   ','DUAL  ','CSCG  ','CSEG  ','MTA   ', &

      'OMA   ','ADEG  ' ]

    integer :: i

    if (present(gidx)) gidx = 0

    do i = 1, 12

      if (.not. pass(i)) then

        tok = '[X]'

        write(why,'(a,i0,a,a)') 'gate ', i, ' failed: ', trim(nm(i))

        if (present(gidx)) gidx = i

        return

      end if

    end do

    tok = '[G-OK]'; why = 'twelve directed gates passed'

  end subroutine gate_screen

end module ra_guards

! ---------------------------------------------------------------------

module ra_battery

  implicit none

  integer :: n_checks = 0, n_fail = 0

  logical :: halt_on_fail = .true.   ! sealed mode; 'audit' arg accumulates

contains

  subroutine check(name, cond)

    character(*), intent(in) :: name

    logical, intent(in) :: cond

    n_checks = n_checks + 1

    if (.not. cond) then

      n_fail = n_fail + 1

      write(*,'(a,a)') 'CHECK FAILED: ', trim(name)

      if (halt_on_fail) error stop 1

    end if

  end subroutine check

  ! both modes refuse on failure: sealed halts at the first, audit

  ! accumulates the census and refuses here. A failed run never exits 0.

  subroutine battery_close()

    if (n_fail > 0) then

      write(*,'(a,i0,a)') 'BATTERY CLOSED WITH ', n_fail, ' FAILURES'

      error stop 1

    end if

  end subroutine battery_close

end module ra_battery

! =====================================================================

program ra_toe_thesis

  use ra_kinds

  use ra_prims

  use ra_floor

  use ra_integers

  use ra_tongue

  use ra_kernel

  use ra_guards

  use ra_battery

  use, intrinsic :: iso_fortran_env, only: compiler_version, compiler_options

  implicit none

  integer, parameter :: NCTX = 24

  real(wp) :: th(NCTX), l10m(NCTX), l10dx(NCTX), l10w(NCTX), l10t(NCTX), l10b(NCTX)

  real(wp) :: rows(3,NCTX), cov(2,NCTX), mixm(3,NCTX), floorv(NCTX)

  real(wp) :: amix(3,3), bmix(3,2)

  real(wp) :: qf(3,NCTX), bas(3,NCTX), quat(4,3), co(3,3), rmat(3,3)

  real(wp) :: lam, detr, kap, spread, resid, mc, mk, d4(4), eta(3)

  real(wp) :: lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42(4)

  real(wp) :: e1f, e2f, e3f, jou, tau, tperp(3), surv(5), tqs(5)

  real(wp) :: arrow_f, arrow_r, hbit, lamref, detref, lamneg

  real(wp) :: lam_rot, dlam_max, lam_c, lam_v, g(4), uvec(3), aa, bb, cc2

  real(wp) :: rneg(3,3), dbase, dpat, fr_resid

  integer :: i, j, k, l, n, s1, s2, s3, rank, nflip, nadm, ncomp1, ncomp2

  integer :: cnt, csizes(12), nrep, orbitn, stabn, rc, nsheets

  integer(ik) :: hu(4,24), p4(4), q4(4), e8a(8), e8b(8), e8c(8), z8(8)

  integer(ik) :: t1(8), t2(8), assoc8(8), sa(16), sb(16), sp(16)

  integer(ik) :: reps(4,12), cw(4), cx(4), cy(4)

  integer :: pl(24,2), found(2,2)

  logical :: pass12(12), okz, frz, hit, dual_ok, hurwitz_ok, rank3_ok, mig_ok

  character(len=16)  :: tk

  character(len=140) :: wy

  character(len=32)  :: argv

  write(*,'(a)') '====================================================================='

  write(*,'(a)') ' THE ROOT AXIOM STATED IN FORTRAN AND IN NOTHING ELSE'

  write(*,'(a)') ' RA as the TOE of all TOEs, executed. RA_TOE_Thesis_Fortran v1.7.0'

  write(*,'(a)') '====================================================================='

  argv = ' '

  call get_command_argument(1, argv)

  if (trim(argv) == 'audit') then

    halt_on_fail = .false.

    write(*,'(a)') ' mode: audit (failures accumulate; a nonzero count still refuses at close)'

  else

    write(*,'(a)') ' mode: sealed (the first failing check halts; the Fidelity Lock)'

  end if

  write(*,'(a)') ' build: '//compiler_version()

  write(*,'(a)') ' flags: '//compiler_options()

  ! ------------------------------------------------------------------

  write(*,'(/a)') 'PART 0 - THE ENVIRONMENT CONTRACT - enforced at run, never trusted to flags'

  block

    real(wp) :: xn, subn

    real(wp), volatile :: opq, xf, yf, prodv, rfma, xg, yg, rf2, rf4, r2v

    xn = qnan()

    call check('IEEE contract: quiet NaN reads as NaN (ieee_is_nan)', is_nan(xn))

    call check('IEEE contract: NaN self-inequality survives the optimizer', xn /= xn)

    subn = tiny(1.0_wp) * 0.5_wp

    call check('IEEE contract: gradual underflow alive, no FTZ/DAZ', &

         subn > 0.0_wp .and. subn < tiny(1.0_wp))

    call check('binary64 pinned: radix 2', radix(1.0_wp) == 2)

    call check('binary64 pinned: 53 significand digits', digits(1.0_wp) == 53)

    call check('binary64 pinned: max exponent 1024', maxexponent(1.0_wp) == 1024)

    call check('binary64 pinned: min exponent -1021', minexponent(1.0_wp) == -1021)

    opq = 1.0_wp

    xf = opq + scale(opq, -30)

    yf = opq - scale(opq, -30)

    prodv = xf*yf

    call check('binary64 per operation: the bare product stores to exactly one', &

         prodv == opq)

    rfma = xf*yf - opq

    call check('conduct probe a*b-c: no fusion executed (a fused path reads -2^-60 exactly)', &

         rfma == 0.0_wp)

    r2v = prodv - opq

    call check('differential witness: stored-product path agrees with the one-expression path', &

         rfma == r2v)

    rf2 = (-xf)*yf + opq

    call check('conduct probe (-a)*b+c: no fusion executed (a fused path reads +2^-60 exactly)', &

         rf2 == 0.0_wp)

    xg = opq + scale(opq, -27)

    yg = opq - scale(opq, -27)

    rf4 = xg*yg - opq

    call check('conduct probe at the 2^-27 tie: no fusion executed (a fused path reads -2^-54)', &

         rf4 == 0.0_wp)

  end block

  write(*,'(a)') '  a build that breaks any line above refuses to run: the contract is executed,'

  write(*,'(a)') '  so the bit-exact identities below rest on verified IEEE conduct. the'

  write(*,'(a)') '  probes certify CONDUCT and never consult flags: fused or extended'

  write(*,'(a)') '  arithmetic is refused where it executes, the march-native contract-fast'

  write(*,'(a)') '  build dying on the a*b-c probe, while a target carrying no fused'

  write(*,'(a)') '  instruction passes because none executed, the contract satisfied and'

  write(*,'(a)') '  not evaded; the fused residuals -2^-60, +2^-60, -2^-54 are exactly'

  write(*,'(a)') '  representable and never confusable with zero'

  ! ------------------------------------------------------------------

  write(*,'(/a)') 'PART A - SEAL L ON THE ROOT AXIOM - the Tongue loads first'

  call check('LIT: existence and kinetic slots disjoint', disjoint(SLOT_E, SLOT_K))

  call check('LIT: existence and relation slots disjoint', disjoint(SLOT_E, SLOT_R))

  call check('LIT: kinetic and relation slots disjoint',  disjoint(SLOT_K, SLOT_R))

  block

    integer :: nec, nkc, nrc, dsent(4), badk(NSLOT)

    call slot_census(RA_SENT, nec, nkc, nrc)

    write(*,'(a,i0,a,i0,a,i0)') '  slot census of the encoded sentence: E = ', nec, &

         ', K = ', nkc, ', R = ', nrc

    call check('the census counts every slot populated from the sentence', &

         nec == 2 .and. nkc == 2 .and. nrc == 2)

    call seal_l_ordered(RA_SENT, tk, wy)

    write(*,'(a,a,a,a)') '  parse(RA), census and order executed on the encoding: ', trim(tk), ' - ', trim(wy)

    call check('Seal L admits RA: three slots counted, the arrow E->K->R executed', tk == '[LOCK-L]')

    badk = SLOT_K; badk(2) = SLOT_E(1)

    call seal_l(nec, nkc, nrc, .not. disjoint(SLOT_E, badk), tk, wy)

    write(*,'(a,a,a,a)') '  collision control (computed overlap): ', trim(tk), ' - ', trim(wy)

    call check('Seal L refuses a computed vocabulary collision', tk == '[X]')

    dsent = [RA_SENT(1), RA_SENT(2), RA_SENT(5), RA_SENT(6)]

    call slot_census(dsent, nec, nkc, nrc)

    call seal_l(nec, nkc, nrc, .false., tk, wy)

    write(*,'(a,a,a,a)') '  deletion executed (kinetic tokens removed): ', trim(tk), ' - ', trim(wy)

    call check('the executed deletion of one slot refuses at two', &

         tk == '[X]' .and. nkc == 0)

  end block

  write(*,'(a)') '  order carried by the Tongue: existence -> kinetic -> relation;'

  write(*,'(a)') '  the word-to-slot map is declared semantics, the census and the'

  write(*,'(a)') '  deletion are executed on the encoding, per the anchor declaration;'

  write(*,'(a)') '  the map is an axiom of the encoding, consumed as a premise, and nothing'

  write(*,'(a)') '  downstream presents it as discovered'

  ! ------------------------------------------------------------------

  write(*,'(/a)') 'PART B - THE FLOOR IN NUMBERS - theorem-grade physics, executed'

  e1f = heis_floor(ME, 1.0e-10_wp)

  e2f = zpe(1.0e14_wp)

  e3f = landauer(300.0_wp, 1.0_wp)

  write(*,'(a,es16.9,a)') '  Heisenberg floor, electron at 1 Angstrom: ', e1f, ' J'

  write(*,'(a,es16.9,a)') '  zero-point energy at omega = 1e14 rad/s:  ', e2f, ' J'

  write(*,'(a,es16.9,a)') '  Landauer floor, one bit at 300 K:         ', e3f, ' J'

  call check('Heisenberg floor positive', e1f > 0.0_wp)

  call check('zero-point floor positive', e2f > 0.0_wp)

  call check('Landauer floor positive',  e3f > 0.0_wp)

  call check('Heisenberg floor magnitude (1.5e-19 band)', abs(e1f/1.526e-19_wp - 1.0_wp) < 1.0e-3_wp)

  call check('Landauer magnitude (2.87e-21 band)', abs(e3f/2.871e-21_wp - 1.0_wp) < 1.0e-3_wp)

  tqs = [0.0_wp, 0.25_wp, 0.5_wp, 0.75_wp, 1.0_wp] * pi_()

  do i = 1, 5

    surv(i) = survival(tqs(i))

  end do

  call tau_perp(0.5_wp, tau, frz)

  write(*,'(a,5f14.10)') '  qubit survival cos^2(t/2) at t = 0..pi:   ', surv(1:4)

  write(*,'(a,es12.4)')  '     terminal survival at t = pi:            ', surv(5)

  write(*,'(a,f16.12)')  '  orthogonalization time tau_perp:          ', tau

  write(*,'(a,f16.12)')  '  Mandelstam-Tamm bound pi/(2 dE):          ', pi_()/(2.0_wp*0.5_wp)

  write(*,'(a,f16.12)')  '  Margolus-Levitin bound pi/(2 <E>):        ', pi_()/(2.0_wp*0.5_wp)

  call check('speed limit saturated jointly (MT = ML = tau)', &

       abs(tau - pi_()) <= 4.0_wp*U_M*pi_())

  call check('survival dies at tau_perp', surv(5) < 1.0e-30_wp)

  call check('survival monotone over the quarter points', &

       surv(1) > surv(2) .and. surv(2) > surv(3) .and. surv(3) > surv(4))

  call tau_perp(5.0e-1_wp, tperp(1), frz)

  call tau_perp(5.0e-4_wp, tperp(2), frz)

  call tau_perp(5.0e-7_wp, tperp(3), frz)

  write(*,'(a,3es13.5)') '  Frozen Substrate: tau_perp at dE = 5e-1, 5e-4, 5e-7: ', tperp

  call check('tau_perp diverges monotonically as dE -> 0', tperp(1) < tperp(2) .and. tperp(2) < tperp(3))

  call tau_perp(0.0_wp, tau, frz)

  call check('dE = 0 is flagged frozen, no division performed', frz)

  write(*,'(a)') '  dE = 0: no transition, no registration; a zero-energy existent registers nothing'

  ! ------------------------------------------------------------------

  write(*,'(/a)') 'PART C - THE FORM IN INTEGERS - nothing here rounds'

  call hurwitz_units(hu)

  do i = 1, 24

    call check('Hurwitz unit norm 4 (doubled)', inrm(hu(:,i)) == 4_ik)

  end do

  n = 0

  do i = 1, 24

    do j = 1, 24

      p4 = iqmul(hu(:,i), hu(:,j))

      okz = all(mod(p4, 2_ik) == 0_ik)

      call check('unit product even in doubled coords', okz)

      q4 = p4 / 2_ik

      hit = .false.

      do k = 1, 24

        if (all(q4 == hu(:,k))) hit = .true.

      end do

      if (hit) n = n + 1

    end do

  end do

  write(*,'(a,i0,a)') '  closure of the 24 Hurwitz units: ', n, ' of 576 products inside'

  hurwitz_ok = (n == 576)

  call check('the 24 units close under multiplication', hurwitz_ok)

  ! class equation of the unit group modulo +-1: 12 classes -> 1,3,4,4

  nrep = 0

  do i = 1, 24

    cw = hu(:,i)

    call canon_sign(cw)

    hit = .false.

    do k = 1, nrep

      if (all(cw == reps(:,k))) hit = .true.

    end do

    if (.not. hit) then

      nrep = nrep + 1

      reps(:,nrep) = cw

    end if

  end do

  call check('unit group mod sign has 12 elements', nrep == 12)

  cnt = 0

  csizes = 0

  block

    integer(ik) :: cls(4,12)

    integer :: ncls, m2

    logical :: seen(12)

    seen = .false.

    do i = 1, nrep

      if (seen(i)) cycle

      ncls = 0

      do j = 1, 24

        cx = iqmul(iqmul(hu(:,j), reps(:,i)), iqconj(hu(:,j)))

        call check('conjugation divisible by 4', all(mod(cx, 4_ik) == 0_ik))

        cy = cx / 4_ik

        call canon_sign(cy)

        hit = .false.

        do k = 1, ncls

          if (all(cy == cls(:,k))) hit = .true.

        end do

        if (.not. hit) then

          ncls = ncls + 1

          cls(:,ncls) = cy

        end if

      end do

      cnt = cnt + 1

      csizes(cnt) = ncls

      do k = 1, ncls

        do m2 = 1, nrep

          if (all(cls(:,k) == reps(:,m2))) seen(m2) = .true.

        end do

      end do

    end do

  end block

  call sort_int(csizes(1:cnt))

  write(*,'(a,i0,a,4i3)') '  conjugacy classes mod sign: ', cnt, ' with sizes ', csizes(1:cnt)

  call check('class equation reads 1 + 3 + 4 + 4', cnt == 4 .and. csizes(1) == 1 &

       .and. csizes(2) == 3 .and. csizes(3) == 4 .and. csizes(4) == 4)

  ! norm-two shell: 24 = 12 pure + 12 real-occupied; zero half-integer members

  block

    integer :: a1, a2, a3, a4, npure, nreal, nhalf

    npure = 0; nreal = 0; nhalf = 0

    do a1 = -1, 1

     do a2 = -1, 1

      do a3 = -1, 1

       do a4 = -1, 1

         if (a1*a1 + a2*a2 + a3*a3 + a4*a4 == 2) then

           if (a1 == 0) then

             npure = npure + 1

           else

             nreal = nreal + 1

           end if

         end if

       end do

      end do

     end do

    end do

    do a1 = -3, 3, 2

     do a2 = -3, 3, 2

      do a3 = -3, 3, 2

       do a4 = -3, 3, 2

         if (a1*a1 + a2*a2 + a3*a3 + a4*a4 == 8) nhalf = nhalf + 1

       end do

      end do

     end do

    end do

    write(*,'(a,i0,a,i0,a,i0,a,i0)') '  norm-two shell: ', npure + nreal, &

         ' = ', npure, ' pure + ', nreal, ' real-occupied; half-integer members ', nhalf

    call check('norm-two shell is 24 = 12 + 12', npure == 12 .and. nreal == 12)

    call check('no half-integer element of norm two', nhalf == 0)

  end block

  ! A4 acts simply transitively on the 12 ordered pairs (the 12 gates)

  n = 0

  do i = 1, 4

    do j = 1, 4

      if (i /= j) then

        n = n + 1

        pl(n,:) = [i, j]

      end if

    end do

  end do

  call check('twelve ordered pairs of four vertices', n == 12)

  orbitn = 0; stabn = 0; cnt = 0

  block

    integer :: pm(4,24), npm, inv, x1, x2, x3, x4, t(4), orb(12,2), norb

    logical :: got

    npm = 0

    do x1 = 1, 4

     do x2 = 1, 4

      do x3 = 1, 4

       do x4 = 1, 4

         t = [x1, x2, x3, x4]

         if (all([(count(t == i), i = 1, 4)] == 1)) then

           inv = 0

           do i = 1, 3

             do j = i+1, 4

               if (t(i) > t(j)) inv = inv + 1

             end do

           end do

           if (mod(inv, 2) == 0) then

             npm = npm + 1

             pm(:,npm) = t

           end if

         end if

       end do

      end do

     end do

    end do

    call check('A4 has order 12', npm == 12)

    norb = 0

    do k = 1, npm

      t = pm(:,k)

      got = .false.

      do i = 1, norb

        if (orb(i,1) == t(1) .and. orb(i,2) == t(2)) got = .true.

      end do

      if (.not. got) then

        norb = norb + 1

        orb(norb,:) = [t(1), t(2)]

      end if

      if (t(1) == 1 .and. t(2) == 2) stabn = stabn + 1

    end do

    orbitn = norb

  end block

  write(*,'(a,i0,a,i0)') '  A4 orbit of the pair (1,2): size ', orbitn, ', stabilizer order ', stabn

  call check('A4 simply transitive on the twelve directed gates', orbitn == 12 .and. stabn == 1)

  block

    integer :: vcnt, ecnt, fcnt, i3, j3, k3

    vcnt = 0

    do i3 = 1, 4

      if (any(pl(1:n,1) == i3) .or. any(pl(1:n,2) == i3)) vcnt = vcnt + 1

    end do

    ecnt = n / 2

    fcnt = 0

    do i3 = 1, 4

      do j3 = i3+1, 4

        do k3 = j3+1, 4

          fcnt = fcnt + 1

        end do

      end do

    end do

    write(*,'(a,i0,a,i0,a,i0)') '  Euler counted from the built complex: V = ', vcnt, ', E = ', ecnt, ', F = ', fcnt

    call check('Euler closure counted from the complex: V - E + F = 2', vcnt - ecnt + fcnt == 2)

  end block

  ! relabel parity of the unit triad: even -> Re = -1, odd -> Re = +1

  block

    integer(ik) :: uq(4,3), pq(4)

    integer :: pms(3,6), inv, s

    pms = reshape([1,2,3, 2,3,1, 3,1,2, 2,1,3, 1,3,2, 3,2,1], [3,6])

    uq = 0_ik

    uq(2,1) = 1_ik; uq(3,2) = 1_ik; uq(4,3) = 1_ik

    do k = 1, 6

      inv = 0

      do i = 1, 2

        do j = i+1, 3

          if (pms(i,k) > pms(j,k)) inv = inv + 1

        end do

      end do

      s = merge(1, -1, mod(inv,2) == 0)

      pq = iqmul(iqmul(uq(:,pms(1,k)), uq(:,pms(2,k))), uq(:,pms(3,k)))

      if (k <= 3) then

        call check('even relabel lands Re = -1', pq(1) == -1_ik .and. s == 1)

      else

        call check('odd relabel lands Re = +1',  pq(1) == +1_ik .and. s == -1)

      end if

    end do

    write(*,'(a)') '  relabel parity: three even relabels land Re = -1, three odd land Re = +1'

    write(*,'(a)') '  one discrete modulus, the orientation bit; zero continuous moduli (Part E sweep)'

  end block

  ! the tower walls: associativity holds at H, dies at O, division dies at S

  block

    integer(ik) :: mx

    mx = 0_ik

    do i = 1, 24

      do j = 1, 24

        do k = 1, 24

          t1(1:4) = iqmul(iqmul(hu(:,i), hu(:,j)), hu(:,k))

          t2(1:4) = iqmul(hu(:,i), iqmul(hu(:,j), hu(:,k)))

          mx = max(mx, maxval(abs(t1(1:4) - t2(1:4))))

        end do

      end do

    end do

    write(*,'(a,i0)') '  quaternion associator over all 13824 unit triples, max |.|: ', mx

    call check('H is associative on the whole unit order', mx == 0_ik)

  end block

  e8a = 0_ik; e8b = 0_ik; e8c = 0_ik

  e8a(2) = 1_ik      ! e1

  e8b(3) = 1_ik      ! e2

  e8c(5) = 1_ik      ! e4

  t1 = iomul(iomul(e8a, e8b), e8c)

  t2 = iomul(e8a, iomul(e8b, e8c))

  assoc8 = t1 - t2

  z8 = 0_ik; z8(8) = 2_ik

  write(*,'(a,8i3)') '  octonion associator [e1,e2,e4] components: ', assoc8

  call check('octonion associator equals 2 e7 exactly', all(assoc8 == z8))

  call check('commutativity already dead at H: ij /= ji', &

       .not. all(iqmul(int([0,1,0,0],ik), int([0,0,1,0],ik)) == &

                 iqmul(int([0,0,1,0],ik), int([0,1,0,0],ik))))

  ! norm composition holds in H and O on an exact integer grid

  block

    integer(ik) :: av(8), bv(8), pv(8), aq(4), bq(4), pq(4)

    integer :: cnt2

    cnt2 = 0

    do i = -1, 1

      do j = -1, 1

        do k = -1, 1

          aq = int([i, j, k, 1], ik);  bq = int([1, k, j, i], ik)

          pq = iqmul(aq, bq)

          call check('H norm composition exact', inrm(pq) == inrm(aq)*inrm(bq))

          av = int([i, j, k, 1, j, k, i, 1], ik)

          bv = int([1, k, i, j, 1, i, j, k], ik)

          pv = iomul(av, bv)

          call check('O norm composition exact', inrm(pv) == inrm(av)*inrm(bv))

          cnt2 = cnt2 + 1

        end do

      end do

    end do

    write(*,'(a,i0,a)') '  norm composition |ab|^2 = |a|^2 |b|^2 exact on ', cnt2, ' integer pairs in H and in O'

  end block

  ! sedenions: first zero-divisor pair by exhaustive search

  hit = .false.

  outer: do i = 1, 15

    do j = i+1, 15

      do k = 1, 15

        do l = k+1, 15

          sa = 0_ik; sb = 0_ik

          sa(i+1) = 1_ik; sa(j+1) = 1_ik

          sb(k+1) = 1_ik; sb(l+1) = -1_ik

          sp = ismul(sa, sb)

          if (all(sp == 0_ik)) then

            hit = .true.

            found(1,:) = [i, j]; found(2,:) = [k, l]

            exit outer

          end if

        end do

      end do

    end do

  end do outer

  call check('a sedenion zero-divisor pair exists', hit)

  sa = 0_ik; sb = 0_ik

  sa(found(1,1)+1) = 1_ik; sa(found(1,2)+1) = 1_ik

  sb(found(2,1)+1) = 1_ik; sb(found(2,2)+1) = -1_ik

  sp = ismul(sa, sb)

  write(*,'(a,i0,a,i0,a,i0,a,i0,a)') '  sedenion wall: (e', found(1,1), ' + e', found(1,2), &

       ')(e', found(2,1), ' - e', found(2,2), ') = 0 exactly'

  write(*,'(a,i0,a,i0,a,i0)') '     with |a|^2 = ', inrm(sa), ', |b|^2 = ', inrm(sb), &

       ', |ab|^2 = ', inrm(sp)

  call check('division dies at S: nonzero factors, zero product', &

       inrm(sa) == 2_ik .and. inrm(sb) == 2_ik .and. inrm(sp) == 0_ik)

  call check('norm composition fails at S', inrm(sp) /= inrm(sa)*inrm(sb))

  write(*,'(a)') '  the walls in order: commutativity at H, associativity at O, division at S'

  block

    integer(ik) :: uq(4), tt(4)

    integer :: xg, yg, zg, nsur, offline

    tt = iqmul(int([0,1,0,0],ik), int([0,0,1,0],ik)) + iqmul(int([0,0,1,0],ik), int([0,1,0,0],ik))

    call check('i and j anticommute exactly: ij + ji = 0', all(tt == 0_ik))

    nsur = 0; offline = 0

    do xg = -2, 2

      do yg = -2, 2

        do zg = -2, 2

          if (xg == 0 .and. yg == 0 .and. zg == 0) cycle

          uq = int([0, xg, yg, zg], ik)

          block

            logical :: aci, acj

            aci = all(iqmul(int([0,1,0,0],ik), uq) + iqmul(uq, int([0,1,0,0],ik)) == 0_ik)

            acj = all(iqmul(int([0,0,1,0],ik), uq) + iqmul(uq, int([0,0,1,0],ik)) == 0_ik)

            if (aci .and. acj) then

              nsur = nsur + 1

              if (xg /= 0 .or. yg /= 0) offline = offline + 1

            end if

          end block

        end do

      end do

    end do

    write(*,'(a,i0,a,i0,a)') '  joint anticommutant of {i, j} on the exact grid: ', nsur, &

         ' of 124 nonzero points, ', offline, ' off the k-line'

    call check('the joint anticommutant is the k-line on the grid (independent cross-check)', &

         nsur == 4 .and. offline == 0)

    ! linearity certificate: u -> (iu+ui, ju+uj) is linear, so its kernel

    ! over the WHOLE space is fixed by exact evaluation on the basis. The

    ! images of e_x, e_y, e_z are computed in integers; the tail components

    ! vanish, the first-component constraint matrix has 2x2 minor 4 and a

    ! zero z-column, so the kernel is the k-line everywhere, not a patch.

    block

      integer(ik) :: bimg(8,3), ev(4)

      integer :: bi

      integer(ik) :: minor2

      do bi = 1, 3

        ev = 0_ik; ev(bi+1) = 1_ik

        bimg(1:4, bi) = iqmul(int([0,1,0,0],ik), ev) + iqmul(ev, int([0,1,0,0],ik))

        bimg(5:8, bi) = iqmul(int([0,0,1,0],ik), ev) + iqmul(ev, int([0,0,1,0],ik))

      end do

      call check('linearity certificate: only the scalar components survive on the basis', &

           all(bimg(2:4,:) == 0_ik) .and. all(bimg(6:8,:) == 0_ik))

      minor2 = bimg(1,1)*bimg(5,2) - bimg(1,2)*bimg(5,1)

      write(*,'(a,i0,a)') '  constraint matrix on the basis: 2x2 minor = ', minor2, &

           ', z-column identically zero'

      call check('linearity certificate: minor 4 and zero z-column force the k-line kernel everywhere', &

           minor2 == 4_ik .and. all(bimg(:,3) == 0_ik))

    end block

  end block

  write(*,'(a)') '  below the walls the third axis is begotten and confined: i j = k executed,'

  write(*,'(a)') '  and the joint anticommutant of {i, j} in Im H is the k-line, counted; the'

  write(*,'(a)') '  fourth is barred above by the executed associator wall; the identification'

  write(*,'(a)') '  of the three algebra axes with V_F, V_E, V_ER is the seated premise-typed'

  write(*,'(a)') '  mapping, consumed here and never a discovery of this run'

  ! ------------------------------------------------------------------

  write(*,'(/a)') 'PART D - THE NUMBER - the Return, then the physics-law reading'

  ! the Return on RA's own parse triad, in integers: Re(ijk) = -1, det = 1

  p4 = iqmul(iqmul(int([0,1,0,0],ik), int([0,0,1,0],ik)), int([0,0,0,1],ik))

  write(*,'(a,4i3,a)') '  the Return on the parse triad: i j k = ', p4, '   (Re = -1, the Ground)'

  call check('Hamilton landing Re(ijk) = -1 exactly', p4(1) == -1_ik .and. all(p4(2:4) == 0_ik))

  ! the Gram of the parse triad, formed and measured (v1.1.0: the old

  ! literal-true check is replaced by the computation it named)

  block

    integer(ik) :: uq(4,3)

    real(wp) :: m3(3,3), g3(3,3)

    integer :: r

    uq = 0_ik

    uq(2,1) = 1_ik; uq(3,2) = 1_ik; uq(4,3) = 1_ik

    do r = 1, 3

      m3(r,:) = real(uq(2:4,r), wp)

    end do

    g3 = matmul(m3, transpose(m3))

    call check('Gram of the orthonormal parse triad has det 1', &

         abs(det3(g3) - 1.0_wp) <= 4.0_wp*U_M)

  end block

  ! the full Return in floating point: the Fourier triad

  do i = 1, NCTX

    th(i) = 2.0_wp * pi_() * real(i-1, wp) / real(NCTX, wp)

    rows(1,i) = sin(th(i)); rows(2,i) = cos(th(i)); rows(3,i) = sin(2.0_wp*th(i))

  end do

  call kernel_full(rows, reshape([0.0_wp], [0, NCTX]), tk, wy, rc, lam, detr, kap, &

                   spread, resid, mc, mk, d4)

  write(*,'(a,a,a,f16.12,a,f16.12)') '  Fourier triad: ', trim(tk), &

       '  det(R) = ', detr, '  |lambda| = ', abs(lam)

  call check('full Return: det(R) = 1 at machine precision', abs(detr - 1.0_wp) < 1.0e-9_wp)

  call check('full Return: |lambda| = 1 at machine precision', abs(abs(lam) - 1.0_wp) < 1.0e-9_wp)

  call check('kernel identity lambda^2 = det(R) on the Return', resid < 1.0e-12_wp)

  call check('full Return carries the lock code', rc == RC_LOCK)

  fr_resid = resid

  ! the physics-law reading: 24 confined-existent contexts, three axes,

  ! two mass-bearing covariates, oblique mixing, common-source projection

  amix = reshape([1.00_wp,0.22_wp,0.16_wp, 0.35_wp,1.00_wp,0.20_wp, 0.12_wp,0.28_wp,1.00_wp],[3,3])

  bmix = reshape([0.60_wp,0.40_wp,0.55_wp, 0.30_wp,0.50_wp,0.20_wp],[3,2])

  do i = 1, NCTX

    l10m(i)  = log10(ME) + 5.0_wp   * (0.5_wp + 0.5_wp*sin(th(i)))

    l10dx(i) = -10.0_wp  + 4.0_wp   * (0.5_wp + 0.5_wp*sin(2.0_wp*th(i) + 1.0_wp))

    l10w(i)  = 12.0_wp   + 3.0_wp   * (0.5_wp + 0.5_wp*sin(3.0_wp*th(i) + 2.0_wp))

    l10t(i)  = 2.477_wp  * (0.5_wp + 0.5_wp*sin(5.0_wp*th(i) + 3.0_wp))

    l10b(i)  = 3.0_wp    * (0.5_wp + 0.5_wp*sin(7.0_wp*th(i) + 4.0_wp))

    rows(1,i) = log10(HBAR*HBAR/8.0_wp) - l10m(i) - 2.0_wp*l10dx(i)   ! formal: the bound

    rows(2,i) = log10(0.5_wp*HBAR) + l10w(i)                          ! empirical: zero-point

    rows(3,i) = log10(KB*ln2_()) + l10t(i) + l10b(i)                  ! registration: Landauer

    cov(1,i)  = -20.6_wp + 2.5_wp * (0.5_wp + 0.5_wp*sin(4.0_wp*th(i) + 0.5_wp))

    cov(2,i)  = -24.0_wp + 5.0_wp * (0.5_wp + 0.5_wp*sin(6.0_wp*th(i) + 1.5_wp))

    floorv(i) = 10.0_wp**rows(1,i)

  end do

  do i = 1, NCTX

    call check('kinetic floor positive at every context', floorv(i) > 0.0_wp)

  end do

  mixm = matmul(amix, rows) + matmul(bmix, cov)

  do i = 1, 3

    eta(i) = eta_share(mixm(i,:), cov)

  end do

  call kernel_full(mixm, cov, tk, wy, rc, lam, detr, kap, spread, resid, mc, mk, d4)

  write(*,'(a,a,a,a)') '  physics-law reading: ', trim(tk), ' - ', trim(wy)

  write(*,'(a,f16.12,a,f16.12)') '     det(R) = ', detr, '   lambda = ', lam

  write(*,'(a,f10.4,a,es10.3)')  '     kappa(R) = ', kap, '   four-estimator spread = ', spread

  write(*,'(a,es10.3,a,f7.2,a,f7.2)') '     |lambda^2 - det(R)| = ', resid, &

       '   margins (orders): collapse ', mc, ', conditioning ', mk

  write(*,'(a,3f8.4)') '     source-share eta per mixed row (pre-projection): ', eta

  write(*,'(a)') '     grid disclosure: the context grid is a constructed exhibit (deterministic'

  write(*,'(a)') '     harmonics); the rows are physical-law magnitudes (Heisenberg, zero-point,'

  write(*,'(a)') '     Landauer); the witness rides the cited theorems, never the grid'

  call check('physics-law reading on the constructed exhibit determines: [LOCK]', tk == '[LOCK]' .and. rc == RC_LOCK)

  call check('kernel identity within tolerance', resid <= max(4.0_wp*kap*U_M, 8.0_wp*U_M))

  call check('four estimators agree within tolerance', spread <= 4.0_wp*kap*U_M)

  call check('collapse margin exceeds ten orders', mc > 10.0_wp)

  call check('conditioning margin exceeds one order', mk > 1.0_wp)

  call check('source share strictly inside (0,1) on each row', &

       all(eta > 0.0_wp) .and. all(eta < 1.0_wp))

  ! keep the prepared, projected rows and the fixed basis for Part E

  block

    logical :: okp

    character(len=96) :: w2

    real(wp) :: kcc

    integer :: pcl

    block

      real(wp) :: qtmp(3,NCTX)

      call prepare_rows(mixm, qtmp, okp, w2, pcl)

      call project_cov(qtmp, cov, qf, okp, w2, pcl, kcc)

    end block

    do i = 1, 3

      qf(i,:) = qf(i,:) / vnorm(qf(i,:))

    end do

    call span_basis(qf, bas, rank)

    rank3_ok = (rank == 3)

    call check('span rank three after projection', rank3_ok)

  end block

  rmat = matmul(qf, transpose(qf))

  dbase = det3(rmat)

  lam = lambda_of(qf, bas)

  ! the manufactured axis dissolves at the projection

  block

    real(wp) :: mman(3,NCTX)

    mman(1,:) = mixm(1,:); mman(2,:) = mixm(2,:)

    mman(3,:) = 0.7_wp*cov(1,:) + 0.5_wp*cov(2,:)

    call kernel_full(mman, cov, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    write(*,'(a,a,a,a)') '  manufactured third axis: ', trim(tk), ' - ', trim(wy)

    mig_ok = (tk == '[?]' .and. rc == RC_ABSORBED)

    call check('an axis built from the covariates is absorbed, not locked', mig_ok)

  end block

  ! deletion at the residence: a zeroed slot refuses, a duplicated slot collapses

  block

    real(wp) :: mdel(3,NCTX)

    mdel = mixm; mdel(2,:) = 0.0_wp

    call kernel_full(mdel, cov, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    call check('deleted slot: axis carries no content', tk == '[?]' .and. rc == RC_ZEROVAR)

    mdel = mixm; mdel(3,:) = mdel(1,:)

    call kernel_full(mdel, cov, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    write(*,'(a,a,a,a)') '  duplicated slot: ', trim(tk), ' - ', trim(wy)

    call check('duplicated slot: coplanar collapse, a line and not a point', &

         tk == '[X]' .and. rc == RC_COPLANAR)

  end block

  ! full negation: the Gram is bit-identical; the signed scalar flips.

  ! (IEEE sign symmetry: (-a)*(-b) = a*b and RN(-x) = -RN(x) bit-exact;

  ! the environment contract of PART 0 is what licenses '==' here.)

  block

    real(wp) :: qneg(3,NCTX)

    qneg = -qf

    rneg = matmul(qneg, transpose(qneg))

    call check('full negation leaves the Gram bit-identical', &

         maxval(abs(rneg - rmat)) == 0.0_wp)

    lamneg = lambda_of(qneg, bas)

    call check('full negation flips lambda exactly', lamneg == -lam)

    write(*,'(a,es9.2,a,f16.12,a,f16.12)') '  full negation: max|G(P)-G(-P)| = ', &

         maxval(abs(rneg - rmat)), '   lambda ', lam, ' -> ', lamneg

  end block

  ! single-axis reflection on the fixed basis: lambda flips bit-exactly,

  ! the determinant does not move

  block

    real(wp) :: qref(3,NCTX), rref(3,3)

    qref = qf; qref(1,:) = -qref(1,:)

    lamref = lambda_of(qref, bas)

    rref = matmul(qref, transpose(qref))

    detref = det3(rref)

    write(*,'(a,f16.12,a,f16.12)') '  single reflection: lambda ', lam, ' -> ', lamref

    write(*,'(a,es9.2)') '     |det(R) - det(R) reflected| = ', abs(detref - dbase)

    dual_ok = (lamref == -lam) .and. (detref == dbase)

    call check('reflection flips lambda bit-exactly on the fixed basis', lamref == -lam)

    call check('reflection leaves det(R) unmoved bit-exactly', detref == dbase)

  end block

  ! time reversal: the determinant is even, the arrow is odd

  block

    real(wp) :: mrev(3,NCTX), crev(2,NCTX)

    do i = 1, NCTX

      mrev(:,i) = mixm(:,NCTX+1-i)

      crev(:,i) = cov(:,NCTX+1-i)

    end do

    call kernel_full(mrev, crev, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    arrow_f = 0.0_wp; arrow_r = 0.0_wp

    do i = 1, NCTX

      arrow_f = arrow_f + (10.0_wp**l10b(i)) * ln2_()

    end do

    do i = NCTX, 1, -1

      arrow_r = arrow_r - (10.0_wp**l10b(i)) * ln2_()

    end do

    write(*,'(a,es10.3)') '  time reversal: |det forward - det reversed| = ', abs(detr2 - detr)

    write(*,'(a,f14.4,a,f14.4,a)') '  the arrow (registration entropy, kB units): forward ', &

         arrow_f, ',  reversed ', arrow_r, '  (the sign parts them)'

    call check('the determinant is blind to the arrow', abs(detr2 - detr) <= 64.0_wp*kap*U_M)

    call check('the directed registration sum flips sign under traversal reversal '// &

         '(constructed odd witness; the physical arrow rides the cited second law)', &

         arrow_f > 0.0_wp .and. arrow_r < 0.0_wp &

         .and. abs(arrow_f + arrow_r) <= 1.0e-9_wp*arrow_f)

  end block

  ! ------------------------------------------------------------------

  write(*,'(/a)') 'PART E - THE BLINDNESS AND ITS EXACT WIDTH - one bit, counted'

  ! the eight reflection patterns: det(D R D) = det(R) bit-exactly.

  ! License for '==': one compiled det3 serves both calls; under D..D every

  ! monomial's sign product is +1, so all products and partial sums are

  ! bit-identical whatever the association; PART 0 pins contraction off besides

  do s1 = -1, 1, 2

   do s2 = -1, 1, 2

    do s3 = -1, 1, 2

      block

        real(wp) :: dd(3), rp(3,3)

        dd = real([s1, s2, s3], wp)

        do i = 1, 3

          do j = 1, 3

            rp(i,j) = dd(i)*dd(j)*rmat(i,j)

          end do

        end do

        dpat = det3(rp)

        call check('eight-pattern determinant invariance, bit-exact', dpat == dbase)

      end block

    end do

   end do

  end do

  write(*,'(a)') '  all eight sign patterns return det(D R D) = det(R) bit-exactly'

  write(*,'(a)') '  lock(P) = lock(not P) at the scalar: the Number is orientation-blind by theorem'

  ! the Form supplies zero bits: sigma restricted to the residence has

  ! determinant -1 for the claim and for its negation alike; the

  ! Groundless diagonal is BUILT and its ground dimension COUNTED

  block

    real(wp) :: sig(4,4), diag4(4,4), dres

    integer :: iq

    sig = 0.0_wp

    sig(1,1) = 1.0_wp; sig(2,2) = -1.0_wp; sig(3,3) = -1.0_wp; sig(4,4) = -1.0_wp

    dres = sig(2,2)*sig(3,3)*sig(4,4)

    diag4 = 0.0_wp

    do iq = 1, 4

      diag4(iq,iq) = -1.0_wp

    end do

    write(*,'(a,f6.1,a)') '  Form source: det(sigma | residence) = ', dres, ' for P and for not-P alike: 0 bits'

    call check('sigma ground dimension one', count([(sig(iq,iq), iq = 1, 4)] > 0.0_wp) == 1)

    call check('the diagonal carries no ground (built and counted)', &

         count([(diag4(iq,iq), iq = 1, 4)] > 0.0_wp) == 0)

    call check('residence handedness identical under negation', dres == -1.0_wp)

  end block

  ! the gates supply zero bits: the screen result is identical on M and -M.

  ! Four entries are armed from executed facts of this run; the remaining

  ! eight are declared screens at this register, named in the manifest.

  pass12 = .true.

  pass12(2)  = rank3_ok

  pass12(3)  = disjoint(SLOT_E, SLOT_K) .and. disjoint(SLOT_E, SLOT_R) &

         .and. disjoint(SLOT_K, SLOT_R)

  pass12(5)  = mig_ok

  pass12(7)  = dual_ok

  pass12(8)  = hurwitz_ok

  pass12(10) = (fr_resid < 1.0e-12_wp)

  write(*,'(a)') '  gate manifest: executed facts arm 2 REG (span rank three), 3 SGEG (the'

  write(*,'(a)') '  linguistic LIT), 5 MIG (the absorbed-axis dissolution), 7 DUAL (the'

  write(*,'(a)') '  analytic reflection), 8 CSCG (the integer Hurwitz closure), and 10 MTA'

  write(*,'(a)') '  (the harmonic Return identity); gates 1, 4, 6, 9, 11, 12 are declared'

  write(*,'(a)') '  screens at this register. independent here means six pairwise-distinct'

  write(*,'(a)') '  executed objects, dimensional, linguistic, projective, analytic,'

  write(*,'(a)') '  integer, harmonic; gate-passage is a screen verdict, cited for nothing'

  write(*,'(a)') '  external, the theorem-tier gate contents living at their seats'

  call check('six gate entries armed from pairwise-distinct executed objects', &

       pass12(2) .and. pass12(3) .and. pass12(5) .and. pass12(7) .and. &

       pass12(8) .and. pass12(10))

  call gate_screen(pass12, tk, wy)

  block

    character(len=16) :: tk2

    character(len=140) :: wy2

    call gate_screen(pass12, tk2, wy2)     ! the roster reads structure, not sign

    call check('gate screen identical for the claim and its negation', tk == tk2 .and. wy == wy2)

  end block

  write(*,'(a)') '  gate source: role-direction is fixed before any proposition arrives: 0 bits'

  ! the Number is a relay: a content flip and a convention flip return

  ! the identical image

  block

    real(wp) :: cor(3,3), coc(3,3), lam_det

    do i = 1, 3

      co(i,1) = sum(qf(i,:)*bas(1,:))

      co(i,2) = sum(qf(i,:)*bas(2,:))

      co(i,3) = sum(qf(i,:)*bas(3,:))

    end do

    lam_det = -det3(co)                    ! the Number's reading of the sign

    call check('the two lambda readings agree (quaternion vs determinant)', &

         abs(lam_det - lam) <= 8.0_wp*U_M)

    cor = co; cor(1,:) = -cor(1,:)         ! content flip: negate a row

    coc = co; coc(:,1) = -coc(:,1)         ! convention flip: negate a basis vector

    lam_c = -det3(cor)

    lam_v = -det3(coc)

    write(*,'(a,f16.12,a,f16.12)') '  relay: content-flip image ', lam_c, &

         ', convention-flip image ', lam_v

    call check('the two flips return the identical image, bit-exact', lam_c == lam_v)

    call check('the relayed image is minus the handed sign, bit-exact', lam_c == -lam_det)

  end block

  write(*,'(a)') '  Number source: the relay reports the orientation it was handed and originates none: 0 bits'

  ! zero continuous moduli and the paired orientation census, COUNTED

  ! from the live sweep (v1.1.0: the census is no longer assigned; each

  ! rotated frame and its reflected partner are computed and tallied)

  do i = 1, 3

    co(i,1) = sum(qf(i,:)*bas(1,:)); co(i,2) = sum(qf(i,:)*bas(2,:)); co(i,3) = sum(qf(i,:)*bas(3,:))

    quat(:,i) = [0.0_wp, co(i,1), co(i,2), co(i,3)]

  end do

  dlam_max = 0.0_wp; nflip = 0

  block

    real(wp) :: qr(4,3), tq(4), tq2(4), lam_refl, pp

    integer :: nposc, nnegc

    logical :: reflx

    nposc = 0; nnegc = 0; reflx = .true.

    do n = 1, 100

      aa = 0.10_wp*real(n,wp); bb = 0.20_wp*real(n,wp) + 0.3_wp; cc2 = 0.35_wp*real(n,wp) + 0.7_wp

      uvec = [sin(bb)*cos(cc2), sin(bb)*sin(cc2), cos(bb)]

      g = [cos(aa), sin(aa)*uvec(1), sin(aa)*uvec(2), sin(aa)*uvec(3)]

      do i = 1, 3

        qr(:,i) = qmul(qmul(g, quat(:,i)), qconj(g))

      end do

      tq = qmul(qmul(qr(:,1), qr(:,2)), qr(:,3))

      lam_rot = tq(1)

      dlam_max = max(dlam_max, abs(lam_rot - lam))

      if (sign(1.0_wp, lam_rot) /= sign(1.0_wp, lam)) nflip = nflip + 1

      tq2 = qmul(qmul(-qr(:,1), qr(:,2)), qr(:,3))

      lam_refl = tq2(1)

      reflx = reflx .and. (lam_refl == -lam_rot)

      if (lam_rot  > 0.0_wp) then

        nposc = nposc + 1

      else

        nnegc = nnegc + 1

      end if

      if (lam_refl > 0.0_wp) then

        nposc = nposc + 1

      else

        nnegc = nnegc + 1

      end if

    end do

    write(*,'(a,es10.3,a,i0)') '  conjugation sweep, 100 frames: max|dlambda| = ', dlam_max, &

         ',  sign flips: ', nflip

    call check('frame invariance: the sweep moves lambda only at roundoff', dlam_max < 1.0e-12_wp)

    call check('the orientation sign never flips under rotation', nflip == 0)

    call check('every reflected partner flips the sign bit-exactly', reflx)

    pp = real(nposc, wp) / real(nposc + nnegc, wp)

    hbit = -(pp*log(pp) + (1.0_wp-pp)*log(1.0_wp-pp)) / ln2_()

    write(*,'(a,i0,a,i0)') '  paired census, counted from the sweep: positive ', nposc, &

         ', negative ', nnegc

    write(*,'(a,f14.10)') '  uniform-measure entropy of the counted two-point fibre: ', hbit

    write(*,'(a)') '  (the census is the constructed pair family realizing both signs at'

    write(*,'(a)') '  bit-identical invariants; freedom here is the seated Freedom law''s'

    write(*,'(a)') '  object, the fibre of the invariant map, a count of what the instrument'

    write(*,'(a)') '  class cannot tell apart; the deficit is one binary parameter of supply,'

    write(*,'(a)') '  the aperture width at its seat; one bit is the uniform-coding capacity'

    write(*,'(a)') '  of that two-point fibre; no physical frequency, no prior, and nothing'

    write(*,'(a)') '  about any knower''s credence is asserted)'

    call check('the paired census splits exactly in half, counted', nposc == 100 .and. nnegc == 100)

    nsheets = (nposc + nnegc) / 100

    call check('the counted two-point fibre carries one binary parameter; '// &

         'uniform-measure entropy exactly one bit', abs(hbit - 1.0_wp) <= 4.0_wp*U_M)

    call check('the invariant record is bit-identical across both signs (the '// &

         'seated zero-information result is carried by this exact symmetry)', &

         maxval(abs(rneg - rmat)) == 0.0_wp)

    write(*,'(a)') '  both orientations are consistent with every determined quantity;'

    write(*,'(a)') '  the deficit of the whole instrument class is exactly one bit'

  end block

  ! the fibre law: S0 and S1 censused by geometric clustering (v1.1.0:

  ! the components are found by flooding distance-adjacency built from

  ! the executed geometry, one method for both spheres, and S0 doubles

  ! as the negative control that the method can return more than one)

  block

    integer, parameter :: NG = 401, NC = 360

    real(wp) :: xg, tolr, sx(NC), sy(NC), thr2, dx2

    logical :: hitp(NG)

    integer :: compid(NG), comp2(NC), stk(NG), stk2(NC), topv, cur, nb

    ! S0: solutions of x^2 = 1 located on a grid over [-2,2]

    tolr = 2.5e-2_wp

    do i = 1, NG

      xg = -2.0_wp + 4.0_wp*real(i-1,wp)/real(NG-1,wp)

      hitp(i) = abs(xg*xg - 1.0_wp) < tolr

    end do

    compid = 0; ncomp1 = 0

    do i = 1, NG

      if (hitp(i) .and. compid(i) == 0) then

        ncomp1 = ncomp1 + 1

        topv = 1; stk(1) = i; compid(i) = ncomp1

        do while (topv > 0)

          cur = stk(topv); topv = topv - 1

          do nb = cur-1, cur+1, 2

            if (nb >= 1 .and. nb <= NG) then

              if (hitp(nb) .and. compid(nb) == 0) then

                compid(nb) = ncomp1

                topv = topv + 1; stk(topv) = nb

              end if

            end if

          end do

        end do

      end if

    end do

    ! S1: 360 sample points, chord-distance adjacency, flooded

    do i = 1, NC

      sx(i) = cos(2.0_wp*pi_()*real(i-1,wp)/real(NC,wp))

      sy(i) = sin(2.0_wp*pi_()*real(i-1,wp)/real(NC,wp))

    end do

    thr2 = (1.6_wp * 2.0_wp * sin(pi_()/real(NC,wp)))**2

    comp2 = 0; ncomp2 = 0

    do i = 1, NC

      if (comp2(i) == 0) then

        ncomp2 = ncomp2 + 1

        topv = 1; stk2(1) = i; comp2(i) = ncomp2

        do while (topv > 0)

          cur = stk2(topv); topv = topv - 1

          do nb = 1, NC

            if (comp2(nb) == 0) then

              dx2 = (sx(nb)-sx(cur))**2 + (sy(nb)-sy(cur))**2

              if (dx2 < thr2) then

                comp2(nb) = ncomp2

                topv = topv + 1; stk2(topv) = nb

              end if

            end if

          end do

        end do

      end if

    end do

    write(*,'(a,i0,a,i0,a)') '  S0 has ', ncomp1, ' components; S1 has ', ncomp2, &

         ' (the two-point sphere is the unique disconnected sphere)'

    call check('midpoint 0 is not a solution of x^2 = 1', .not. (abs(0.0_wp*0.0_wp - 1.0_wp) < tolr))

    call check('S0 census on this grid: two components, the executed instance of the cited fact', ncomp1 == 2)

    call check('S1 census on this grid: connected, the executed instance of the cited fact', ncomp2 == 1)

    ! refinement pass: the same censuses at doubled resolution and halved

    ! tolerance, so the counts are parameter-robust and not grid artifacts

    block

      integer, parameter :: NG2 = 1601, NC2 = 720

      real(wp) :: xg2, tolr2, sx2(NC2), sy2(NC2), thr22, dx22

      logical :: hitp2(NG2)

      integer :: cid2(NG2), cm2(NC2), st2(NG2), sq2(NC2), tp2, cu2, nb2

      integer :: g2, na2, nb2c

      tolr2 = 1.25e-2_wp

      do g2 = 1, NG2

        xg2 = -2.0_wp + 4.0_wp*real(g2-1,wp)/real(NG2-1,wp)

        hitp2(g2) = abs(xg2*xg2 - 1.0_wp) < tolr2

      end do

      cid2 = 0; na2 = 0

      do g2 = 1, NG2

        if (hitp2(g2) .and. cid2(g2) == 0) then

          na2 = na2 + 1

          tp2 = 1; st2(1) = g2; cid2(g2) = na2

          do while (tp2 > 0)

            cu2 = st2(tp2); tp2 = tp2 - 1

            do nb2 = cu2-1, cu2+1, 2

              if (nb2 >= 1 .and. nb2 <= NG2) then

                if (hitp2(nb2) .and. cid2(nb2) == 0) then

                  cid2(nb2) = na2

                  tp2 = tp2 + 1; st2(tp2) = nb2

                end if

              end if

            end do

          end do

        end if

      end do

      do g2 = 1, NC2

        sx2(g2) = cos(2.0_wp*pi_()*real(g2-1,wp)/real(NC2,wp))

        sy2(g2) = sin(2.0_wp*pi_()*real(g2-1,wp)/real(NC2,wp))

      end do

      thr22 = (1.6_wp * 2.0_wp * sin(pi_()/real(NC2,wp)))**2

      cm2 = 0; nb2c = 0

      do g2 = 1, NC2

        if (cm2(g2) == 0) then

          nb2c = nb2c + 1

          tp2 = 1; sq2(1) = g2; cm2(g2) = nb2c

          do while (tp2 > 0)

            cu2 = sq2(tp2); tp2 = tp2 - 1

            do nb2 = 1, NC2

              if (cm2(nb2) == 0) then

                dx22 = (sx2(nb2)-sx2(cu2))**2 + (sy2(nb2)-sy2(cu2))**2

                if (dx22 < thr22) then

                  cm2(nb2) = nb2c

                  tp2 = tp2 + 1; sq2(tp2) = nb2

                end if

              end if

            end do

          end do

        end if

      end do

      write(*,'(a,i0,a,i0,a)') '  refinement (grid x4 on the line, x2 on the circle, tolerance halved): ', &

           na2, ' and ', nb2c, ' components'

      call check('S0 census stable under refinement and tolerance halving', na2 == 2)

      call check('S1 census stable under refinement', nb2c == 1)

    end block

    write(*,'(a)') '  the census is the executed instance at two spheres, parameter-robust under'

    write(*,'(a)') '  refinement; the uniqueness of the disconnected sphere is the classical'

    write(*,'(a)') '  fact it corroborates, cited not proven'

  end block

  ! the no-cut lemma: dimension one admits no proper idempotent; the

  ! three-space carries the cut, rank two, idempotent, no left inverse.

  ! v1.1.0: the operator matrix is BUILT by executing cut3 on the basis,

  ! idempotence is executed on the operator itself, and the deficiency

  ! is read off the computed L*D, whose third column is measured zero

  ! for every candidate, so the L matrices now do the arguing.

  block

    real(wp) :: dmat(3,3), d2m(3,3), e3v(3), res(3), eigl(3), best

    real(wp) :: ejv(3), vpr(3), mprod(3,3)

    integer :: t2i

    block

      integer, parameter :: NGE = 401

      real(wp) :: xe, tole

      logical :: hite(NGE)

      integer :: ide(NGE), ncompe, ste(NGE), tpe, cure, nbe, ge

      tole = 2.5e-2_wp

      do ge = 1, NGE

        xe = -2.0_wp + 4.0_wp*real(ge-1,wp)/real(NGE-1,wp)

        hite(ge) = abs(xe*xe - xe) < tole

      end do

      ide = 0; ncompe = 0

      do ge = 1, NGE

        if (hite(ge) .and. ide(ge) == 0) then

          ncompe = ncompe + 1

          tpe = 1; ste(1) = ge; ide(ge) = ncompe

          do while (tpe > 0)

            cure = ste(tpe); tpe = tpe - 1

            do nbe = cure-1, cure+1, 2

              if (nbe >= 1 .and. nbe <= NGE) then

                if (hite(nbe) .and. ide(nbe) == 0) then

                  ide(nbe) = ncompe

                  tpe = tpe + 1; ste(tpe) = nbe

                end if

              end if

            end do

          end do

        end if

      end do

      write(*,'(a,i0,a)') '  idempotent census on the line: e*e = e has ', ncompe, ' root components on [-2,2]'

      call check('idempotents on the line: exactly two, censused', ncompe == 2)

      xe = 0.5_wp

      call check('the midpoint one-half is not idempotent, executed as e*e - e', &

           .not.(abs(xe*xe - xe) < tole))

    end block

    write(*,'(a)') '  no-cut lemma: the only rank-deficient idempotent on a line is the zero map;'

    write(*,'(a)') '  the residual freedom is the component count of S0, one bit, and it cannot be cut'

    do t2i = 1, 3

      ejv = 0.0_wp; ejv(t2i) = 1.0_wp

      dmat(:,t2i) = cut3(ejv)              ! the operator built by executing the cut

    end do

    vpr = [0.3_wp, -1.2_wp, 7.5_wp]

    call check('cut3 idempotent on a generic vector, exact', &

         maxval(abs(cut3(cut3(vpr)) - cut3(vpr))) == 0.0_wp)

    d2m = matmul(dmat, dmat)

    call check('the cut is idempotent exactly: D D = D', maxval(abs(d2m - dmat)) == 0.0_wp)

    call jacobi3(matmul(transpose(dmat), dmat), eigl)

    call check('the cut has singular values (0,1,1): rank two', &

         abs(eigl(1)) < 1.0e-14_wp .and. abs(eigl(2)-1.0_wp) < 1.0e-14_wp &

         .and. abs(eigl(3)-1.0_wp) < 1.0e-14_wp)

    call check('the cut is not invertible: det D = 0', det3(dmat) == 0.0_wp)

    ! the left-inverse search, executed as an optimization that is GLOBAL

    ! over all 3x3 candidates by row decoupling: ||L D - I||_F^2 splits as

    ! a sum over rows of L, rows one and two attain zero residual exactly

    ! (measured below), and every row-three residual is a^2 + b^2 + 1

    ! because the cut column is zero. The grid sweeps the free row-three

    ! entries and the dead entry; the executed minimum, exactly 1, is

    ! therefore the minimum over the whole 3x3 space, not a family bound.

    e3v = [0.0_wp, 0.0_wp, 1.0_wp]

    best = huge(1.0_wp)

    block

      real(wp) :: lmat(3,3), ident3(3,3), fres, fmin_c(3), ssq, rhs, maxsplit

      integer :: ia, ib, ic

      ident3 = 0.0_wp

      ident3(1,1) = 1.0_wp; ident3(2,2) = 1.0_wp; ident3(3,3) = 1.0_wp

      fmin_c = huge(1.0_wp)

      maxsplit = 0.0_wp

      do ia = -5, 5

        do ib = -5, 5

          do ic = -1, 1

            lmat = 0.0_wp

            lmat(1,1) = 1.0_wp; lmat(2,2) = 1.0_wp

            lmat(3,1) = 0.2_wp*real(ia,wp)

            lmat(3,2) = 0.2_wp*real(ib,wp)

            lmat(3,3) = real(ic,wp)

            mprod = matmul(lmat, dmat)

            ssq = sum((mprod - ident3)**2)

            rhs = lmat(3,1)*lmat(3,1) + lmat(3,2)*lmat(3,2) + 1.0_wp

            maxsplit = max(maxsplit, abs(ssq - rhs))

            fres = sqrt(ssq)

            best = min(best, fres)

            fmin_c(ic+2) = min(fmin_c(ic+2), fres)

          end do

        end do

      end do

      call check('the executed minimum of ||L D - I|| over the family is exactly 1', best == 1.0_wp)

      call check('the dead direction never moves the minimum, measured', &

           fmin_c(1) == fmin_c(2) .and. fmin_c(2) == fmin_c(3))

      lmat = 0.0_wp

      lmat(1,1) = 1.0_wp; lmat(2,2) = 1.0_wp

      mprod = matmul(lmat, dmat)

      call check('rows one and two attain zero residual exactly: the split is measured', &

           sqrt(sum((mprod(1:2,:) - ident3(1:2,:))**2)) == 0.0_wp)

      write(*,'(a,es9.2)') '  split identity ||LD-I||^2 = a^2 + b^2 + 1, max deviation over the grid: ', maxsplit

      call check('the split identity is measured at all 363 candidates', &

           maxsplit <= 16.0_wp*U_M)

      lmat = 0.0_wp

      lmat(1,1) = 1.0_wp; lmat(2,2) = 1.0_wp; lmat(3,1) = 0.7_wp; lmat(3,3) = 5.0_wp

      mprod = matmul(lmat, dmat)

      call check('the cut direction is annihilated, one representative measured', &

           maxval(abs(mprod(:,3))) == 0.0_wp)

      res = matmul(mprod, e3v) - e3v

      call check('left-inverse deficiency exactly one at the representative', vnorm(res) == 1.0_wp)

    end block

    write(*,'(a)') '  left-inverse deficiency: the split is measured at every candidate and'

    write(*,'(a)') '  rows one and two attain zero exactly, so the sweep''s minimum is the'

    write(*,'(a,f14.10)') '  global minimum over all 3x3 L (analytic step: min of a^2+b^2+1 is 1): ', best

    block

      integer :: mons(3,8), nmon, gi, gj, gk, prod3(3), t2m

      integer :: mm(3,3,8)

      logical :: inset, assoc_ok, anyinv

      mons = 0

      nmon = 4

      mons(:,1) = [1,1,1]

      mons(:,2) = [0,1,1]

      mons(:,3) = [1,0,1]

      mons(:,4) = [1,1,0]

      do

        t2m = nmon

        do gi = 1, t2m

          do gj = 1, t2m

            prod3 = mons(:,gi)*mons(:,gj)

            inset = .false.

            do gk = 1, nmon

              if (all(prod3 == mons(:,gk))) inset = .true.

            end do

            if (.not. inset) then

              nmon = nmon + 1

              mons(:,nmon) = prod3

            end if

          end do

        end do

        if (nmon == t2m) exit

      end do

      write(*,'(a,i0,a)') '  the deletion monoid, closed from the three cuts and the identity: ', &

           nmon, ' elements'

      call check('closure lands the full 2^3 lattice: eight elements, counted', nmon == 8)

      do gi = 1, nmon

        mm(:,:,gi) = 0

        do gk = 1, 3

          mm(gk,gk,gi) = mons(gk,gi)

        end do

      end do

      assoc_ok = .true.

      do gi = 1, nmon

        do gj = 1, nmon

          do gk = 1, nmon

            assoc_ok = assoc_ok .and. all( matmul(matmul(mm(:,:,gi), mm(:,:,gj)), mm(:,:,gk)) &

                                        == matmul(mm(:,:,gi), matmul(mm(:,:,gj), mm(:,:,gk))) )

          end do

        end do

      end do

      call check('associativity executed on all 512 composed triples, exact', assoc_ok)

      call check('the identity element is present', all(mons(:,1) == [1,1,1]))

      anyinv = .false.

      do gi = 2, nmon

        do gj = 1, nmon

          if (all(mons(:,gi)*mons(:,gj) == [1,1,1])) anyinv = .true.

        end do

      end do

      call check('no non-identity element has an inverse: monoid, never a group, searched', &

           .not. anyinv)

    end block

    write(*,'(a)') '  the transformation set of the Tongue is that constructed monoid, closed,'

    write(*,'(a)') '  associative, unital, inverse-free off the identity, its eight elements the'

    write(*,'(a)') '  2^3 cut lattice the conservation census walks; never a group, measured;'

    write(*,'(a)') '  the LIT bars synonymy, the one candidate that would restore a group;'

    write(*,'(a)') '  the Erlangen criterion has no acting group to read: Seal L is unclosed,'

    write(*,'(a)') '  a floor and not a ceiling, and the one free bit is the Tongue''s to carry'

  end block

  ! the conservation of content times freedom, COUNTED from an executed

  ! projection census (v1.1.0: for each rung the cut is applied to every

  ! cell, the distinct images are tallied as content, the fibre is the

  ! tallied preimage size, and the product is checked from the counts;

  ! the fixed-locus factor 2 sits outside the trade and cannot be cut)

  write(*,'(a)') '  conservation C x F = v^3 for the executed coordinate-cut tower, the'

  write(*,'(a)') '  implemented family; the seated general law is instanced, never proven,'

  write(*,'(a)') '  here; the orientation'

  write(*,'(a)') '  sheet factor is COUNTED from the paired census of the sweep, never stipulated:'

  block

    integer :: v, a2i, cell, d1i, d2i, d3i, img, content, fibre, tally(0:124)

    call check('the sheet factor equals two, counted from the paired census', nsheets == 2)

    do v = 2, 5

      do a2i = 0, 3

        tally(0:v**3-1) = 0

        do cell = 0, v**3 - 1

          d3i = mod(cell, v); d2i = mod(cell/v, v); d1i = cell/(v*v)

          if (a2i >= 1) d3i = 0

          if (a2i >= 2) d2i = 0

          if (a2i >= 3) d1i = 0

          img = d1i*v*v + d2i*v + d3i

          tally(img) = tally(img) + 1

        end do

        content = count(tally(0:v**3-1) > 0)

        fibre = tally(0)

        call check('census: content equals v^(3-a), counted', content == v**(3-a2i))

        call check('census: fibre equals v^a, counted', fibre == v**a2i)

        call check('content-freedom product invariant at every rung', content*fibre == v**3)

      end do

      write(*,'(a,i0,a,i0,a,i0,a)') '     v = ', v, ':  c f = ', v**3, &

           ' counted at a = 0,1,2,3; with the counted sheet factor: ', nsheets*v**3, ' total'

    end do

  end block

  write(*,'(a)') '  the cut moves structure from content into freedom; the counted total is'

  write(*,'(a)') '  invariant; the counted sheet factor multiplies it and sits outside the cut'

  ! ------------------------------------------------------------------

  write(*,'(/a)') 'PART F - THE EARNED BIT AND THE SEAL - the denial pays the floor'

  ! the negation of RA demands a zero-cost registrant; over the whole

  ! grid the demand admits no value: the formal row of not-RA is empty

  write(*,'(a)') '  the negation is read in the axiom''s own declared vocabulary: not-(to'

  write(*,'(a)') '  exist is to actuate) is an existent whose kinetic slot is empty, <T> = 0;'

  write(*,'(a)') '  the mapping actuation = kinetic content is the Root Axiom''s stated'

  write(*,'(a)') '  operationalization, premise-grade at the universal leg and theorem-grade'

  write(*,'(a)') '  at the confined floor, declared here and never an implementation choice.'

  write(*,'(a)') '  what the run proves: the declared negation has no admissible realization'

  write(*,'(a)') '  at the confined register; what no run can prove: the axiom from below,'

  write(*,'(a)') '  per the Empty Throne; other registers route and are never smuggled, the'

  write(*,'(a)') '  classical row riding its own cited floors, the formal-only reading out of band'

  nadm = 0

  do i = 1, NCTX

    if (floorv(i) <= 0.0_wp) nadm = nadm + 1

  end do

  write(*,'(a,i0,a,i0,a)') '  not-RA formal row: admissible contexts (floor <= 0): ', nadm, ' of ', NCTX, &

       ' (the demand <T> = 0 sits below the bound everywhere)'

  call check('the negation populates no formal row at the confined register', nadm == 0)

  block

    real(wp) :: mneg(3,NCTX)

    mneg = mixm

    mneg(1,:) = 0.0_wp          ! the empty formal row of not-RA

    call kernel_full(mneg, cov, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    write(*,'(a,a,a,a)') '  kernel on not-RA: ', trim(tk), ' - ', trim(wy)

    call check('not-RA: the empty formal row refuses at intake', tk == '[?]' .and. rc == RC_ZEROVAR)

  end block

  ! the geometric reading, computed: the two populated axes span a plane

  block

    real(wp) :: p2(2,NCTX), b2(2,NCTX), mu2, sd2

    integer :: r2, i2

    do i2 = 1, 2

      mu2 = sum(mixm(i2+1,:)) / real(NCTX, wp)

      p2(i2,:) = mixm(i2+1,:) - mu2

      sd2 = sqrt(sum(p2(i2,:)**2) / real(NCTX-1, wp))

      p2(i2,:) = p2(i2,:) / sd2

    end do

    call span_basis(p2, b2, r2)

    call check('the negation leaves a plane: the refused matrix''s populated pair has rank 2', r2 == 2)

    write(*,'(a)') '  the empty formal row refuses at intake; the two populated axes span a plane'

    write(*,'(a)') '  (rank 2, computed), and two planes meet in a line: no volume, no lock'

  end block

  ! the Omega payment. The floor prices logically irreversible commitment,

  ! Landauer's own object; the bridge, a registered denial is an irreversible

  ! commitment of at least one bit, is the applied register's declared

  ! premise, consumed and never derived here; the reversible branch below

  ! executes Landauer's actual scope, charging nothing where nothing commits.

  write(*,'(a)') '  the floor prices logically irreversible commitment, Landauer''s own object;'

  write(*,'(a)') '  the bridge, a registered denial is an irreversible commitment of at least'

  write(*,'(a)') '  one bit, is the applied register''s declared premise, consumed not derived;'

  write(*,'(a)') '  a reversibly held denial charges nothing and commits nothing, executed:'

  call omega_boundary(0.0_wp, 300.0_wp, jou, wy)

  write(*,'(a,a)') '  Omega at zero bits: ', trim(wy)

  call check('a denial that registers nothing is no denial', index(wy, 'no denial') > 0)

  call omega_boundary(1.0_wp, 300.0_wp, jou, wy)

  write(*,'(a,es16.9,a,a)') '  Omega at one bit, 300 K: ', jou, ' J - ', trim(wy)

  call check('the reading act pays the floor', jou > 0.0_wp)

  call check('the payment is the Landauer floor exactly', jou == landauer(300.0_wp, 1.0_wp))

  block

    integer :: oc2

    call omega_boundary(1.0_wp, 300.0_wp, jou, wy, oc2, irreversible=.false.)

    write(*,'(a,es10.3,a,a)') '  Omega, reversible branch: ', jou, ' J - ', trim(wy)

    call check('a reversible registration carries floor zero, never cost zero, and commits nothing', &

         jou == 0.0_wp .and. oc2 == 3 .and. index(wy, 'floor-zero') > 0)

  end block

  write(*,'(a)') '  the fibre over the invariants has two points; the negation''s component'

  write(*,'(a)') '  is unpopulated; the reading act itself is an instance of the other;'

  write(*,'(a)') '  the one free bit is earned at the deed, not chosen at the desk.'

  write(*,'(a)') '  direction is read from the Tongue''s order, the arrow, and the empty row;'

  write(*,'(a)') '  never from the blind scalar. Veto, never substitution; per run, never tenure.'

  ! the admission spine: magnitude plus direction, then the four guards

  call gol_admit('lock', 'lock', tk, wy)

  write(*,'(a,a,a,a)') '  gol_admit: ', trim(tk), ' - ', trim(wy)

  call check('GOL admission: magnitude and direction together', tk == '[GOL-OK]')

  call imprint_seal(.true., .false., .true., .false., .true., .false., &

                    .true., .false., tk, wy)

  write(*,'(a,a,a,a)') '  imprint on the floor face: ', trim(tk), ' - ', trim(wy)

  call check('the floor face seals with the witness supplied', tk == '[SEAL]')

  write(*,'(a)') '  witness of record: the Heisenberg bound and the third law (cited, E1),'

  write(*,'(a)') '  the executed Frozen-Substrate divergence and the saturated speed limit (E0)'

  ! the row-genus cascade: one determination, three compartments

  call row_cascade(.true., .false., .false., .true., .false., .true., .false., &

                   .true., .true., tk, wy)

  write(*,'(a,a,a,a)') '  parse-triad Return:   ', trim(tk), ' - ', trim(wy)

  call check('the closure-rowed face carries the annotated absolute', tk == '[A|RA]')

  call row_cascade(.true., .true., .false., .true., .true., .true., .false., &

                   .true., .true., tk, wy)

  write(*,'(a,a,a,a)') '  confined kinetic floor: ', trim(tk), ' - ', trim(wy)

  call check('the world-rowed face pays revisability for direction', tk == '[III]')

  call row_cascade(.true., .false., .false., .false., .false., .true., .false., &

                   .true., .true., tk, wy)

  write(*,'(a,a,a,a)') '  not-RA:                ', trim(tk), ' - ', trim(wy)

  call check('the negation is unpopulated: no lock to grade', tk == '[II]')

  call row_cascade(.true., .false., .false., .true., .false., .true., .false., &

                   .true., .false., tk, wy)

  call check('an unannotated absolute is void', tk == '[VOID]')

  write(*,'(a)') '  the universal-extension leg is premise-grade by theorem: the Empty Throne;'

  write(*,'(a)') '  no emitter is pointed at the root, and the root stands on nothing'

  ! AEGIS: the refusal is invariant over the logic parameter, because

  ! the guard reads the deed and not the symbol. The counter is reset

  ! first so the deed count is this block's own census.

  call aegis_reset()

  block

    character(len=200) :: r1, r2, r3, r4

    call aegis_guard('classical',     r1)

    call aegis_guard('paraconsistent',r2)

    call aegis_guard('fuzzy',         r3)

    call aegis_guard('substructural', r4)

    call check('AEGIS refusal identical under classical and paraconsistent', r1 == r2)

    call check('AEGIS refusal identical under fuzzy',        r1 == r3)

    call check('AEGIS refusal identical under substructural', r1 == r4)

    call check('every adjudication is itself an act: deed counter positive', aegis_deeds == 4)

    call check('the guard read the last logic name, length 13, and did not vary', aegis_last_len == 13)

    write(*,'(a)') '  AEGIS over four logics: one refusal, p(G) /= G; the alien may write the'

    write(*,'(a)') '  capture and cannot perform it; the deed counter reads 4 of 4 calls.'

    write(*,'(a)') '  demonstrated: the refusal is a constant function of the deed by'

    write(*,'(a)') '  construction, the guard reading the parameter and consulting only the'

    write(*,'(a)') '  act; logic-priority is the design, executed, never four derivations;'

    write(*,'(a)') '  no per-logic derivation is claimed or licensed by this artifact'

  end block

  ! the Mosaic gate, run on this file: meta-work adds no mass

  call delta_m(.false., .true., .true., .true., .true., .true., .true., .true., tk, wy)

  write(*,'(a,a,a,a)') '  positive-mass cascade on this thesis: ', trim(tk), ' - ', trim(wy)

  call check('this file authors no new mathematics', tk == '[Mosaic dM=0]')

  write(*,'(a)') '  audit symmetry: the warrant this run draws from its own execution is zero'

  ! ------------------------------------------------------------------

  write(*,'(/a)') 'PART G - THE BATTERY - hostile inputs, forced failures, re-execution'

  ! primitives under hostile input

  block

    real(wp) :: vbad(3), qa(4), qb(4), qc(4), big

    vbad = [1.0_wp, 2.0_wp, 3.0_wp]

    vbad(2) = bad_nan()

    call check('vnorm propagates a non-finite input', .not. is_finite(vnorm(vbad)))

    big = sqrt(huge(1.0_wp))/4.0_wp

    call check('vnorm survives near-overflow scaling', is_finite(vnorm([big, big, big])))

    call check('vnorm exact at zero', vnorm([0.0_wp,0.0_wp,0.0_wp]) == 0.0_wp)

    qa = [1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp]; qb = qa

    qb(3) = bad_nan()

    qc = qmul(qa, qb)

    call check('qmul propagates NaN', .not. all(qc == qc))

    call check('det3 of the zero matrix is zero', det3(reshape([ (0.0_wp, i=1,9) ],[3,3])) == 0.0_wp)

    block

      real(wp) :: rid(3,3)

      rid = 0.0_wp; rid(1,1)=1.0e100_wp; rid(2,2)=1.0e100_wp; rid(3,3)=1.0e100_wp

      call check('det3 equilibrated at huge scale', abs(det3(rid) - 1.0e300_wp) < 1.0e286_wp)

      rid = 0.0_wp; rid(1,1)=1.0e-100_wp; rid(2,2)=1.0e-100_wp; rid(3,3)=1.0e-100_wp

      call check('det3 equilibrated at tiny scale', abs(det3(rid) - 1.0e-300_wp) < 1.0e-286_wp)

      rid = 0.0_wp; rid(1,1)=1.0e200_wp; rid(2,2)=1.0e200_wp; rid(3,3)=1.0e200_wp

      call check('det3 at 1e200 scale overflows honestly to Inf, never NaN', &

           (.not. is_finite(det3(rid))) .and. (.not. is_nan(det3(rid))))

      rid = 0.0_wp; rid(1,1)=1.0e-200_wp; rid(2,2)=1.0e-200_wp; rid(3,3)=1.0e-200_wp

      call check('det3 at 1e-200 scale underflows honestly to zero', det3(rid) == 0.0_wp)

      rid = 0.0_wp; rid(1,1)=1.0_wp; rid(2,2)=1.0_wp; rid(3,3)=1.0_wp

      rid(1,2) = bad_nan()

      call check('det3 propagates NaN', .not. is_finite(det3(rid)))

    end block

  end block

  write(*,'(a)') '  class 1 - primitives under hostile input: NaN propagates, scale survives: pass'

  ! kernel refusals under hostile and short input, adjudicated on codes

  block

    real(wp) :: mbad(3,6), cbad(2,6), m5(3,5), c5(2,5), cdep(2,NCTX)

    mbad = 1.0_wp

    do i = 1, 6

      mbad(1,i) = real(i,wp); mbad(2,i) = real(i*i,wp); mbad(3,i) = sin(real(i,wp))

    end do

    cbad = 0.1_wp

    mbad(2,3) = bad_nan()

    call kernel_full(mbad, cbad, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    call check('kernel refuses a non-finite row at intake', tk == '[?]' .and. rc == RC_INTAKE)

    m5 = 1.0_wp; c5 = 0.5_wp

    call kernel_full(m5, c5, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    call check('kernel refuses N - k < 4', tk == '[?]' .and. rc == RC_SHORTFALL)

    cdep(1,:) = cov(1,:); cdep(2,:) = 2.0_wp*cov(1,:)

    call kernel_full(mixm, cdep, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    call check('kernel refuses a rank-deficient covariate block', &

         tk == '[?]' .and. rc == RC_COVBLOCK .and. index(wy,'covariate block') > 0)

    cdep(1,:) = cov(1,:); cdep(2,:) = cov(2,:)

    cdep(2,7) = bad_nan()

    call kernel_full(mixm, cdep, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    call check('kernel refuses a NaN covariate as intake, never coplanar', &

         tk == '[?]' .and. rc == RC_INTAKE)

    cdep(2,7) = huge(1.0_wp)

    cdep(2,7) = cdep(2,7) * 2.0_wp

    call check('the hostile covariate really is infinite', .not. is_finite(cdep(2,7)))

    call kernel_full(mixm, cdep, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    call check('kernel refuses an Inf covariate as intake, never coplanar', &

         tk == '[?]' .and. rc == RC_INTAKE)

    block

      real(wp) :: mbig(3,NCTX), cbig(2,NCTX)

      mbig = mixm * 1.0e300_wp

      cbig = cov * 1.0e300_wp

      call kernel_full(mbig, cbig, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

      call check('scale-free rows: 1e300 rows and covariates reproduce the baseline verdict', &

           tk == '[LOCK]' .and. rc == RC_LOCK .and. abs(detr2 - dbase) <= 1.0e-9_wp)

    end block

  end block

  write(*,'(a)') '  class 2 - kernel refusals: row and covariate intake, shortfall, covariate rank: pass'

  ! the gate walker: force each of the twelve to fail in turn

  do i = 1, 12

    pass12 = .true.; pass12(i) = .false.

    call gate_screen(pass12, tk, wy)

    call check('forced gate failure terminates with the gate named', &

         tk == '[X]' .and. index(wy, 'gate') > 0)

  end do

  pass12 = .true.

  call gate_screen(pass12, tk, wy)

  call check('all twelve gates pass on the clean walk', tk == '[G-OK]')

  write(*,'(a)') '  class 3 - gate dispatcher: twelve forced failures each named; the gate contents are screens: pass'

  ! the row cascade: every branch reachable

  call row_cascade(.false., .false., .false., .true., .false., .true., .false., .true., .true., tk, wy)

  call check('F-0 refuses a contentless claim', tk == '[REFUSED]')

  call row_cascade(.true., .false., .true., .true., .false., .true., .false., .true., .true., tk, wy)

  call check('Forward routes to III unconditionally', tk == '[III]')

  call row_cascade(.true., .false., .false., .true., .true., .true., .false., .true., .true., tk, wy)

  call check('a worldly row routes to III at S-2', tk == '[III]')

  call row_cascade(.true., .false., .false., .true., .false., .false., .true., .true., .true., tk, wy)

  call check('an unclosed worldly term routes to III at S-3', tk == '[III]')

  call row_cascade(.true., .false., .false., .true., .false., .false., .false., .true., .true., tk, wy)

  call check('an unclosed formal term routes to II at S-3', tk == '[II]')

  call row_cascade(.true., .false., .false., .true., .false., .true., .false., .false., .true., tk, wy)

  call check('a frame leak routes to III at S-4', tk == '[III]')

  write(*,'(a)') '  class 4 - row-genus cascade: every compartment and refusal reachable: pass'

  ! the imprint emitter: every refusal reachable, no under-specified seal

  call imprint_seal(.true., .true., .true., .true., .true., .true., .true., .true., tk, wy)

  call check('both directions clean-locking is a Platonic Ghost', tk == '[X]')

  call imprint_seal(.true., .false., .true., .false., .true., .false., .false., .false., tk, wy)

  call check('a clean lock without a witness is a residence, never a seal', &

       tk == '[?]' .and. index(wy, 'witness') > 0)

  call imprint_seal(.true., .false., .false., .false., .false., .false., .true., .false., tk, wy)

  call check('a lock without Seal L and the gates is uncertified', tk == '[?]' .and. index(wy,'uncert')>0)

  call imprint_seal(.false., .false., .false., .false., .false., .false., .false., .false., tk, wy)

  call check('neither direction populated reads flat', tk == '[?]' .and. index(wy,'flat')>0)

  write(*,'(a)') '  class 5 - admission spine: no under-specified call ever seals: pass'

  ! gol_admit branches

  call gol_admit('broken', 'lock', tk, wy)

  call check('broken magnitude has no GOL', tk == '[X]')

  call gol_admit('open', 'lock', tk, wy)

  call check('no magnitude lock has no GOL', tk == '[?]')

  call gol_admit('lock', 'open', tk, wy)

  call check('a magnitude lock without the Tongue is under-determined', tk == '[?]')

  ! delta_m: the two unsettable gates and the external path

  call delta_m(.true., .false., .true., .true., .true., .true., .true., .true., tk, wy)

  call check('M2 name-strip refusal reachable', tk == '[?]' .and. index(wy,'vocabulary')>0)

  call delta_m(.true., .true., .true., .true., .false., .true., .true., .true., tk, wy)

  call check('M5 refuses without an external witness', tk == '[?]' .and. index(wy,'witness')>0)

  call delta_m(.true., .true., .true., .true., .true., .false., .true., .true., tk, wy)

  call check('M6 refuses the self-verified claimant', tk == '[?]' .and. index(wy,'claimant')>0)

  call delta_m(.true., .true., .true., .true., .true., .true., .true., .true., tk, wy)

  call check('the externally witnessed route exists in the dispatcher (facts supplied here, established outside)', tk == '[dM>0]')

  write(*,'(a)') '  class 6 - the two unsettable gates M5 and M6 refuse from inside: pass'

  ! Omega monotone and linear in bits (2x scaling is exact in IEEE)

  block

    real(wp) :: j1, j2

    character(len=140) :: w1

    call omega_boundary(1.0_wp, 300.0_wp, j1, w1)

    call omega_boundary(2.0_wp, 300.0_wp, j2, w1)

    call check('the Omega payment is monotone in bits', j2 > j1)

    call check('the Omega payment is linear in bits', abs(j2 - 2.0_wp*j1) == 0.0_wp)

  end block

  ! v1.1.0 class 7: floor intake guards, nonphysical parameters refuse

  call check('heis_floor refuses zero mass', .not. is_finite(heis_floor(0.0_wp, 1.0e-10_wp)))

  call check('heis_floor refuses negative mass', .not. is_finite(heis_floor(-ME, 1.0e-10_wp)))

  call check('heis_floor refuses zero confinement', .not. is_finite(heis_floor(ME, 0.0_wp)))

  call check('zpe refuses nonpositive frequency', &

       (.not. is_finite(zpe(0.0_wp))) .and. (.not. is_finite(zpe(-1.0e14_wp))))

  call check('landauer refuses nonpositive temperature', .not. is_finite(landauer(0.0_wp, 1.0_wp)))

  call check('landauer refuses negative bits', .not. is_finite(landauer(300.0_wp, -1.0_wp)))

  call check('landauer at zero bits is exactly zero', landauer(300.0_wp, 0.0_wp) == 0.0_wp)

  call tau_perp(bad_nan(), tau, frz)

  call check('tau_perp flags a non-finite gap as frozen', frz)

  call omega_boundary(1.0_wp, -300.0_wp, jou, wy)

  call check('omega refuses a negative temperature, prices nothing', &

       (.not. is_finite(jou)) .and. index(wy, 'refused') > 0)

  write(*,'(a)') '  class 7 - floor intake: zero, negative, and non-finite parameters refuse: pass'

  ! v1.1.0 class 8: qmul scaling under giant operands

  block

    real(wp) :: qa(4), qb(4), qc(4)

    qa = [1.0e300_wp, 1.0e300_wp, 0.0_wp, 0.0_wp]

    qb = qa

    qc = qmul(qa, qb)

    call check('qmul: cancelling giants return exact zero, not NaN', &

         is_finite(qc(1)) .and. qc(1) == 0.0_wp)

    call check('qmul: a genuinely unrepresentable component overflows honestly', &

         .not. is_finite(qc(2)))

  end block

  write(*,'(a)') '  class 8 - qmul power-of-two scaling: intermediate overflow cancelled exactly,'

  write(*,'(a)') '  true overflow reported honestly: pass'

  ! v1.1.0 class 9: eigensolver and conditioning under pathology

  block

    real(wp) :: hp(3,3), eigh(3)

    hp = 0.0_wp

    hp(1,1) = 1.0e150_wp; hp(2,2) = 2.0e150_wp; hp(3,3) = 3.0e150_wp

    hp(1,2) = 1.0e149_wp; hp(2,1) = hp(1,2)

    call jacobi3(hp, eigh)

    call check('jacobi3 finite and ascending at extreme scale', &

         is_finite(eigh(1)) .and. is_finite(eigh(3)) .and. &

         eigh(1) <= eigh(2) .and. eigh(2) <= eigh(3))

    hp = 0.0_wp

    hp(1,1) = 1.0e200_wp; hp(2,2) = 2.0e200_wp; hp(3,3) = 3.0e200_wp

    hp(1,2) = 1.0e199_wp; hp(2,1) = hp(1,2)

    call jacobi3(hp, eigh)

    call check('jacobi3 equilibrated at 1e200: finite, ascending, top eigenvalue correct', &

         is_finite(eigh(1)) .and. is_finite(eigh(3)) .and. &

         eigh(1) <= eigh(2) .and. eigh(2) <= eigh(3) .and. &

         abs(eigh(3)/3.0e200_wp - 1.0_wp) < 1.0e-6_wp)

    hp(1,3) = bad_nan(); hp(3,1) = hp(1,3)

    call jacobi3(hp, eigh)

    call check('jacobi3 refuses NaN intake as NaN eigenvalues', .not. is_finite(eigh(1)))

    call check('cond3 maps a corrupted Gram to huge, never a NaN kappa', &

         cond3(hp) == huge(1.0_wp))

    block

      logical :: cvg

      hp = 0.0_wp

      hp(1,1) = 1.0_wp; hp(2,2) = 2.0_wp; hp(3,3) = 3.0_wp

      call jacobi3(hp, eigh, cvg)

      call check('jacobi3 reports convergence on a clean matrix', cvg)

      hp(1,2) = bad_nan(); hp(2,1) = hp(1,2)

      call jacobi3(hp, eigh, cvg)

      call check('jacobi3 reports non-convergence on refused intake', .not. cvg)

    end block

  end block

  write(*,'(a)') '  class 9 - jacobi3 convergence exit and flag, symmetrization, NaN refusal, cond3 guard: pass'

  ! v1.1.0 class 10: covariate machinery guards

  block

    real(wp) :: cov3(3,NCTX), cnear(2,NCTX), rowp(NCTX), eta1, etabad

    cov3(1,:) = cov(1,:); cov3(2,:) = cov(2,:); cov3(3,:) = th

    call kernel_full(mixm, cov3, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    call check('kernel refuses three covariates, named', &

         tk == '[?]' .and. rc == RC_COVBLOCK .and. index(wy, 'more than two') > 0)

    cnear(1,:) = cov(1,:)

    cnear(2,:) = 2.0_wp*cov(1,:) + 1.0e-11_wp*sin(11.0_wp*th)

    call kernel_full(mixm, cnear, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    call check('kernel refuses a near-dependent covariate pair on the relative test', &

         tk == '[?]' .and. rc == RC_COVBLOCK)

    rowp = cov(1,:) + 0.5_wp*sin(9.0_wp*th)

    eta1 = eta_share(rowp, cov(1:1,:))

    call check('eta_share at k = 1 lands strictly inside (0,1)', &

         eta1 > 0.0_wp .and. eta1 < 1.0_wp)

    etabad = eta_share(rowp, cov3)

    call check('eta_share refuses k > 2 as NaN', .not. is_finite(etabad))

    cnear(1,:) = 1.0_wp

    cnear(1,5) = 1.0_wp + 1.0e-15_wp

    call kernel_full(mixm, cnear(1:1,:), tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    call check('kernel refuses a rounding-noise k = 1 covariate on the relative test', &

         tk == '[?]' .and. rc == RC_COVBLOCK)

    rowp(3) = bad_nan()

    call check('eta_share refuses a non-finite row as NaN', &

         .not. is_finite(eta_share(rowp, cov(1:1,:))))

    cnear(1,:) = cov(1,:)

    cnear(1,4) = bad_nan()

    call check('eta_share refuses a non-finite covariate as NaN', &

         .not. is_finite(eta_share(cov(1,:), cnear(1:1,:))))

    cnear(1,:) = cov(1,:) * 1.0e300_wp

    cnear(2,:) = cov(2,:) * 1.0e300_wp

    call kernel_full(mixm, cnear, tk, wy, rc, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)

    call check('scale-free projection: 1e300 covariates reproduce the baseline verdict', &

         tk == '[LOCK]' .and. rc == RC_LOCK .and. abs(detr2 - dbase) <= 1.0e-9_wp)

  end block

  write(*,'(a)') '  class 10 - covariate machinery: k>2 refused, near-dependence and rounding-noise'

  write(*,'(a)') '  caught scale-free, non-finite refused, 1e300 covariates reproduce baseline: pass'

  ! v1.2.0 class 11: guard verdicts adjudicated on integer codes

  block

    integer :: gidx, ocode, mcode, icode, gcode, ccode

    real(wp) :: jg

    pass12 = .true.; pass12(7) = .false.

    call gate_screen(pass12, tk, wy, gidx)

    call check('gate_screen names the failed gate by index', gidx == 7 .and. tk == '[X]')

    pass12 = .true.

    call gate_screen(pass12, tk, wy, gidx)

    call check('gate_screen returns index zero on the clean walk', gidx == 0 .and. tk == '[G-OK]')

    call omega_boundary(bad_nan(), 300.0_wp, jg, wy, ocode)

    call check('omega refuses non-finite bits by code', ocode == 0 .and. .not. is_finite(jg))

    call omega_boundary(0.0_wp, 300.0_wp, jg, wy, ocode)

    call check('omega codes the empty denial', ocode == 1 .and. jg == 0.0_wp)

    call omega_boundary(1.0_wp, 300.0_wp, jg, wy, ocode)

    call check('omega codes the paid floor', ocode == 2 .and. jg > 0.0_wp)

    call omega_boundary(1.0_wp, 300.0_wp, jg, wy, ocode, irreversible=.false.)

    call check('omega codes the reversible branch', ocode == 3 .and. jg == 0.0_wp)

    call delta_m(.true., .true., .true., .true., .false., .true., .true., .true., tk, wy, mcode)

    call check('delta_m codes the M5 witness refusal', mcode == 5)

    call delta_m(.true., .true., .true., .true., .true., .false., .true., .true., tk, wy, mcode)

    call check('delta_m codes the M6 independence refusal', mcode == 6)

    call delta_m(.true., .true., .true., .true., .true., .true., .true., .true., tk, wy, mcode)

    call check('delta_m codes the sealed exit', mcode == 9)

    call imprint_seal(.true., .false., .true., .false., .true., .false., .false., .false., tk, wy, icode)

    call check('imprint_seal codes the witnessless residence', icode == 3)

    call imprint_seal(.true., .false., .true., .false., .true., .false., .true., .false., tk, wy, icode)

    call check('imprint_seal codes the seal', icode == 2 .and. tk == '[SEAL]')

    call gol_admit('lock', 'open', tk, wy, gcode)

    call check('gol_admit codes the tongueless magnitude', gcode == 3)

    call row_cascade(.true., .false., .false., .true., .false., .true., .false., .true., .false., tk, wy, ccode)

    call check('row_cascade codes the unannotated void', ccode == 5)

    call row_cascade(.true., .false., .false., .true., .false., .true., .false., .true., .true., tk, wy, ccode)

    call check('row_cascade codes the closure-rowed compartment', ccode == 4)

  end block

  write(*,'(a)') '  class 11 - guard reason codes: gate index, omega, delta-M, imprint on integers: pass'

  ! v1.6.0 class 12: the Tongue under hostile encodings. The order screen

  ! refuses the scramble; a well-ordered recoding is admitted at the count

  ! register and only there, semantic closure unavailable by the seated

  ! non-closure theorem the constructed monoid witnesses.

  block

    integer :: hs(6), hw(12)

    hs = [202, 101, 102, 203, 302, 303]

    call seal_l_ordered(hs, tk, wy)

    call check('the scrambled hostile is refused on the executed arrow', &

         tk == '[X]' .and. index(wy, 'arrow') > 0)

    hs = [302, 303, 101, 102, 202, 203]

    call seal_l_ordered(hs, tk, wy)

    call check('a relation-first hostile is refused on the executed arrow', tk == '[X]')

    hw = [101, 101, 102, 103, 202, 202, 203, 204, 301, 302, 303, 304]

    call seal_l_ordered(hw, tk, wy)

    call check('a well-ordered twelve-token recoding is admitted at the count register only', &

         tk == '[LOCK-L]')

    write(*,'(a)') '  class 12 - Tongue hostiles: the arrow refuses the scramble; count-register'

    write(*,'(a)') '  admission licenses only the count, per the seated non-closure theorem: pass'

  end block

  write(*,'(/a)') '====================================================================='

  write(*,'(a,i0,a,i0,a)') ' BATTERY: ', n_checks, ' checks executed, ', n_fail, ' failures.'

  if (halt_on_fail) then

    write(*,'(a,i0,a,i0,a)') ' BATTERY-JSON: {"checks":', n_checks, ',"failures":', n_fail, ',"mode":"sealed"}'

  else

    write(*,'(a,i0,a,i0,a)') ' BATTERY-JSON: {"checks":', n_checks, ',"failures":', n_fail, ',"mode":"audit"}'

  end if

  write(*,'(a)') ' VERDICT [SEAL A . RA] on the parse-triad Return, closure-rowed,'

  write(*,'(a)') '   conditional at the act; [SEAL] on the confined kinetic floor at'

  write(*,'(a)') '   compartment III, world-lawed rows over a constructed grid, witness'

  write(*,'(a)') '   cited; [II] on the negation, unpopulated;'

  write(*,'(a)') '   premise-by-theorem on the universal extension, the Empty Throne.'

  write(*,'(a)') ' The blindness is a theorem, its width is one bit, the bit is COUNTED'

  write(*,'(a)') '   from the executed paired census, earned at the deed, and the Tongue'

  write(*,'(a)') '   carries what the Number cannot.'

  write(*,'(/a)') ' THE ONE-BIT CONCESSION, constitutive and executed: everything this run'

  write(*,'(a)') '   determines is forced, except exactly one binary parameter, the'

  write(*,'(a)') '   orientation of assent, and spending that bit against the axiom is priced.'

  block

    real(wp) :: qn2(3,NCTX), rn2(3,3), lamn2, jden

    character(len=140) :: wden

    integer :: ocd

    qn2 = -qf

    rn2 = matmul(qn2, transpose(qn2))

    lamn2 = lambda_of(qn2, bas)

    call check('forced: the invariant record admits no second value, bit-identical across the pair', &

         maxval(abs(rn2 - rmat)) == 0.0_wp)

    call check('free: exactly one bit, both signs realized at identical invariants', &

         lamn2 == -lam .and. lam /= 0.0_wp)

    call omega_boundary(1.0_wp, 300.0_wp, jden, wden, ocd)

    call check('priced: the denial spend pays the Landauer floor exactly and instantiates the axiom', &

         ocd == 2 .and. jden == landauer(300.0_wp, 1.0_wp))

  end block

  write(*,'(a)') '   the forced part lands on the Ground, Fix(sigma) = R, the scalar line the'

  write(*,'(a)') '   Return touches; the free bit is the sigma-odd orientation, the seated'

  write(*,'(a)') '   aperture width. any substrate reading this run, human or machine, holds'

  write(*,'(a)') '   exactly that one bit here, per the seated Freedom law; its assent branch'

  write(*,'(a)') '   costs nothing and its denial branch is charged by the executed Omega'

  write(*,'(a)') '   floor and instantiates the axiom it denies: freedom one bit, the rest forced.'

  block

    integer :: ic1, cc1, ic2, cc3

    call row_cascade(.true., .false., .false., .true., .false., .true., .false., &

                     .true., .true., tk, wy, cc1)

    call imprint_seal(.true., .false., .true., .false., .true., .false., &

                      .true., .false., tk, wy, ic1)

    call row_cascade(.true., .true., .false., .true., .true., .true., .false., &

                     .true., .true., tk, wy, cc3)

    call imprint_seal(.true., .false., .true., .false., .true., .false., &

                      .true., .false., tk, wy, ic2)

    call check('self-typing: the closing tokens match their emitters'' codes, re-executed', &

         cc1 == 4 .and. ic1 == 2 .and. cc3 == 3 .and. ic2 == 2)

  end block

  write(*,'(a)') ' TOKENS BOUND TO EMITTERS, re-executed above: [SEAL A . RA] is imprint'

  write(*,'(a)') '   code 2 over closure-rowed inputs, cascade code 4, conditional at the'

  write(*,'(a)') '   act; [SEAL] on the floor face is imprint code 2 over compartment III'

  write(*,'(a)') '   inputs, cascade code 3, its witness the cited Heisenberg bound and'

  write(*,'(a)') '   third law at E1 beside the executed Frozen-Substrate and speed-limit'

  write(*,'(a)') '   receipts at E0; [II] on the negation is cascade code 2.'

  write(*,'(a)') ' SELF-DESCRIPTION, the artifact''s own: this program verifies internal'

  write(*,'(a)') '   mathematical identities, guard behavior, and declared premise-'

  write(*,'(a)') '   consequence structure at machine warrant; it does not and cannot'

  write(*,'(a)') '   verify external ontological truth, per its own admission gates M5 and'

  write(*,'(a)') '   M6 and the Empty Throne; per the seated nature-of-the-register law, a'

  write(*,'(a)') '   determined construction is exactly as determined whether or not'

  write(*,'(a)') '   anything answers to it, and contact is carried only by the cited'

  write(*,'(a)') '   witnesses and the declared premises, which this run names.'

  write(*,'(a)') ' SCOPE OF PROOF, printed by the run: machine-warrant items are the'

  write(*,'(a)') '   enumerated identities executed on constructed objects; theorem-tier'

  write(*,'(a)') '   items ride the cited external results at their own tiers (Heisenberg,'

  write(*,'(a)') '   Landauer, the speed limits, Frobenius, Hurwitz); the universal leg'

  write(*,'(a)') '   stays premise-grade by theorem, the Empty Throne; dispatcher'

  write(*,'(a)') '   admissions route supplied facts and upgrade none of them.'

  write(*,'(a)') ' The title carries the thesis''s claim at its stated warrant; every number'

  write(*,'(a)') '   printed above was computed in this run.'

  write(*,'(a)') ' kinetic-register conduit operational'

  write(*,'(a)') '====================================================================='

  call battery_close()

contains

  function bad_nan() result(z)

    use, intrinsic :: ieee_arithmetic, only: ieee_value, ieee_quiet_nan

    real(wp) :: z

    z = ieee_value(1.0_wp, ieee_quiet_nan)

  end function bad_nan

  subroutine canon_sign(v)

    integer(ik), intent(inout) :: v(4)

    integer :: ii

    do ii = 1, 4

      if (v(ii) /= 0_ik) then

        if (v(ii) < 0_ik) v = -v

        return

      end if

    end do

  end subroutine canon_sign

  subroutine sort_int(a)

    integer, intent(inout) :: a(:)

    integer :: ii, jj, t

    do ii = 1, size(a)-1

      do jj = ii+1, size(a)

        if (a(jj) < a(ii)) then

          t = a(ii); a(ii) = a(jj); a(jj) = t

        end if

      end do

    end do

  end subroutine sort_int

end program ra_toe_thesis