home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / TPL60N14.ZIP / TESTPRGS.ZIP / UNIT1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-02-27  |  22.1 KB  |  701 lines
  1. {$a+,n-,x-,s-,i-,r-,b-,v-}
  2.  
  3. unit Unit1;
  4. interface
  5.    uses mainvars;
  6.    procedure start;
  7.    procedure mile2060;
  8.  
  9. implementation
  10.    procedure start;
  11.  
  12.  
  13.    begin (* PARA *)
  14.  
  15.    {First two assignments use integer right-hand sides.}
  16.    Zero := 0;
  17.    One := 1;
  18.    Two := One + One;
  19.    Three := Two + One;
  20.    Four := Three + One;
  21.    Five := Four + One;
  22.    Eight := Four + Four;
  23.    Nine := Three * Three;
  24.    TwentySeven := Nine * Three;
  25.    ThirtyTwo := Four * Eight;
  26.    TwoForty := Four * Five * Three * Four;
  27.    MinusOne := -One;
  28.    Half := One / Two;
  29.    OneAndHalf := One + Half;
  30.  
  31.    NoErrors [Failure] := 0;
  32.    NoErrors [SeriousDefect] := 0;
  33.    NoErrors [Defect] := 0;
  34.    NoErrors [Flaw] := 0;
  35.    PageNo := 0;
  36. {=============================================}
  37.    Milestone := 0;
  38. {=============================================}
  39.    writeln ('Type any character to start the program.');
  40.    { assign(input,'con:');} { for TURBO Pascal version 2 }
  41.    { reset (input); }       { for old Cray Pascal }
  42.    while not eoln (input) do
  43.       read (input, ch);
  44.    Instructions;
  45.    Pause;
  46.    Heading;
  47.    Pause;
  48.    Characteristics;
  49.    Pause;
  50.    History;
  51. {=============================================}
  52.    Milestone := 7;
  53. {=============================================}
  54.    Pause;
  55.    writeln ('Program is now RUNNING tests on small integers:');
  56.    TestCondition (Failure, (Zero + Zero = Zero) and (One - One = Zero)
  57.          and (One > Zero)
  58.          and (One + One = Two), ' 0+0<>0  or 1-1<>0  or  1<=0  or 1+1<>2 '
  59.          );
  60.    Z := - Zero;
  61.    if Z <> 0.0 then
  62.       begin
  63.       NoErrors [Failure] := NoErrors [Failure] + 1;
  64.       writeln ('Comparison alleges that -0.0 is Non-zero!');
  65.       U2 := 0.001;
  66.       Radix := 1;
  67.       TestPartialUnderflow;
  68.       end;
  69.    TestCondition (Failure, (Three = Two + One) and (Four = Three + One)
  70.          and (Four + Two * (- Two) = Zero)
  71.          and (Four - Three - One = Zero),
  72.          ' 3<>2+1, 4<>3+1, 4+2*(-2)<>0 or 4-3-1<>0');
  73.    TestCondition (Failure, (MinusOne = - One)
  74.          and (MinusOne + One = Zero ) and (One + MinusOne = Zero)
  75.          and (MinusOne + abs (One) = Zero)
  76.          and (MinusOne + MinusOne * MinusOne = Zero),
  77.          '-1+1<>0, -1+abs(1)<>0 or -1+(-1)*(-1)<>0');
  78.    TestCondition (Failure, Half + MinusOne + Half = Zero,
  79.          '   1/2  + (-1) + 1/2 <> 0               ');
  80. {=============================================}
  81.    Milestone := 10;
  82. {=============================================}
  83.    TestCondition (Failure, (Nine = Three * Three)
  84.          and (TwentySeven = Nine * Three) and (Eight = Four + Four)
  85.          and (ThirtyTwo = Eight * Four)
  86.          and (ThirtyTwo - TwentySeven - Four - One = Zero),
  87.          '9<>3*3, 27<>9*3, 32<>8*4 or 32-27-4-1<>0');
  88.    TestCondition (Failure, (Five = Four + One)
  89.          and (TwoForty = Four * Five * Three * Four)
  90.          and (TwoForty / Three - Four * Four * Five = Zero)
  91.          and ( TwoForty / Four - Five * Three * Four = Zero)
  92.          and ( TwoForty / Five - Four * Three * Four = Zero),
  93.          '5<>4+1,240/3<>80,240/4<>60, or 240/5<>48');
  94.    if NoErrors [Failure] = 0 then
  95.       begin
  96.       writeln (' -1, 0, 1/2, 1, 2, 3, 4, 5, 9, 27, 32 & 240 are O.K.');
  97.       writeln
  98.       end;
  99.    writeln ('Searching for Radix and Precision.');
  100.    W := One;
  101.    repeat
  102.       W := W + W;
  103.       Y := W + One;
  104.       Z := Y - W;
  105.       Y := Z - One;
  106.    until (MinusOne + abs (Y) >= Zero);
  107. {.. now W is just big enough that |((W+1)-W)-1| >= 1 ...}
  108.    Precision := 0;
  109.    Y := One;
  110.    repeat
  111.       Radix := W + Y;
  112.       Y := Y + Y;
  113.       Radix := Radix - W;
  114.    until (Radix <> Zero);
  115.    if Radix < Two then
  116.       Radix := One;
  117.    writeln ('Radix = ', Radix);
  118.    if Radix <> 1 then
  119.       begin
  120.       W := One;
  121.       repeat
  122.          Precision := Precision + One;
  123.          W := W * Radix;
  124.          Y := W + One;
  125.       until (Y - W) <> One;
  126.    {... now W = Radix^Precision is barely too big to satisfy (W+1)-W = 1
  127.                                           ...}
  128.       end;
  129.    U1 := One / W;
  130.    U2 := Radix * U1;
  131.    writeln ('Closest relative separation found is U1 = ', U1);
  132.    writeln;
  133.    writeln ('Recalculating radix and precision');
  134.    E0 := Radix;
  135.    E1 := U1;
  136.    E9 := U2;
  137. {save old values}
  138.    X := Four / Three;
  139.    Third := X - One;
  140.    F6 := Half - Third;
  141.    X := F6 + F6;
  142.    X := abs (X - Third);
  143.    if X < U2 then
  144.       X := U2;
  145. {... now X = (unknown no.) ulps of 1+...}
  146.    repeat
  147.       U2 := X;
  148.       Y := Half * U2 + ThirtyTwo * U2 * U2;
  149.       Y := One + Y;
  150.       X := Y - One;
  151.    until (U2 <= X) or (X <= Zero);
  152. {... now U2 = 1 ulp of 1 + ... }
  153.    X := Two / Three;
  154.    F6 := X - Half;
  155.    Third := F6 + F6;
  156.    X := Third - Half;
  157.    X := abs (X + F6);
  158.    if X < U1 then
  159.       X := U1;
  160. {... now  X = (unknown no.) ulps of 1 -... }
  161.    repeat
  162.       U1 := X;
  163.       Y := Half * U1 + ThirtyTwo * U1 * U1;
  164.       Y := Half - Y;
  165.       X := Half + Y;
  166.       Y := Half - X;
  167.       X := Half + Y;
  168.    until (U1 <= X) or (X <= Zero);
  169. {... now U1 = 1 ulp of 1 - ... }
  170.    if U1 = E1 then
  171.       writeln (' confirms closest relative separation U1 .')
  172.    else
  173.       writeln (' gets better closest relative separation U1 = ', U1);
  174.    W := One / U1;
  175.    F9 := (Half - U1) + Half;
  176.    Radix := Int (0.01 + U2 / U1);
  177.    if Radix = E0 then
  178.       writeln ('Radix confirmed.')
  179.    else
  180.       writeln ('MYSTERY: recalculated Radix = ', Radix);
  181.    TestCondition (Defect, Radix <= Eight + Eight,
  182.          'Radix is too big: roundoff problems     ');
  183.    TestCondition (Flaw, (Radix = Two) or (Radix = 10)
  184.          or (Radix = One), 'Radix is not as good as 2 or 10.        ');
  185.    end (*start*);
  186.  
  187.    procedure mile2060;
  188.    begin
  189.  
  190. {=============================================}
  191.    Milestone := 20;
  192. {=============================================}
  193.    TestCondition (Failure, F9 - Half < Half,
  194.          ' (1-U1)-1/2 < 1/2 is FALSE, prog. fails?');
  195.    X := F9;
  196.    I := 1;
  197.    Y := X - Half;
  198.    Z := Y - Half;
  199.    TestCondition (Failure, (X <> One)
  200.          or (Z = Zero), 'Comparison is fuzzy,X=1 but X-1/2-1/2<>1');
  201.    X := One + U2;
  202.    I := 0;
  203. {=============================================}
  204.    Milestone := 25;
  205. {=============================================}
  206.    BMinusU2 := Radix - One;
  207.    BMinusU2 := (BMinusU2 - U2) + One;
  208.    if Radix <> One then
  209.       begin {... BMinusU2 = nextafter(Radix, 0) }
  210.       X := - TwoForty * ln (U1) / ln (Radix);
  211.       Y := Int (Half + X);
  212.       if abs (X - Y) * Four < One then
  213.          X := Y;
  214.       Precision := X / TwoForty;
  215.       Y := Int (Half + Precision);
  216.       if abs (Precision - Y) * TwoForty < Half then
  217.          Precision := Y;
  218.    { Purify integers }
  219.       end;
  220.    if (Precision <> Int (Precision)) or (Radix = One) then
  221.       begin
  222.       writeln ('Precision cannot be characterized by an integer',
  223.             ' number of sig. digits,');
  224.       writeln ('but, by itself, this is a minor flaw.');
  225.       end;
  226.    if Radix = One then
  227.       writeln ('logarithmic encoding has precision characterized',
  228.             'solely by U1.')
  229.    else
  230.       writeln ('The number of significant digits of the Radix is ',
  231.             Precision);
  232.    TestCondition (SeriousDefect, U2 * Nine * Nine * TwoForty < One,
  233.          ' Precision worse than 5 decimal figures ');
  234. {=============================================}
  235.    Milestone := 30;
  236. {=============================================}
  237. { Test for extra-precise subepressions }
  238.    X := abs (((Four / Three - One) - One / Four) * Three - One / Four);
  239.    repeat
  240.       Z2 := X;
  241.       X := (One + (Half * Z2 + ThirtyTwo * Z2 * Z2)) - One;
  242.    until (Z2 <= X) or (X <= Zero);
  243.    Y := abs ((Three / Four - Two / Three) * Three - One / Four);
  244.    Z := Y;
  245.    X := Y;
  246.    repeat
  247.       Z1 := Z;
  248.       Z := (One / Two - ((One / Two - (Half * Z1 + ThirtyTwo * Z1 * Z1))
  249.             + One / Two)) + One / Two;
  250.    until (Z1 <= Z) or (Z <= Zero);
  251.    repeat
  252.       repeat
  253.          Y1 := Y;
  254.          Y := (Half - ((Half - (Half * Y1 + ThirtyTwo * Y1 * Y1)) + Half
  255.                )) + Half;
  256.       until (Y1 <= Y) or (Y <= Zero);
  257.       X1 := X;
  258.       X := ((Half * X1 + ThirtyTwo * X1 * X1) - F9) + F9;
  259.    until (X1 <= X) or (X <= Zero);
  260.    if (X1 <> Y1) or (X1 <> Z1) then
  261.       begin
  262.       NoErrors [SeriousDefect] := NoErrors [SeriousDefect] + 1;
  263.       writeln ('SERIOUS DEFECT:  Disagreements among the values X1, Y1, Z1');
  264.       writeln ('resp. ', X1, Y1, Z1);
  265.       writeln ('are symptoms of inconsistencies introduced');
  266.       writeln ('by extra-precise evaluation of allegedly');
  267.       writeln ('"optimized" arithmetic subexpressions.');
  268.       writeln ('Possibly some part of this test is inconsistent.');
  269.       if (X1 = U1) or (Y1 = U1) or (Z1 = U1) then
  270.          writeln ('That feature is not tested further by this program.');
  271.       end
  272.    else if (Z1 <> U1) or (Z2 <> U2) then
  273.       begin
  274.       if (Z1 >= U1) or (Z2 >= U2) then
  275.          begin
  276.          NoErrors [Failure] := NoErrors [Failure] + 1;
  277.          writeln ('FAILURE:  Precision ', Precision);
  278.          writeln ('U1 = ', U1, ' Z1 - U1 = ', Z1 - U1);
  279.          writeln ('U2 = ', U2, ' Z2 - U2 = ', Z2 - U2);
  280.          end
  281.       else begin
  282.         if (Z1 <= Zero) or (Z2 <= Zero) then begin
  283.          writeln ('Because of unusual Radix = ', Radix);
  284.          writeln (' or exact rational arithmetic a result');
  285.          writeln (' Z1 = ', Z1, ' or Z2 = ', Z2);
  286.          writeln (' of an extra precision test is inconsistent.');
  287.          if Z1 = Z2 then
  288.          end;
  289.         if (Z1 <> Z2) or (Z1 > Zero) then begin
  290.          X := Z1 / U1;
  291.          Y := Z2 / U2;
  292.          if Y > X then X := Y;
  293.          Q := - ln (X);
  294.          writeln ('Some subexpressions appear to be calculated');
  295.          writeln ('extra precisely with about ');
  296.          writeln (Q / ln (Radix), 'extra B-digits i.e. ');
  297.          writeln ('roughly ', Q / ln (10),
  298.             ' extra significant decimals.');
  299.          end;
  300.         writeln ('That feature is not tested further by this program.')
  301.         end
  302.       end;
  303.    Pause;
  304. {=============================================}
  305.    Milestone := 35;
  306. {=============================================}
  307.    if Radix >= Two then
  308.       begin
  309.       X := W / (Radix * Radix);
  310.       Y := X + One;
  311.       Z := Y - X;
  312.       T := Z + U2;
  313.       X := T - Z;
  314.       TestCondition (Failure, X = U2,
  315.             'Subtraction is not normlzd X=Y,X+Z<>Y+Z!');
  316.       if X = U2 then
  317.           writeln ('Subtraction appears to be normalized,',
  318.             ' as it should be.');
  319.       end;
  320.    writeln;
  321.    writeln ('Checking for guard digit on *, /, and -.');
  322.    Y := F9 * One;
  323.    Z := One * F9;
  324.    X := F9 - Half;
  325.    Y := (Y - Half) - X;
  326.    Z := (Z - Half) - X;
  327.    X := One + U2;
  328.    T := X * Radix;
  329.    R := Radix * X;
  330.    X := T - Radix;
  331.    X := X - Radix * U2;
  332.    T := R - Radix;
  333.    T := T - Radix * U2;
  334.    X := X * (Radix - One);
  335.    T := T * (Radix - One);
  336.    if (X = Zero) and (Y = Zero) and (Z = Zero) and (T = Zero) then
  337.       GMult := Yes
  338.    else
  339.       begin
  340.       GMult := No;
  341.       TestCondition (SeriousDefect, false,
  342.             '  * lacks guard digit, 1*X <> X         ');
  343.       end;
  344.    Z := Radix * U2;
  345.    X := One + Z;
  346.    Y := abs ((X + Z) - X * X) - U2;
  347.    X := One - U2;
  348.    Z := abs ((X - U2) - X * X) - U1;
  349.    TestCondition (Failure, (Y <= Zero)
  350.          and (Z <= Zero), '  * gets too many final digits wrong.   ');
  351.    Y := One - U2;
  352.    X := One + U2;
  353.    Z := One / Y;
  354.    Y := Z - X;
  355.    X := One / Three;
  356.    Z := Three / Nine;
  357.    X := X - Z;
  358.    T := Nine / TwentySeven;
  359.    Z := Z - T;
  360.    TestCondition (Defect, (X = Zero) and (Y = Zero)
  361.          and (Z = Zero), 'Division error > ulp, 1/3 <> 3/9 <> 9/27');
  362.    Y := F9 / One;
  363.    X := F9 - Half;
  364.    Y := (Y - Half) - X;
  365.    X := One + U2;
  366.    T := X / One;
  367.    X := T - X;
  368.    if (X = Zero) and (Y = Zero) and (Z = Zero) then
  369.       GDiv := Yes
  370.    else
  371.       begin
  372.       GDiv := No;
  373.       TestCondition (SeriousDefect, false,
  374.             '  Division lacks guard digit so X/1 <> X');
  375.       end;
  376.    X := One / (One + U2);
  377.    Y := X - Half - Half;
  378.    TestCondition (SeriousDefect, Y < Zero,
  379.          '  Computed value of 1/1.000..1 >= 1.    ');
  380.    X := One - U2;
  381.    Y := One + Radix * U2;
  382.    Z := X * Radix;
  383.    T := Y * Radix;
  384.    R := Z / Radix;
  385.    StickyBit := T / Radix;
  386.    X := R - X;
  387.    Y := StickyBit - Y;
  388.    TestCondition (Failure, (X = Zero) and (Y = Zero),
  389.             ' * &or / gets too many last digits wrong');
  390.    Y := One - U1;
  391.    X := One - F9;
  392.    Y := One - Y;
  393.    T := Radix - U2;
  394.    Z := Radix - BMinusU2;
  395.    T := Radix - T;
  396.    if (X = U1) and (Y = U1) and (Z = U2) and (T = U2) then
  397.       GAddSub := Yes
  398.    else
  399.       begin
  400.       GAddSub := No;
  401.       TestCondition (SeriousDefect, false,
  402.             '- lacks guard dig.,cancellation obscured');
  403.       end;
  404.  
  405.    if (F9 <> One) and (F9 - One >= Zero) then begin
  406.       TestCondition (SeriousDefect, false,
  407.             'comparison alleges  (1-U1) < 1  although');
  408.       writeln('  subtration yields  (1-U1) - 1 = 0 , thereby vitiating');
  409.       writeln('  such precautions against division by zero as');
  410.       writeln('  ...  if (X=1.0) then ..... else .../(X-1.0)...');
  411.       end;
  412.    if (GMult = Yes) and (GDiv = Yes) and (GAddSub = Yes) then
  413.       writeln (' *, /, and - have guard digits, as they should.');
  414. {=============================================}
  415.    Milestone := 40;
  416. {=============================================}
  417.    Pause;
  418.    writeln ('Checking rounding on multiply, divide and add/subtract.');
  419.    RMult := Other;
  420.    RDiv := Other;
  421.    RAddSub := Other;
  422.    RadixD2 := Radix / Two;
  423.    A1 := Two;
  424.    Done := false;
  425.    repeat
  426.       AInverse := Radix;
  427.       repeat
  428.          X := AInverse;
  429.          AInverse := AInverse / A1;
  430.       until Int (AInverse) <> AInverse;
  431.       Done := (X = One) or (A1 > Three);
  432.       if not Done then
  433.          A1 := Nine + One;
  434.    until Done;
  435.    if X = One then
  436.       A1 := Radix;
  437.    AInverse := One / A1;
  438.    X := A1;
  439.    Y := AInverse;
  440.    Done := false;
  441.    repeat
  442.       Z := X * Y - Half;
  443.       TestCondition (Failure, Z = Half,
  444.             '  X * (1/X) differs from 1.             ');
  445.       Done := X = Radix;
  446.       X := Radix;
  447.       Y := One / X;
  448.    until Done;
  449.    Y2 := One + U2;
  450.    Y1 := One - U2;
  451.    X := OneAndHalf - U2;
  452.    Y := OneAndHalf + U2;
  453.    Z := (X - U2) * Y2;
  454.    T := Y * Y1;
  455.    Z := Z - X;
  456.    T := T - X;
  457.    X := X * Y2;
  458.    Y := (Y + U2) * Y1;
  459.    X := X - OneAndHalf;
  460.    Y := Y - OneAndHalf;
  461.    if (X = Zero) and (Y = Zero) and (Z = Zero) and (T <= Zero) then
  462.       begin
  463.       X := (OneAndHalf + U2) * Y2;
  464.       Y := OneAndHalf - U2 - U2;
  465.       Z := OneAndHalf + U2 + U2;
  466.       T := (OneAndHalf - U2) * Y1;
  467.       X := X - (Z + U2);
  468.       StickyBit := Y * Y1;
  469.       S := Z * Y2;
  470.       T := T - Y;
  471.       Y := (U2 - Y) + StickyBit;
  472.       Z := S - (Z + U2 + U2);
  473.       StickyBit := (Y2 + U2) * Y1;
  474.       Y1 := Y2 * Y1;
  475.       StickyBit := StickyBit - Y2;
  476.       Y1 := Y1 - Half;
  477.       if (X = Zero) and (Y = Zero) and (Z = Zero) and (T = Zero)
  478.             and ( StickyBit = Zero) and (Y1 = Half) then
  479.          begin
  480.          RMult := Rounded;
  481.          writeln ('Multiplication appears to round correctly.');
  482.          end
  483.       else if (X + U2 = Zero) and (Y < Zero) and (Z + U2 = Zero)
  484.             and (T < Zero) and (StickyBit + U2 = Zero)
  485.             and (Y1 < Half) then
  486.          begin
  487.          RMult := Chopped;
  488.          writeln ('Multiplication appears to chop.');
  489.          end
  490.       else
  491.          writeln ('* is neither chopped nor correctly rounded.');
  492.       if (RMult = Rounded) and (GMult = No) then
  493.          notify('multiplication');
  494.       end
  495.    else
  496.       writeln ('* is neither chopped nor correctly rounded.');
  497. {=============================================}
  498.    Milestone := 45;
  499. {=============================================}
  500.    Y2 := One + U2;
  501.    Y1 := One - U2;
  502.    Z := OneAndHalf + U2 + U2;
  503.    X := Z / Y2;
  504.    T := OneAndHalf - U2 - U2;
  505.    Y := (T - U2) / Y1;
  506.    Z := (Z + U2) / Y2;
  507.    X := X - OneAndHalf;
  508.    Y := Y - T;
  509.    T := T / Y1;
  510.    Z := Z - (OneAndHalf + U2);
  511.    T := (U2 - OneAndHalf) + T;
  512.    if not ((X > Zero) or (Y > Zero) or (Z > Zero) or (T > Zero)) then
  513.       begin
  514.       X := OneAndHalf / Y2;
  515.       Y := OneAndHalf - U2;
  516.       Z := OneAndHalf + U2;
  517.       X := X - Y;
  518.       T := OneAndHalf / Y1;
  519.       Y := Y / Y1;
  520.       T := T - (Z + U2);
  521.       Y := Y - Z;
  522.       Z := Z / Y2;
  523.       Y1 := (Y2 + U2) / Y2;
  524.       Z := Z - OneAndHalf;
  525.       Y2 := Y1 - Y2;
  526.       Y1 := (F9 - U1) / F9;
  527.       if (X = Zero) and (Y = Zero) and (Z = Zero) and (T = Zero)
  528.             and (Y2 = Zero) and (Y2 = Zero)
  529.             and (Y1 - Half = F9 - Half ) then
  530.          begin
  531.          RDiv := Rounded;
  532.          writeln ('Division appears to round correctly.');
  533.          if GDiv = No then notify('   division   ');
  534.          end
  535.       else if (X < Zero) and (Y < Zero) and (Z < Zero) and (T < Zero)
  536.             and (Y2 < Zero) and (Y1 - Half < F9 - Half) then
  537.          begin
  538.          RDiv := Chopped;
  539.          writeln ('Division appears to chop.');
  540.          end;
  541.       end;
  542.    if RDiv = Other then
  543.       writeln ('/ is neither chopped nor correctly rounded.');
  544.    BInverse := One / Radix;
  545.    TestCondition (Failure, (BInverse * Radix - Half = Half),
  546.          '  Radix * ( 1 / Radix ) differs from 1. ');
  547. {=============================================}
  548.    Milestone := 50;
  549. {=============================================}
  550.    TestCondition (Failure, ((F9 + U1) - Half = Half)
  551.          and ((BMinusU2 + U2 ) - One = Radix - One),
  552.          'Incomplete carry-propagation in Addition');
  553.    X := One - U1 * U1;
  554.    Y := One + U2 * (One - U2);
  555.    Z := F9 - Half;
  556.    X := (X - Half) - Z;
  557.    Y := Y - One;
  558.    if (X = Zero) and (Y = Zero) then
  559.       begin
  560.       RAddSub := Chopped;
  561.       writeln ('Add/Subtract appears to be chopped.');
  562.       end;
  563.    if GAddSub = Yes then
  564.       begin
  565.       X := (Half + U2) * U2;
  566.       Y := (Half - U2) * U2;
  567.       X := One + X;
  568.       Y := One + Y;
  569.       X := (One + U2) - X;
  570.       Y := One - Y;
  571.       if (X = Zero) and (Y = Zero) then
  572.          begin
  573.          X := (Half + U2) * U1;
  574.          Y := (Half - U2) * U1;
  575.          X := One - X;
  576.          Y := One - Y;
  577.          X := F9 - X;
  578.          Y := One - Y;
  579.          if (X = Zero) and (Y = Zero) then
  580.             begin
  581.             RAddSub := Rounded;
  582.             writeln ('Addition/Subtraction appears to round correctly.');
  583.             if GAddSub = No then notify(' add/subtract ');
  584.             end
  585.          else
  586.             writeln ('Addition/Subtraction neither rounds nor chops.');
  587.          end
  588.       else
  589.          writeln ('Addition/Subtraction neither rounds nor chops.');
  590.       end
  591.    else
  592.       writeln ('Addition/Subtraction neither rounds nor chops.');
  593.    S := One;
  594.    X := One + Half * (One + Half);
  595.    Y := (One + U2) * Half;
  596.    Z := X - Y;
  597.    T := Y - X;
  598.    StickyBit := Z + T;
  599.    if StickyBit <> 0 then
  600.       begin
  601.       S := 0;
  602.       NoErrors [Flaw] := NoErrors [Flaw] + 1;
  603.       write('FLAW:  (X - Y) + (Y - X) is non zero!');
  604.       end;
  605.    StickyBit := Zero;
  606.    if (GMult = Yes) and (GDiv = Yes) and (GAddSub = Yes)
  607.          and (RMult = Rounded) and (RDiv = Rounded)
  608.          and (RAddSub = Rounded) and (Int (RadixD2) = RadixD2) then
  609.       begin
  610.       writeln (' Checking for sticky bit.');
  611.       X := (Half + U1) * U2;
  612.       Y := Half * U2;
  613.       Z := One + Y;
  614.       T := One + X;
  615.       if (Z - One <= Zero) and (T - One >= U2) then
  616.          begin
  617.          Z := T + Y;
  618.          Y := Z - X;
  619.          if (Z - T >= U2) and (Y - T = Zero) then
  620.             begin
  621.             X := (Half + U1) * U1;
  622.             Y := Half * U1;
  623.             Z := One - Y;
  624.             T := One - X;
  625.             if (Z - One = Zero) and (T - F9 = Zero) then
  626.                begin
  627.                inline($fa/$fb);
  628.                Z := (Half - U1) * U1;
  629.                T := F9 - Z;
  630.                Q := F9 - Y;
  631.                if (T - F9 = Zero) and (F9 - U1 - Q = Zero) then
  632.                   begin
  633.                   Z := (One + U2) * OneAndHalf;
  634.                   T := (OneAndHalf + U2) - Z + U2;
  635.                   X := One + Half / Radix;
  636.                   Y := One + Radix * U2;
  637.                   Z := X * Y;
  638.                   if (T = Zero) and (X + Radix * U2 - Z = Zero) then
  639.                      begin
  640.                      if Radix <> Two then
  641.                         begin
  642.                         X := Two + U2;
  643.                         Y := X / Two;
  644.                         if (Y - One = Zero) then
  645.                            StickyBit := S;
  646.                         end
  647.                      else StickyBit := S;
  648.                      end;
  649.                   end;
  650.                end;
  651.             end;
  652.          end;
  653.       end;
  654.    if StickyBit = One then
  655.       writeln ('Sticky bit apparently used correctly.')
  656.    else writeln ('Sticky bit used incorrectly or not at all.');
  657.    if (GMult = No) or (GDiv = No) or (GAddSub = No) or (RMult = Other)
  658.       or (RDiv = Other) or (RAddSub = Other) then begin
  659.         TestCondition (Flaw, false,
  660.              'lack(s) of guard digits or failure(s) to');
  661.         writeln('correctly round or chop (noted above) count as one');
  662.         writeln('flaw in the final tally below.')
  663.         end;
  664.  
  665.  
  666. {=============================================}
  667.    Milestone := 60;
  668. {=============================================}
  669.    writeln;
  670.    writeln ('Does Multiplication commute? Testing on ', NoTrials,
  671.          ' random pairs.');
  672.    R9 := sqrt (3.0);
  673.    RandomNumber1 := Third;
  674.    I := 1;
  675.    repeat
  676.       X := Random;
  677.       Y := Random;
  678.       Z9 := Y * X;
  679.       Z := X * Y;
  680.       Z9 := Z - Z9;
  681.       I := I + 1;
  682.    until (I > NoTrials) or (Z9 <> Zero);
  683.    if I = NoTrials then
  684.       begin
  685.       RandomNumber1 := One + Half / Three;
  686.       RandomNumber2 := (U2 + U1) + One;
  687.       Z := RandomNumber1 * RandomNumber2;
  688.       Y := RandomNumber2 * RandomNumber1;
  689.       Z9 := (One + Half / Three) * ((U2 + U1) + One) - (One + Half /
  690.             Three) * ((U2 + U1) + One);
  691.       end;
  692.    if not ((I = NoTrials) or (Z9 = Zero)) then
  693.       begin
  694.       NoErrors [Defect] := NoErrors [Defect] + 1;
  695.       writeln ('DEFECT:  X * Y = Y * X trail fails.');
  696.       end
  697.    else
  698.       writeln ('No failures found in ', NoTrials, ' integer pairs.');
  699.    end;
  700. end.
  701.