C - FOCAL MULTIPLE PRECISION PACKAGE.
C-FOCAL	v3A(222)-1	2102	28-AUG-73
ERASE ALL,

1.01	TYPE !!"IN ORDER TO USE THE MULTIPLE-PRECISION PACKAGE,"
1.02	TYPE !"CREATE A FOCAL APPLICATIONS PROGRAM IN GROUPS 1-39,"
1.03	TYPE !"THEN CALL IN THE PACKAGE, AND RUN THE COMBINATION."!
1.04	QUIT

40.01	C - INITIALIZE PARAMETERS AND CONSTANTS
40.10	S N=6 ;C - NUMBER OF WORDS OF PRECISION.
40.11	C - ITEM 0 IS THE SIGN/OVERFLOW WORD.
40.12	C - ITEM N+1 IS THE REMAINDER WORD.
40.20	S M=2^24 ;C - MODULO OF WORDS OF PRECISION
40.21	C - M*M*N MUST NOT OVERFLOW WORD LENGTH.
40.30	S P=0 ;C - STACK POINTER ;C - STACK IS A(P,I)
40.40	S U=1 ;C - INDEX OF WORD WITH DECIMAL POINT AT THE RIGHT OF IT.
40.50	C - ARG = SINGLE-WORD ARGUMENT.
40.60	X FOCAL(2,2);T%3;ERASE 41.01,42.01,43.01,44.01,45.01,46.01,47.01,48.01,49.01,50.01,51.01,52.01,53.01,54.01,55.01,56.01,57.01,58.01,59.01

41.01	C - CREATE A NUMBER WITH VALUE ARG.
41.10	S P=P+1,T1=N+1,T3=0;IF FABS(ARG) 41.2,41.2;S T1=U-FITR(FLOG(FABS(ARG))/FLOG(M)),T3=ARG*M^(T1-U)
41.20	F T2=0,T1-1;S A(P,T2)=0
41.30	F T2=T1,N+1;S A(P,T2)=FITR(T3),T3=M*(T3-FITR(T3))

42.01	C - ADD TOP NUMBER INTO SECOND TOP.
42.10	S P=P-1,T2=0;F T1=N,-1,1;S T3=T2+A(P,T1)+A(P+1,T1),T2=FITR(T3/M),A(P,T1)=T3-M*T2
42.20	S A(P,0)=T2

43.01	C - SUBTRACT TOP NUMBER INTO SECOND TOP.
43.10	S P=P-1,T2=0;F T1=N,-1,1;S T3=T2+A(P,T1)-A(P+1,T1),T2=FITR(T3/M),A(P,T1)=T3-M*T2
43.20	S A(P,0)=T2

44.01	C - SCALE (MULTIPLY) TOP NUMBER BY INTEGER, ARG.
44.10	S T2=0;F T1=N,-1,1;S T3=T2+A(P,T1)*ARG,T2=FITR(T3/M),A(P,T1)=T3-M*T2
44.20	S A(P,0)=T2

45.01	C - DIVIDE TOP NUMBER BY INTEGER, ARG.
45.10	S T2=0;F T1=1,N;S T3=FITR((T2*M+A(P,T1))/ARG),T2=T2*M+A(P,T1)-ARG*T3,A(P,T1)=T3
45.20	S A(P,N+1)=T2

46.01	C - MULTIPLY TOP NUMBER INTO SECOND TOP
46.10	S T4=P-1;F T5=1,N;D 47;S ARG=A(T4,T5);D 44,48
46.20	F T5=1-U,2*N-U;S A(T4,T5)=0
46.30	F T5=1,N;F T1=0,N;S A(T4,T1+T5-U)=A(T4,T1+T5-U)+A(T4+T5,T1)
46.40	S P=T4,T2=0;F T1=2*N-U,-1,-U;S T3=A(P,T1)+T2,T2=FITR(T3/M),A(P,T1)=T3-M*T2

47.01	C - COPY ONE NUMBER TO MAKE A NEW ENTRY, INDEX P
47.10	S P=P+1;F T1=1,N;S A(P,T1)=A(P-1,T1)

48.01	C - INTERCHANGE TOP AND SECOND TOP
48.10	F T1=1,N;S T2=A(P,T1),A(P,T1)=A(P-1,T1),A(P-1,T1)=T2

51.01	C - CREATE LOGARITHM OF TOP ENTRY AS A NEW ENTRY.
51.10	C - NUMBER >= 1
51.20	S POW=0;D 47,53;I -ARG 51.3;Z "ILLEGAL LOGARITHM ARGUMENT".
51.30	I ARG-1.05 51.4;S POW=POW+1;D 55,48,57,53;G 51.30
51.40	S ARG=1;D 41,48,43,47,47;S ITER=1
51.50	S ARG=P-1;D 56;S ARG=P-3;D 56,46,51.9,53;I -FABS(ARG) 51.6;D 57,43;S ARG=2^POW;D 44;R
51.60	S ITER=ITER+1,ARG=ITER;D 45,42;G 51.5
51.90	F T1=1,N;S A(P-2,T1)=A(P,T1)

52.01	C - TYPE OUT TOP NUMBER IN RADIX RAD
52.05	S RAD=FITR(RAD+.5);I -RAD 52.1;S RAD=10;C - DEFAULT DECIMAL.
52.10	D 47,53;F T1=U,-1,1;S A(P,N+T1-U)=A(P,T1)*FSGN(ARG)
52.20	F T1=0,N-U;S A(P,T1)=0
52.30	S ND=0;I -ARG 52.4,52.4;T "-"
52.40	S ND=ND+1,ARG=RAD;D 45,53;S CH(ND)=A(P,N+1);I -FABS(ARG) 52.4
52.50	F T1=ND,-1,1;X FCHR(CH(T1)+48)
52.60	T ".";S ND=(N-U)*FLOG(M)/FLOG(RAD)
52.70	D 57,47;F T7=1,ND;S A(P,U)=0,ARG=RAD;D 44;X FCHR(A(P,U)+48)
52.80	D 57

53.01	C - RETURN VALUE OF TOP NUMBER IN ARG.
53.10	S ARG=0;F T1=1,N;S ARG=ARG+A(P,T1)*M^(U-T1)

54.01	C - ACCEPT A (POSITIVE) (FIXED-POINT) NUMBER TYPED IN, TO CREATE A NEW NUMBER
54.05	I -RAD 54.1;S RAD=10
54.10	S T4=1,ARG=0;D 41
54.20	S CH=FCHR(-1);I CH-46 54.9,54.6;I CH-48 54.9;I 57-CH 54.9;S ARG=RAD;D 44;S ARG=CH-48;D 41,42;G 54.2
54.60	S CH=FCHR(-1);I (CH-48)*(57-CH) 54.9;S ARG=CH-48;D 41;F T8=1,T4;S ARG=RAD;D 45
54.70	D 42;S T4=T4+1;G 54.6
54.90	IF CH-13 54.99,54.91,54.99
54.91	X FCHR(-1);C - SWALLOW LINE-FEED AFTER CARRIAGE-RETURN
54.99	RETURN

55.01	C - CREATE SQUARE ROOT OF TOP NUMBER AS A NEW NUMBER.
55.10	D 53;S ARG=FSQT(ARG),TSQ=2*ARG;D 41
55.20	D 47,47,46;S ARG=P-2;D 56,43;S ARG=TSQ;D 45,53,43;I -FABS(ARG) 55.2

56.01	C - COPY ONE NUMBER TO MAKE A NEW ENTRY, INDEX ARG.
56.10	S P=P+1;F T1=1,N;S A(P,T1)=A(ARG,T1)

57.01	C - DELETE TOP ENTRY
57.10	S P=P-1

58.01	C - TYPE OUT TOP NUMBER IN DECIMAL
58.10	D 47,53;F T1=U,-1,1;S A(P,N+T1-U)=A(P,T1)*FSGN(ARG)
58.20	F T1=0,N-U;S A(P,T1)=0
58.30	S ND=0;I -ARG 58.4,58.4;T "-"
58.40	S ND=ND+1,ARG=10;D 45,53;S CH(ND)=A(P,N+1);I -FABS(ARG) 58.4
58.50	F T1=ND,-1,1;X FCHR(CH(T1)+48)
58.60	T ".";S ND=(N-U)*LOG10(M)
58.70	D 57,47;F T7=1,ND;S A(P,U)=0,ARG=10;D 44;X FCHR(A(P,U)+48)
58.80	D 57

59.01	C - TYPE OUT TOP NUMBER IN OCTAL
59.10	D 47,53;F T1=U,-1,1;S A(P,N+T1-U)=A(P,T1)*FSGN(ARG)
59.20	F T1=0,N-U;S A(P,T1)=0
59.30	S ND=0;I -ARG 59.4,59.4;T "-"
59.40	S ND=ND+1,ARG=8;D 45,53;S CH(ND)=A(P,N+1);I -FABS(ARG) 59.4
59.50	F T1=ND,-1,1;X FCHR(CH(T1)+48)
59.60	T ".";S ND=(N-U)*FLOG(M)/FLOG(8)
59.70	D 57,47;F T7=1,ND;S A(P,U)=0,ARG=8;D 44;X FCHR(A(P,U)+48)
59.80	D 57

TYPE !"FOCAL MULTIPLE-PRECISION PACKAGE."!
TYPE !"	THIS PACKAGE IS A COLLECTION OF SUBROUTINES"
TYPE !"WHICH MUST BE CALLED BY AN APPLICATIONS PROGRAM"
TYPE !"USING THE FOCAL 'DO' COMMAND."
TYPE !"THE APPLICATIONS PROGRAM IS RESPONSIBLE FOR"
TYPE !"SETTING UP THE ARGUMENTS FOR EACH SUBROUTINE AND"
TYPE !"FOR MODIFYING AND CALLING GROUP 40 PRIOR TO INITIAL USE."
TYPE !!"	THE PACKAGE USES VARIABLES"
TYPE !"ARG, ITER, N, ND, M, P, POW, RAD, TSQ, T1,T2,T3,T4,T5,T6,T7,T8 AND V."
TYPE !"ARRAYS A(..,..) AND CH(..) ARE ALSO USED."
TYPE !!"	THE ARRAY A(..,..) IS USED IN THE FORM OF A PUSH-DOWN STACK."
TYPE !"THE PACKAGE INCLUDES ADDITION, SUBTRACTION, MULTIPLICATION,"
TYPE !"DIVISION BY INTEGER, STACK MANIPULATION (DUPLICATE, INTERCHANGE,"
TYPE !"DELETE TOP ENTRIES), LOGARITHM, SQUARE ROOT AND DATA ENTRY AND"
TYPE !"TYPE-OUT IN OCTAL AND DECIMAL."
GO