DataMuseum.dk

Presents historical artifacts from the history of:

Rational R1000/400 Tapes

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about Rational R1000/400 Tapes

Excavated with: AutoArchaeologist - Free & Open Source Software.


top - download
Index: ┃ B T

⟦06346fae5⟧ TextFile

    Length: 9572 (0x2564)
    Types: TextFile
    Names: »B«

Derivation

└─⟦5f3412b64⟧ Bits:30000745 8mm tape, Rational 1000, ENVIRONMENT 12_6_5 TOOLS 
    └─ ⟦91c658230⟧ »DATA« 
        └─⟦458657fb6⟧ 
            └─⟦1472c4407⟧ 
                └─⟦this⟧ 
└─⟦d10a02448⟧ Bits:30000409 8mm tape, Rational 1000, ENVIRONMENT, D_12_7_3
    └─ ⟦fc9b38f02⟧ »DATA« 
        └─⟦9b46a407a⟧ 
            └─⟦2e03b931c⟧ 
                └─⟦this⟧ 

TextFile

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;