cxg2009.a

来自「linux下编程用 编译软件」· A 代码 · 共 422 行

-- CXG2009.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that the real sqrt and complex modulus functions
--      return results that are within the allowed
--      error bound.
--
-- TEST DESCRIPTION:
--      This test checks the accuracy of the sqrt and modulus functions 
--      by computing the norm of various vectors where the result
--      is known in advance.
--      This test uses real and complex math together as would an 
--      actual application.  Considerable use of generics is also
--      employed.
--
-- SPECIAL REQUIREMENTS
--      The Strict Mode for the numerical accuracy must be
--      selected.  The method by which this mode is selected
--      is implementation dependent.
--
-- APPLICABILITY CRITERIA:
--      This test applies only to implementations supporting the
--      Numerics Annex.
--      This test only applies to the Strict Mode for numerical
--      accuracy.
--
--
-- CHANGE HISTORY:
--      26 FEB 96   SAIC    Initial release for 2.1
--      22 AUG 96   SAIC    Revised Check procedure
--
--!

------------------------------------------------------------------------------

with System;
with Report;
with Ada.Numerics.Generic_Complex_Types;
with Ada.Numerics.Generic_Elementary_Functions;
procedure CXG2009 is
   Verbose : constant Boolean := False;

   --=====================================================================

   generic
      type Real is digits <>;
   package Generic_Real_Norm_Check is
      procedure Do_Test;
   end Generic_Real_Norm_Check;

   -----------------------------------------------------------------------

   package body Generic_Real_Norm_Check is
      type Vector is array (Integer range <>) of Real;

      package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real);
      function Sqrt (X : Real) return Real renames GEF.Sqrt;

      function One_Norm (V : Vector) return Real is
      -- sum of absolute values of the elements of the vector
	 Result : Real := 0.0;
      begin
	 for I in V'Range loop
	    Result := Result + abs V(I);
	 end loop;
	 return Result;
      end One_Norm;

      function Inf_Norm (V : Vector) return Real is
      -- greatest absolute vector element
	 Result : Real := 0.0;
      begin
	 for I in V'Range loop
	    if abs V(I) > Result then
	       Result := abs V(I);
	    end if;
	 end loop;
	 return Result;
      end Inf_Norm;

      function Two_Norm (V : Vector) return Real is
      -- if greatest absolute vector element is 0 then return 0
      -- else return greatest * sqrt (sum((element / greatest) ** 2)))
      --   where greatest is Inf_Norm of the vector
	 Inf_N : Real;
	 Sum_Squares : Real;
	 Term : Real;
      begin
	 Inf_N := Inf_Norm (V);
	 if Inf_N = 0.0 then
	    return 0.0;
	 end if;
         Sum_Squares := 0.0;
	 for I in V'Range loop
	    Term := V (I) / Inf_N;
	    Sum_Squares := Sum_Squares + Term * Term;
	 end loop;
	 return Inf_N * Sqrt (Sum_Squares);
      end Two_Norm;


      procedure Check (Actual, Expected : Real;
		       Test_Name : String;
		       MRE : Real;
		       Vector_Length : Integer) is
         Rel_Error : Real;
         Abs_Error : Real;
         Max_Error : Real;
      begin
         -- In the case where the expected result is very small or 0
         -- we compute the maximum error as a multiple of Model_Epsilon instead
         -- of Model_Epsilon and Expected.
         Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
         Abs_Error := MRE * Real'Model_Epsilon;
         if Rel_Error > Abs_Error then
            Max_Error := Rel_Error;
         else
            Max_Error := Abs_Error;
         end if; 

         if abs (Actual - Expected) > Max_Error then
            Report.Failed (Test_Name & 
	                     "  VectLength:" & 
                           Integer'Image (Vector_Length) &
                           " actual: " & Real'Image (Actual) &
                           " expected: " & Real'Image (Expected) &
                           " difference: " & 
                           Real'Image (Actual - Expected) &
                           " mre:" & Real'Image (Max_Error) );
         elsif Verbose then
            Report.Comment (Test_Name & " vector length" &
                            Integer'Image (Vector_Length));
	  end if;
      end Check;


      procedure Do_Test is
      begin
	 for Vector_Length in 1 .. 10 loop
	    declare
	       V  : Vector (1..Vector_Length) := (1..Vector_Length => 0.0);
	       V1 : Vector (1..Vector_Length) := (1..Vector_Length => 1.0);
	    begin
	       Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length);
	       Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length);

	       for J in 1..Vector_Length loop
		 V := (1..Vector_Length => 0.0);
		 V (J) := 1.0;
	         Check (One_Norm (V), 1.0, "one_norm (010)", 
			0.0, Vector_Length);
	         Check (Inf_Norm (V), 1.0, "inf_norm (010)", 
			0.0, Vector_Length);
	         Check (Two_Norm (V), 1.0, "two_norm (010)", 
			0.0, Vector_Length);
	       end loop;

	       Check (One_Norm (V1), Real (Vector_Length), "one_norm (1)", 
		      0.0, Vector_Length);
	       Check (Inf_Norm (V1), 1.0, "inf_norm (1)", 
		      0.0, Vector_Length);

               -- error in computing Two_Norm and expected result
               -- are as follows  (ME is Model_Epsilon * Expected_Value):
               --   2ME from expected Sqrt
               --   2ME from Sqrt in Two_Norm times the error in the
               --   vector calculation.
               --   The vector calculation contains the following error
               --   based upon the length N of the vector:
               --      N*1ME from squaring terms in Two_Norm
               --      N*1ME from the division of each term in Two_Norm
               --      (N-1)*1ME from the sum of the terms
               -- This gives (2 + 2 * (N + N + (N-1)) ) * ME
               -- which simplifies to (2 + 2N + 2N + 2N - 2) * ME
               -- or 6*N*ME
	       Check (Two_Norm (V1), Sqrt (Real(Vector_Length)), 
                      "two_norm (1)", 
		      (Real (6 * Vector_Length)), 
		      Vector_Length);
	    exception
	       when others => Report.Failed ("exception for vector length" &
				Integer'Image (Vector_Length) );
	    end;
	 end loop;
      end Do_Test;
   end Generic_Real_Norm_Check;

   --=====================================================================

   generic
      type Real is digits <>;
   package Generic_Complex_Norm_Check is
      procedure Do_Test;
   end Generic_Complex_Norm_Check;

   -----------------------------------------------------------------------

   package body Generic_Complex_Norm_Check is
      package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real);
      use Complex_Types;
      type Vector is array (Integer range <>) of Complex;

      package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real);
      function Sqrt (X : Real) return Real renames GEF.Sqrt;

      function One_Norm (V : Vector) return Real is
	 Result : Real := 0.0;
      begin
	 for I in V'Range loop
	    Result := Result + abs V(I);
	 end loop;
	 return Result;
      end One_Norm;

      function Inf_Norm (V : Vector) return Real is
	 Result : Real := 0.0;
      begin
	 for I in V'Range loop
	    if abs V(I) > Result then
	       Result := abs V(I);
	    end if;
	 end loop;
	 return Result;
      end Inf_Norm;

      function Two_Norm (V : Vector) return Real is
	 Inf_N : Real;
	 Sum_Squares : Real;
	 Term : Real;
      begin
	 Inf_N := Inf_Norm (V);
	 if Inf_N = 0.0 then
	    return 0.0;
	 end if;
         Sum_Squares := 0.0;
	 for I in V'Range loop
	    Term := abs (V (I) / Inf_N );
	    Sum_Squares := Sum_Squares + Term * Term;
	 end loop;
	 return Inf_N * Sqrt (Sum_Squares);
      end Two_Norm;


      procedure Check (Actual, Expected : Real;
		       Test_Name : String;
		       MRE : Real;
		       Vector_Length : Integer) is
         Rel_Error : Real;
         Abs_Error : Real;
         Max_Error : Real;
      begin
         -- In the case where the expected result is very small or 0
         -- we compute the maximum error as a multiple of Model_Epsilon instead
         -- of Model_Epsilon and Expected.
         Rel_Error := MRE * abs Expected * Real'Model_Epsilon;
         Abs_Error := MRE * Real'Model_Epsilon;
         if Rel_Error > Abs_Error then
            Max_Error := Rel_Error;
         else
            Max_Error := Abs_Error;
         end if; 

         if abs (Actual - Expected) > Max_Error then
            Report.Failed (Test_Name & 
	                     "  VectLength:" & 
                           Integer'Image (Vector_Length) &
                           " actual: " & Real'Image (Actual) &
                           " expected: " & Real'Image (Expected) &
                           " difference: " & 
                           Real'Image (Actual - Expected) &
                           " mre:" & Real'Image (Max_Error) );
         elsif Verbose then
            Report.Comment (Test_Name & " vector length" &
                            Integer'Image (Vector_Length));
	  end if;
      end Check;


      procedure Do_Test is
      begin
	 for Vector_Length in 1 .. 10 loop
	    declare
	       V  : Vector (1..Vector_Length) := 
                      (1..Vector_Length => (0.0, 0.0));
               X, Y : Vector (1..Vector_Length);
	    begin
	       Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length);
	       Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length);

	       for J in 1..Vector_Length loop
		 X := (1..Vector_Length => (0.0, 0.0) );
                 Y := X;   -- X and Y are now both zeroed
		 X (J).Re := 1.0;
                 Y (J).Im := 1.0;
	         Check (One_Norm (X), 1.0, "one_norm (0x0)", 
			0.0, Vector_Length);
	         Check (Inf_Norm (X), 1.0, "inf_norm (0x0)", 
			0.0, Vector_Length);
	         Check (Two_Norm (X), 1.0, "two_norm (0x0)", 
			0.0, Vector_Length);
	         Check (One_Norm (Y), 1.0, "one_norm (0y0)", 
			0.0, Vector_Length);
	         Check (Inf_Norm (Y), 1.0, "inf_norm (0y0)", 
			0.0, Vector_Length);
	         Check (Two_Norm (Y), 1.0, "two_norm (0y0)", 
			0.0, Vector_Length);
	       end loop;

               V := (1..Vector_Length => (3.0, 4.0));

               -- error in One_Norm is 3*N*ME for abs computation +
               --  (N-1)*ME for the additions
               -- which gives (4N-1) * ME
	       Check (One_Norm (V), 5.0 * Real (Vector_Length), 
		      "one_norm ((3,4))", 
		      Real (4*Vector_Length - 1), 
		      Vector_Length);

               -- error in Inf_Norm is from abs of single element (3ME)
	       Check (Inf_Norm (V), 5.0, 
		      "inf_norm ((3,4))", 
		      3.0, 
		      Vector_Length);

               -- error in following comes from:
               --   2ME in sqrt of expected result
               --   3ME in Inf_Norm calculation
               --   2ME in sqrt of vector calculation
               --   vector calculation has following error
               --      3N*ME for abs
               --       N*ME for squaring
               --       N*ME for division
               --       (N-1)ME for sum
               -- this results in [2 + 3 + 2(6N-1) ] * ME
               -- or (12N + 3)ME
	       Check (Two_Norm (V), 5.0 * Sqrt (Real(Vector_Length)), 
                      "two_norm ((3,4))", 
		      (12.0 * Real (Vector_Length) + 3.0), 
		      Vector_Length);
	    exception
	       when others => Report.Failed ("exception for complex " &
                                             "vector length" &
	                                     Integer'Image (Vector_Length) );
	    end;
	 end loop;
      end Do_Test;
   end Generic_Complex_Norm_Check;

   --=====================================================================

   generic
      type Real is digits <>;
   package Generic_Norm_Check is
      procedure Do_Test;
   end Generic_Norm_Check;

   -----------------------------------------------------------------------

   package body Generic_Norm_Check is
      package RNC is new Generic_Real_Norm_Check (Real);
      package CNC is new Generic_Complex_Norm_Check (Real);
      procedure Do_Test is
      begin
         RNC.Do_Test;
         CNC.Do_Test;
      end Do_Test;
   end Generic_Norm_Check;

   --=====================================================================

   package Float_Check is new Generic_Norm_Check (Float);

   type A_Long_Float is digits System.Max_Digits;
   package A_Long_Float_Check is new Generic_Norm_Check (A_Long_Float);

   -----------------------------------------------------------------------

begin
   Report.Test ("CXG2009",
                "Check the accuracy of the real sqrt and complex " &
                " modulus functions"); 

   if Verbose then
      Report.Comment ("checking Standard.Float");
   end if;

   Float_Check.Do_Test;

   if Verbose then
      Report.Comment ("checking a digits" & 
                      Integer'Image (System.Max_Digits) &
                      " floating point type");
   end if;

   A_Long_Float_Check.Do_Test;

   Report.Result;
end CXG2009;