home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
PASCAL
/
TPL60N19
/
TESTPRGS
/
DPOWER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-02-14
|
10KB
|
339 lines
PROGRAM DPower; { converted from Fortran original 05-01-92 Norbert Juffa }
{$A+,B-,D-,E+,F-,G-,I-,L-,N-,O-,R-,S-,V-,X-}
USES MachArit, Power;
{
C PROGRAM TO TEST POWER FUNCTION (**)
C
C DATA REQUIRED
C
C NONE
C
C SUBPROGRAMS REQUIRED FROM THIS PACKAGE
C
C MACHAR - AN ENVIRONMENTAL INQUIRY PROGRAM PROVIDING
C INFORMATION ON THE FLOATING-POINT ARITHMETIC
C SYSTEM. NOTE THAT THE CALL TO MACHAR CAN
C BE DELETED PROVIDED THE FOLLOWING SIX
C PARAMETERS ARE ASSIGNED THE VALUES INDICATED
C
C IBETA - THE RADIX OF THE FLOATING-POINT SYSTEM
C IT - THE NUMBER OF BASE-IBETA DIGITS IN THE
C SIGNIFICAND OF A FLOATING-POINT NUMBER
C MINEXP - THE LARGEST IN MAGNITUDE NEGATIVE
C INTEGER SUCH THAT DFLOAT(IBETA)**MINEXP
C IS A POSITIVE FLOATING-POINT NUMBER
C MAXEXP - THE LARGEST POSITIVE INTEGER EXPONENT
C FOR A FINITE FLOATING-POINT NUMBER
C XMIN - THE SMALLEST NON-VANISHING FLOATING-POINT
C POWER OF THE RADIX
C XMAX - THE LARGEST FINITE FLOATING-POINT
C NUMBER
C
C REN(K) - A FUNCTION SUBPROGRAM RETURNING RANDOM REAL
C NUMBERS UNIFORMLY DISTRIBUTED OVER (0,1)
C
C
C STANDARD FORTRAN SUBPROGRAMS REQUIRED
C
C DABS, DLOG, DMAX1, DEXP, DFLOAT, DSQRT
C
C
C LATEST REVISION - DECEMBER 6, 1979
C
C AUTHOR - W. J. CODY
C ARGONNE NATIONAL LABORATORY
C
C
}
FUNCTION REN (K: LONGINT): REAL;
{
DOUBLE PRECISION FUNCTION REN(K)
C
C RANDOM NUMBER GENERATOR - BASED ON ALGORITHM 266 BY PIKE AND
C HILL (MODIFIED BY HANSSON), COMMUNICATIONS OF THE ACM,
C VOL. 8, NO. 10, OCTOBER 1965.
C
C THIS SUBPROGRAM IS INTENDED FOR USE ON COMPUTERS WITH
C FIXED POINT WORDLENGTH OF AT LEAST 29 BITS. IT IS
C BEST IF THE FLOATING POINT SIGNIFICAND HAS AT MOST
C 29 BITS.
C
}
VAR J: LONGINT;
CONST IY: LONGINT = 100001;
BEGIN
J := K;
IY := IY * 125;
IY := IY - (IY DIV 2796203) * 2796203;
REN:= 1.0 * (IY) / 2796203.0e0 * (1.0e0 + 1.0e-6 + 1.0e-12);
END;
FUNCTION MAX1 (A, B:REAL): REAL;
BEGIN
IF A > B THEN
MAX1 := A
ELSE
MAX1 := B;
END;
VAR I,IBETA,IEXP,IOUT,IRND,
IT,I1,J,K1,K2,K3,MACHEP,
MAXEXP,MINEXP,N,NEGEP,NGRD: LONGINT;
A,AIT,ALBETA,ALXMAX,B,BETA,
C,DEL,DELY,EPS,EPSNEG,ONE,
ONEP5,R6,R7,SCALE,TWO,W,
X,XL,XMAX,XMIN,XN,XSQ,X1,
Y,Y1,Y2,Z,ZERO,TEN,THREE,
ZZ,ONEHUNDREDTH: REAL;
LABEL 50,70,110,120,210,215,220,300;
BEGIN
N := 1000000; { number of trials }
MACHAR (IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,
EPS,EPSNEG,XMIN,XMAX);
PRINTPARAM (IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,
EPS,EPSNEG,XMIN,XMAX);
BETA := IBETA;
ALBETA := LN (BETA);
AIT := IT;
ALXMAX := LN (XMAX);
ZERO := 0;
ONE := 1;
TWO := 2;
THREE := 3;
TEN := 10;
ONEHUNDREDTH:= 0.01;
ONEP5 := (TWO + ONE) / TWO;
SCALE := ONE;
J := (IT+1) DIV 2;
FOR I := 1 TO J DO BEGIN
SCALE := SCALE * BETA;
END;
A := ONE / BETA;
B := ONE;
C := -MAX1 (ALXMAX, -LN(XMIN))/ LN(100.0);
DELY := -C - C;
XN := N;
I1 := 0;
Y1 := ZERO;
{-----------------------------------------------------------------
C RANDOM ARGUMENT ACCURACY TESTS
C-----------------------------------------------------------------}
FOR J := 1 TO 4 DO BEGIN
K1 := 0;
K3 := 0;
X1 := ZERO;
R6 := ZERO;
R7 := ZERO;
DEL:= (B - A) / XN;
XL := A;
FOR I := 1 TO N DO BEGIN
X := DEL * REN(I1) + XL;
IF (J <> 1) THEN
GOTO 50;
ZZ := POW (X, ONE);
Z := X;
GOTO 110;
50: W := SCALE * X;
X := (X + W);
X := X - W;
XSQ:= X * X;
IF (J = 4) THEN
GOTO 70;
ZZ := POW (XSQ, ONEP5);
Z := X * XSQ;
GOTO 110;
70: Y := DELY * REN(I1) + C;
Y2 := Y / TWO;
Y2 := Y2 + Y;
Y2 := Y2 - Y;
Y := Y2 + Y2;
Z := Pow (X, Y);
ZZ := Pow (XSQ, Y2);
110: IF Z <> ZERO THEN
W := (Z - ZZ) / Z
ELSE IF ZZ <> ZERO THEN
W := ONE;
IF W > ZERO THEN
K1 := K1 + 1;
IF W < ZERO THEN
K3 := K3 + 1;
W := ABS (W);
IF W <= R6 THEN
GOTO 120;
R6 := W;
X1 := X;
IF J = 4 THEN
Y1 := Y;
120: R7 := R7 + W * W;
XL := XL + DEL;
END;
K2 := N - K3 - K1;
R7 := SQRT (R7/XN);
IF J > 1 THEN
GOTO 210;
WRITELN;
WRITELN;
WRITELN ('TEST OF X**1.0 VS X');
WRITELN;
WRITELN (N, ' RANDOM ARGUMENTS WERE TESTED FROM THE INTERVAL');
WRITELN ('(', A, ',', B, ')');
WRITELN;
WRITELN ('X**1.0 WAS LARGER', K1:6, ' TIMES');
WRITELN (' AGREED', K2:6, ' TIMES');
WRITELN (' AND WAS SMALLER', K3:6, ' TIMES');
GOTO 220;
210: IF J = 4 THEN
GOTO 215;
WRITELN;
WRITELN;
WRITELN ('TEST OF XSQ**1.5 VS XSQ*X');
WRITELN;
WRITELN (N, ' RANDOM ARGUMENTS WERE TESTED FROM THE INTERVAL');
WRITELN ('(', A, ',', B, ')');
WRITELN;
WRITELN ('X**1.5 WAS LARGER', K1:6, ' TIMES');
WRITELN (' AGREED', K2:6, ' TIMES');
WRITELN (' AND WAS SMALLER', K3:6, ' TIMES');
GOTO 220;
215: WRITELN;
WRITELN;
WRITELN ('TEST OF X**Y VS XSQ**(Y/2)');
W := C + DELY;
WRITELN;
WRITELN (N, ' RANDOM ARGUMENTS WERE TESTED FROM THE REGION');
WRITELN ('X IN (', A, ',', B, '),');
WRITELN ('Y IN (', C, ',', W, ')');
WRITELN;
WRITELN (' X**Y WAS LARGER', K1:6, ' TIMES');
WRITELN (' AGREED', K2:6, ' TIMES');
WRITELN (' AND WAS SMALLER', K3:6, ' TIMES');
220: WRITELN;
WRITELN ('THERE ARE ', IT, ' BASE ', IBETA,
' SIGNIFICANT DIGITS IN A FLOATING-POINT NUMBER');
WRITELN;
W := -999;
IF R6 <> ZERO THEN
W := LN (ABS(R6))/ALBETA;
WRITELN ('THE MAXIMUM RELATIVE ERROR OF ', R6:12,
' = ', IBETA, ' **', W:7:2);
WRITELN ('OCCURED FOR X = ', X1);
W := MAX1 (AIT+W,ZERO);
WRITELN;
WRITELN ('THE ESTIMATED LOSS OF BASE ', IBETA,
' SIGNIFICANT DIGITS IS ', W:7:2);
W := -999.0;
IF (R7 <> ZERO) THEN
W := LN (ABS(R7))/ALBETA;
WRITELN;
WRITELN ('THE ROOT MEAN SQUARE RELATIVE ERROR WAS', R7:12,
' = ', IBETA, ' **' , W:7:2);
W := MAX1 (AIT+W,ZERO);
WRITELN;
WRITELN ('THE ESTIMATED LOSS OF BASE ', IBETA,
' SIGNIFICANT DIGITS IS ', W:7:2);
IF J = 1 THEN
GOTO 300;
B := TEN;
A := ONEHUNDREDTH;
IF J = 3 THEN
GOTO 300;
A := ONE;
B := EXP (ALXMAX/THREE);
300:
END;
{-----------------------------------------------------------------}
{ SPECIAL TESTS }
{-----------------------------------------------------------------}
WRITELN;
WRITELN;
WRITELN ('SPECIAL TESTS');
WRITELN;
WRITELN ('THE IDENTITY X ** Y = (1/X) ** (-Y) WILL BE TESTED.');
WRITELN;
WRITELN (' X Y X**Y-(1/X)**(-Y)/X**Y ');
B := TEN;
FOR I := 1 TO 5 DO BEGIN
X := REN(I1) * B + ONE;
Y := REN(I1) * B + ONE;
Z := POW (X, Y);
ZZ:= POW ((ONE/X), (-Y));
W := (Z - ZZ) / Z;
WRITELN (X:18, Y:18, W:18);
END;
{-----------------------------------------------------------------}
{ TEST OF ERROR RETURNS }
{-----------------------------------------------------------------}
WRITELN;
WRITELN;
WRITELN ('TEST OF ERROR RETURNS');
X := BETA;
Y := MINEXP;
WRITELN;
WRITELN ('(', X, ') ** (', Y, ') WILL BE COMPUTED.');
WRITELN ('THIS SHOULD NOT TRIGGER AN ERROR MESSAGE.');
Z := POW (X, Y);
WRITELN ('THE VALUE RETURNED IS: ', Z);
Y := (MAXEXP-1);
WRITELN;
WRITELN ('(', X, ') ** (', Y, ') WILL BE COMPUTED.');
WRITELN ('THIS SHOULD NOT TRIGGER AN ERROR MESSAGE.');
Z := POW (X, Y);
WRITELN ('THE VALUE RETURNED IS: ', Z);
X := ZERO;
Y := TWO;
WRITELN;
WRITELN ('(', X, ') ** (', Y, ') WILL BE COMPUTED.');
WRITELN ('THIS SHOULD NOT TRIGGER AN ERROR MESSAGE.');
Z := POW (X, Y);
WRITELN ('THE VALUE RETURNED IS: ', Z);
X := -Y;
Y := ZERO;
WRITELN;
WRITELN ('(', X, ') ** (', Y, ') WILL BE COMPUTED.');
WRITELN ('THIS SHOULD TRIGGER AN ERROR MESSAGE.');
Z := POW (X, Y);
WRITELN ('THE VALUE RETURNED IS: ', Z);
Y := TWO;
WRITELN;
WRITELN ('(', X, ') ** (', Y, ') WILL BE COMPUTED.');
WRITELN ('THIS SHOULD TRIGGER AN ERROR MESSAGE.');
Z := POW (X, Y);
WRITELN ('THE VALUE RETURNED IS: ', Z);
X := ZERO;
Y := ZERO;
WRITELN;
WRITELN ('(', X, ') ** (', Y, ') WILL BE COMPUTED.');
WRITELN ('THIS SHOULD TRIGGER AN ERROR MESSAGE.');
Z := POW (X, Y);
WRITELN ('THE VALUE RETURNED IS: ', Z);
WRITELN;
WRITELN ('THIS CONCLUDES THE TESTS');
END. { DPower }