-- ----------------------------------------------------------------------- -- Title: test_relerr_alg -- Last Mod: Fri Mar 29 07:49:12 1991 -- Author: Vincent Broman -- Description: -- ----------------------------------------------------------------------- with random_number, float_types, single_algebraic_functions, double_algebraic_functions, test_relerr_1, text_io; use float_types, text_io; procedure test_relerr_alg is -- package salg renames single_algebraic_functions; package dalg renames double_algebraic_functions; subtype real is single; subtype long_real is double; niter: integer; rand_seed1, rand_seed2: integer; two_eps: constant long_real := long_real( 2.0 * real'base'epsilon); four_eps: constant long_real := long_real( 4.0 * real'base'epsilon); eight_eps: constant long_real := long_real( 8.0 * real'base'epsilon); small: constant real := real'base'safe_small; big: constant real := real'base'safe_large; half_mant: constant real := 6433.0; avg_err, max_err, worst_arg: long_real; package sfio is new text_io.float_io( real); use sfio; package dfio is new text_io.float_io( long_real); use dfio; package iio is new text_io.integer_io( integer); use iio; procedure report_header is begin -- twelve-space fields below, one line per tested functions put( "func name requ'd eps avg_err/eps max_err/eps worst_arg"); new_line; end report_header; procedure report( name: string; eps: in long_real; avg_err: in long_real; max_err: in long_real; worst_arg: in long_real) is -- field_size: constant integer := 12; blanks: string( 1 .. field_size) := " "; begin put( name); put( blanks( 1 .. field_size - name'length)); put( eps, 1, field_size-7, 2); put( " "); put( avg_err, 1, field_size-3, 0); put( " "); put( max_err, 1, field_size-3, 0); put( " "); put( worst_arg, 1, real'base'digits+1, 2); new_line; end report; -- hypot has two args, just fix one at 10**20 . function salg_hypot( y: in real) return real is begin return salg.hypot( 1.0e20, y); end salg_hypot; function dalg_hypot( y: in long_real) return long_real is begin return dalg.hypot( 1.0e20, y); end dalg_hypot; function salg_cube_root( y: in real) return real is begin return salg.cube_root( y); end salg_cube_root; function dalg_cube_root( y: in long_real) return long_real is begin return dalg.cube_root( y); end dalg_cube_root; function salg_nth_root( y: in real) return real is begin return salg.nth_root( y, 389); end salg_nth_root; function dalg_nth_root( y: in long_real) return long_real is begin return dalg.nth_root( y, 389); end dalg_nth_root; procedure test_square is new test_relerr_1( real, long_real, salg.square, dalg.square, two_eps, exp_dist_arg=> true); procedure test_square_root is new test_relerr_1( real, long_real, salg.square_root, dalg.square_root, two_eps, exp_dist_arg=> true); procedure test_cube_root is new test_relerr_1( real, long_real, salg_cube_root, dalg_cube_root, two_eps, exp_dist_arg=> true); procedure test_nth_root is new test_relerr_1( real, long_real, salg_nth_root, dalg_nth_root, two_eps, exp_dist_arg=> true); procedure test_hypot is new test_relerr_1( real, long_real, salg_hypot, dalg_hypot, two_eps, exp_dist_arg=> true); procedure test_complement is new test_relerr_1( real, long_real, salg.complement, dalg.complement, two_eps, exp_dist_arg=> false); procedure test_tan_to_sec is new test_relerr_1( real, long_real, salg.tan_to_sec, dalg.tan_to_sec, two_eps, exp_dist_arg=> true); procedure test_sec_to_tan is new test_relerr_1( real, long_real, salg.sec_to_tan, dalg.sec_to_tan, two_eps, exp_dist_arg=> true); begin -- test_relerr_alg put( "Test of relative accuracy of single-arg algebraic functions."); new_line; new_line; put( "Enter the number of Monte Carlo trials to perform for each fn."); new_line; get( niter); put( "number of trials for each function= "); put( niter); new_line; put( "Enter two integer seeds for the random number generation."); new_line; get( rand_seed1); get( rand_seed2); put( "random number seeds= "); put( rand_seed1); put( ", "); put( rand_seed2); new_line; random_number.start( rand_seed1, rand_seed2); report_header; test_square( niter, small, salg.square_root( big), avg_err, max_err, worst_arg); report( "square", two_eps, avg_err, max_err, worst_arg); test_square_root( niter, small, big, avg_err, max_err, worst_arg); report( "square_root", two_eps, avg_err, max_err, worst_arg); test_cube_root( niter, small, big, avg_err, max_err, worst_arg); report( "cube_root", two_eps, avg_err, max_err, worst_arg); test_cube_root( niter, -small, -big, avg_err, max_err, worst_arg); report( "cube_root-", two_eps, avg_err, max_err, worst_arg); test_nth_root( niter, small, big, avg_err, max_err, worst_arg); report( "389th_root", two_eps, avg_err, max_err, worst_arg); test_hypot( niter, small, big, avg_err, max_err, worst_arg); report( "hypot(1e20,*)", two_eps, avg_err, max_err, worst_arg); test_complement( niter, -1.0, 1.0, avg_err, max_err, worst_arg); report( "complement", two_eps, avg_err, max_err, worst_arg); test_tan_to_sec( niter, small, big, avg_err, max_err, worst_arg); report( "tan_to_sec", two_eps, avg_err, max_err, worst_arg); test_tan_to_sec( niter, -small, -big, avg_err, max_err, worst_arg); report( "tan_to_sec-", two_eps, avg_err, max_err, worst_arg); test_sec_to_tan( niter, 1.0, big, avg_err, max_err, worst_arg); report( "sec_to_tan", two_eps, avg_err, max_err, worst_arg); test_sec_to_tan( niter, -1.0, -big, avg_err, max_err, worst_arg); report( "sec_to_tan-", two_eps, avg_err, max_err, worst_arg); put( "Test done."); new_line; new_line; end test_relerr_alg;