|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 13312 (0x3400)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, function Kf_Sqrt, seg_0130d9, separate Generic_Elementary_Functions
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
separate (Generic_Elementary_Functions)
function Kf_Sqrt (Y : Common_Float) return Common_Float is
-- On input, Y is a floating-point value in Common_Float;
-- On output, the square root of Y is returned
-- The caculation is carried out in three steps.
--
-- Step 1. Reduction.
-- The input argument is scaled to the interval [1, 4) thus:
-- input argument = 2^L * X, X in [1, 4).
-- Furthermore, X is decomposed as X = C + T where
-- C = 1 + j/32, j = 0,1,..,96; and |T| <= 1/64.
--
-- Step 2. Approximation.
-- An approximation Q = sqrt(1 + (T/C)) - 1 is obtained. This is
-- performed by the kernel function kf_R1pSm.
--
-- Step 3. Reconstruction.
-- The value of sqrt(Y) is reconstructed via
-- sqrt(Y) = 2^(L/2) * sqrt(X)
-- = 2^(L/2) * sqrt(C) * sqrt(X/C)
-- = 2^(L/2) * sqrt(C) * sqrt(1 + T/C)
-- = 2^(L/2) * [ sqrt(C) + sqrt(C)*Q ]
--
X, X_Frac, X_Trail, R, C : Common_Float;
Z, Z1, Z2, Q, Rtc, Rtc_Lead, Rtc_Trail : Common_Float;
X_Exp, L, L1, L2, Index : Common_Int;
Two_To : constant array (Common_Int range 0 .. 3) of Common_Float :=
(1.0, 2.0, 4.0, 8.0);
-- Rt_Jby32 is an array of pairs of Common_Float numbers
-- representing sqrt(j/32) for j = 32, 33, ..., 128. Each such value
-- is represented by Lead + Trail. The leading parts contain 13 bits
-- of information and are consequently model numbers as long as
-- System.Max_Digits is >= 4. The trailing parts contain roughly
-- Common_Float'Mantissa bits of information, under the assumption
-- that System.Max_Digits is <= 33.
Rt_Jby32 : constant array (Common_Int range 32 .. 128, Position) of
Common_Float :=
((16#1.000#, 16#0.000000000000000000000000000000000000#),
(16#1.03F#, 16#0.00081F636B80BBC40DD15FB55CFE8794F1E3#),
(16#1.07E#, 16#0.0000F66AFED06F5AC8F119530A885D60CA10#),
(16#1.0BB#, 16#0.000B307ACAFDAEAD568979062D2866CD0BAA#),
(16#1.0F8#, 16#0.00076CCDF6CD96C6863C4E8D2FF01DEEAC27#),
(16#1.134#, 16#0.00063FA37014E0D94ADD534C66998A640703#),
(16#1.16F#, 16#0.0008334644DF885E619FD78EDC88849950ED#),
(16#1.1A9#, 16#0.000DC8F6DF10380EB98F9C8F8ADA2DC38B3F#),
(16#1.1E3#, 16#0.000779B97F4A7C15F39CC0605CEDC8341082#),
(16#1.21C#, 16#0.0005B70D9F8239EEC19844640F5C4DA7CCEA#),
(16#1.254#, 16#0.0008EB9151E8533304014EE90F133D57DEFE#),
(16#1.28C#, 16#0.00017B9337833E50EAF5F17768E0292FE925#),
(16#1.2C2#, 16#0.000FC595456A6CD213E9E0702D4D3664BE11#),
(16#1.2F9#, 16#0.000422C23C47DED837A0D6249A34FEFC03D4#),
(16#1.32E#, 16#0.000EE757704167B639DCC3ABFC978928FCD9#),
(16#1.364#, 16#0.0000630445305A1C9E77362F3D783E11EA98#),
(16#1.398#, 16#0.0008E1409212E7D0321914321A556473DB02#),
(16#1.3CC#, 16#0.0008A99AF5452FE79C9BB0FA0D42CD967382#),
(16#1.400#, 16#0.000000000000000000000000000000000000#),
(16#1.432#, 16#0.000F24FB01C7A4E2FF83804B06E49D480837#),
(16#1.465#, 16#0.000655F122FF6618B174BC3292ED999CC170#),
(16#1.497#, 16#0.0005CD5768087BA33850FF422DE5ECD200DE#),
(16#1.4C8#, 16#0.000DC2E42397FD6C5C1722145A8A2CA6DC62#),
(16#1.4F9#, 16#0.000E6BBC4ECB3073969806124FC607D66B4B#),
(16#1.52A#, 16#0.0007FA9D2F8E9B78E753F30FE1BD106AA53B#),
(16#1.55A#, 16#0.000AA002A9D59FE40AFB89DBE06CA9CB3B5F#),
(16#1.58A#, 16#0.00068A4A8D9F3541E6399C04B6432EDB7BB5#),
(16#1.5B9#, 16#0.000BE5D52A9DA21319A3675EEEEF9BBBF815#),
(16#1.5E8#, 16#0.000ADD236A58EF0839C1F97009CF6309A3C9#),
(16#1.617#, 16#0.000398F2AAA47C931A88BB3F196BFAB425E5#),
(16#1.645#, 16#0.000640568C1C3745DE1F93225C0898BA66A4#),
(16#1.673#, 16#0.0002F8D0E2F76D8400571F7BA3A3BAD60731#),
(16#1.6A0#, 16#0.0009E667F3BCC908B2FB1366EA957D3E3ADE#),
(16#1.6CD#, 16#0.000B2BBB212EB580CCB36EAE8B5B6FFC91B7#),
(16#1.6FA#, 16#0.0006EA162D0F00C8D121EB14BF48BC6E0A0B#),
(16#1.726#, 16#0.000D41832A0BDFF13272AB89A7D4425F8E90#),
(16#1.752#, 16#0.000E50DB3A3A1B1B33B0456F1FBAC9056B03#),
(16#1.77E#, 16#0.000A35D632E434BDC52688BE93AD9C570D1E#),
(16#1.7AA#, 16#0.00010D193C22CE6F126BFC5017AED875D8CB#),
(16#1.7D5#, 16#0.0002F244809E94207DBCEE6757BB7A4A324D#),
(16#1.800#, 16#0.000000000000000000000000000000000000#),
(16#1.82A#, 16#0.0008500794E6BDA24AB1432A741CE963313E#),
(16#1.854#, 16#0.000BFB363DC3964E67F28E1E1F9F6E29BE6E#),
(16#1.87E#, 16#0.000B1990B697A1C43E9F593EA0EABD90D1C2#),
(16#1.8A8#, 16#0.0005C24F706597DB81DAD62293FF086ABE21#),
(16#1.8D1#, 16#0.000C0BE7F20ABC848EB241FBC1A45E32BEE8#),
(16#1.8FA#, 16#0.000E0C15AD389E24852497E80935E4B5704C#),
(16#1.923#, 16#0.000BD7E25164CB61CB9BF8B12FE273885183#),
(16#1.94C#, 16#0.000583ADA5B529204A2BC830CD9BFEA55A70#),
(16#1.974#, 16#0.000B2334F2346229C95A75D3C7E82CE6023A#),
(16#1.99C#, 16#0.000CC999FFF002CC4680C7711DC346B5EE9B#),
(16#1.9C4#, 16#0.000A8969B7076A4D5868CAEBA1823A72BA0F#),
(16#1.9EC#, 16#0.000474A261263D57E76EC8B5F1811E33D9DA#),
(16#1.A13#, 16#0.000A9CB99665081951BC6C5E8F43A079BFF3#),
(16#1.A3A#, 16#0.000D12A1DA1605445A3D2F96610292C13A91#),
(16#1.A61#, 16#0.000BE6CFEC996C7902A9A8946BF287D23F2D#),
(16#1.A88#, 16#0.0007293FD6F34168EF24F1987215A65D94DD#),
(16#1.AAE#, 16#0.000EE979B4837B83DD44184250109D8B3E77#),
(16#1.AD5#, 16#0.000336963EEFBA20ED6B20908B64AC4E18C3#),
(16#1.AFB#, 16#0.00041F432002DE536B5020173A54A81E71A1#),
(16#1.B21#, 16#0.0001B1C70D02300F262F33757177947B7458#),
(16#1.B46#, 16#0.000BFC05AEB896C71F30E6B727BA1B823BF4#),
(16#1.B6C#, 16#0.00030B83593E63E9C7FA51B0978580314306#),
(16#1.B91#, 16#0.0006ED68964EC24D4BABB755C51692DDAC14#),
(16#1.BB6#, 16#0.0007AE8584CAA73B25742D7078B83B8925D8#),
(16#1.BDB#, 16#0.00055B550FDBC1365E96AA5FAE317999642D#),
(16#1.C00#, 16#0.000000000000000000000000000000000000#),
(16#1.C24#, 16#0.0007A85FE81FA33B1DDED0A843F3D1971D1A#),
(16#1.C48#, 16#0.000C6001F0ABFB4ADFB9D840A53ADC8DC996#),
(16#1.C6C#, 16#0.000E322982A3F32365BE7C2BE5138018AE92#),
(16#1.C90#, 16#0.000D29D2D43CD849493E03BB218420C5CA72#),
(16#1.CB4#, 16#0.000951B558D173F97966AFE461040C6E3CF4#),
(16#1.CD8#, 16#0.0002B446159F360FEDECCF37F9E485EE26DE#),
(16#1.CFB#, 16#0.00095BB9DCC0C4B3A88215EB80C48475FE6B#),
(16#1.D1E#, 16#0.000D52076FBE93E9150D6E50EBEC6D31C346#),
(16#1.D41#, 16#0.000EA0E98AF91248C8006132C5DA1A797190#),
(16#1.D64#, 16#0.000D51E0DB1C5BB84B259E4B278016ADC883#),
(16#1.D87#, 16#0.00096E35DDBB227FBB235D6C6F3DEC157D48#),
(16#1.DAA#, 16#0.0002FEFAAE1D7F600F8FE05DD35E1E018509#),
(16#1.DCC#, 16#0.000A0D0CBF4081A6D162310DB56C5AB234A6#),
(16#1.DEE#, 16#0.000EA11683F4920555C97F4F84DA4E72B441#),
(16#1.E11#, 16#0.0000C39105FAF1761614C513963B3FA95DCD#),
(16#1.E33#, 16#0.00007CC56CF5BDC1F6279CEDD9E4EA5CD9FE#),
(16#1.E54#, 16#0.000DD4CE75F1DDDC9CD44073A363E611E0E7#),
(16#1.E76#, 16#0.0008D399DC46F95CDFB2FE8FF8F93FCA3195#),
(16#1.E98#, 16#0.000180E9B47F19250A2F1A4BDC64666B2228#),
(16#1.EB9#, 16#0.0007E455B9EDB666D150215E20B45D93E9DB#),
(16#1.EDA#, 16#0.000C054C8F94C42D7045695881AC1491A88A#),
(16#1.EFB#, 16#0.000DEB14F4ED9B17AE807907E1E88FE92C4D#),
(16#1.F1C#, 16#0.000D9CCEEF23946BF6193AAD828D8C3590F2#),
(16#1.F3D#, 16#0.000B2174E746878544CB5AB14A71F75D3401#),
(16#1.F5E#, 16#0.00067FDCBDF439D43E79ED8A41009E5B0A26#),
(16#1.F7E#, 16#0.000FBEB8D4F11E17B175900CDA9F1B891674#),
(16#1.F9F#, 16#0.0006E4990F2273685CB6BA3D0102FE4EB10C#),
(16#1.FBF#, 16#0.000BF7EBC755E9355AFDEC97D29B989FF7D9#),
(16#1.FDF#, 16#0.000EFEFEBE3D5BD940C0E0F83137D7F3C73B#),
(16#2.000#, 16#0.000000000000000000000000000000000000#));
begin
-- Filter out exceptional cases.
X := Y;
if X < 0.0 then
raise Argument_Error;
end if;
if X = 0.0 then
return (Y);
end if;
-- Step 1. Argument Reduction. Must be extra careful for base 16 machines.
if (Radix = 2) then
Decompose (X, X_Frac, X_Exp);
if (X_Exp mod 2 = 0) then
X := 4.0 * X_Frac;
L := X_Exp - 2;
else
X := 2.0 * X_Frac;
L := X_Exp - 1;
end if;
Index := Common_Int (2#1.0#E5 * X);
C := Common_Float (Index) * 2#1.0#E-5;
R := (X - C) / C;
else
Decompose (X, X_Frac, X_Exp);
X_Exp := X_Exp * 4;
if (X_Frac < 0.25) then
X := X_Frac * 16.0;
L := X_Exp - 4;
X_Trail := 0.0;
else
X := X_Frac * 4.0;
L := X_Exp - 2;
X_Trail := 4.0 * (X_Frac - X * 0.25);
end if;
Index := Common_Int (2#1.0#E5 * X);
C := Common_Float (Index) * 2#1.0#E-5;
R := ((X - C) + X_Trail) / C;
end if;
-- Step 2. Get sqrt(1 + R) - 1
Q := Kf_R1psm (R);
-- Step 3. Reconstruction.
Rtc_Lead := Rt_Jby32 (Index, Lead);
Rtc_Trail := Rt_Jby32 (Index, Trail);
Rtc := Rtc_Lead + Rtc_Trail;
if (Radix = 2) then
L := L / 2;
Z := Rtc_Lead + (Rtc * Q + Rtc_Trail);
return (Scale (Z, L));
else
L := L / 2;
L2 := L mod 4;
L1 := (L - L2) / 4;
-- now L = 4L1 + L2; 2^L = 16^L1 * 2^L2
Z1 := Two_To (L2) * Rtc_Lead;
Z2 := Two_To (L2) * (Rtc * Q + Rtc_Trail);
Z := Z1 + Z2;
return (Scale (Z, L1));
end if;
end Kf_Sqrt;
nblk1=c
nid=0
hdr6=18
[0x00] rec0=1e rec1=00 rec2=01 rec3=018
[0x01] rec0=00 rec1=00 rec2=0c rec3=01c
[0x02] rec0=13 rec1=00 rec2=02 rec3=070
[0x03] rec0=01 rec1=00 rec2=0b rec3=00a
[0x04] rec0=0f rec1=00 rec2=03 rec3=040
[0x05] rec0=0f rec1=00 rec2=04 rec3=076
[0x06] rec0=10 rec1=00 rec2=05 rec3=028
[0x07] rec0=0f rec1=00 rec2=06 rec3=05e
[0x08] rec0=10 rec1=00 rec2=07 rec3=010
[0x09] rec0=0f rec1=00 rec2=08 rec3=046
[0x0a] rec0=2d rec1=00 rec2=09 rec3=058
[0x0b] rec0=26 rec1=00 rec2=0a rec3=000
tail 0x2170e744e82b151cf7acc 0x42a00066462061e03