File: FLT875.PA of Tape: Sources/Focal/s7
(Source file text)
IFNZRO FLTLST <XLIST> IFZERO FFNASS < EJECT OS-8 FLOATING POINT ETC. /&1 /FIELD 1 PART OF THE FOURIER FUNCTION /FOURIER FUNCTION ; CALL S Z=FOUR(SI')',SF,SS) /SI : INITIAL FREQUENCY VALUE (DEFAULT 0) /SF : FINAL FREQUENCY VALUE (DEFAULT 127) /SS : FREQUENCY STEP (DEFAULT 0.5) /THESE FREQUENCY VALUES CAN BE SPECIFIED IN STEPS OF .125 FIELD 1 *4400 XXX, CLA CLL IAC RTL /4 IN AC TAD EXP DCA EXP /SI TIMES 16 JMS I INTEGE DCA FOUS PUSHJ EVAL-1 CLA CLL IAC RTL /4 IN AC TAD EXP /SS TIMES 16 DCA EXP /STEP SIZE DIVIDEABLE BY 16 JMS I INTEGE SNA /TEST FOR TOO SMALL STEP(0 OR .LT.1/16) ERROR4 DCA FOUSS CLA CLL CML RTR /CONSTANT 2000 DCA FOUCOM CIF CDF L JMP I DFOUEX DFOUEX, FOUEXP DFOUJ0, FOUJ0 FEPTEN, PTEN FECONT, 0 *4427 /&2 FOUX0, FINT /ZEROLIZE SUM-REGISTERS FGET I CFRSX FPUT FOUREA FPUT FOUIMA FEXT CIF CDF L JMP I DFOUJ0 /GO CALCULATE FIRST PRODUCT /FLOATING POINT ANTEIL VON SC-FELD FEDIV, SZL JMP FEPOS JMS I MINSKI FEPOS, FINT FNOR FMUL I FEPTEN FEXT ISZ FECONT JMP FEPOS RETURN *4456 /&3 FOUNS, TAD FOUREA /NEXT FREQUENCY S DCA FOUREA+2 /CHANGE FROM EAE FORMAT TO FLOATING TAD P13 DCA FOUREA /YET TO BE NORMALIZED TAD FOUIMA DCA FOUIMA+2 TAD P13 DCA FOUIMA FINT /CALCULATE POWER F(S) FGET FOUREA /F(S)=R^2 + I^2 FNOR FPUT FOUREA FMUL FOUREA FPUT FOUREA FGET FOUIMA FNOR FPUT FOUIMA FMUL FOUIMA FADD FOUREA FEXT CDF L TAD EXP /PUT RESULT IN FCOM DCA I FOUCOM ISZ FOUCOM TAD HORD DCA I FOUCOM ISZ FOUCOM CDF P TAD FOUCOM /END OF ROUTINE NOW TESTED BY FCOM TAD FOUCMM /SO ALWAYS 256 STEPS ARE CALCULATED SMA CLA /AND FOUR CAN'T WRITE BEYOND FCOM-MAX JMP I EFUN3I TAD FOUS TAD FOUSS DCA FOUS JMP FOUX0 /TO NEW SUMS FOUREA, 0 0 0 0 FOUIMA, 0 0 0 0 FOUS, 0 FOUSS, 0 FOUCMM, -3000 FOUCOM, 0 /&3B /FIOP FUNCTION;12-BIT INPUT OUTPUT /S Z=FIOP(ARG) /ARG:0 READ 12 BITS FROM INPUT : OUT TO Z /ARG:+ SET OUTPUT WITH BITS\ /TOTAL OUTPUT BIT PATTERN TO Z /ARG:- CLEAR OUTPUT WITH BITS/ FIOP, JMS I INTEGE SZA CLA JMP .+5 DBRI /READ DBCI /CLEAR DBEI /ENABLE INTERRUPT JMP IOEXIT JMS I (ABSOLV /MAKES POSITIVE;STORES SIGN CLA CLL CML RAR /4000 AND SIGNF CLL RAL TAD LORD SNL JMP .+3 DBCO /CLEAR OUTPUT BITS SKP DBSO /SET OUTPUT BITS DBRO /READ OUTPUT IOEXIT, DCA LORD /NON SIGNED! DCA HORD /CLEAR TAD (27 DCA EXP JMP I EFUN3I LUX, JMS I INTEGE /SATELLITE FOR FIELD 3 CIF CDF 30 JMP I .+1 LUX3 EVAL1, PUSHJ EVAL-1 CIF CDF 30 JMP I .+1 EVAL3R PAGE /&4 /EXPONENTIAL GETSGN=TAD HORD RETURN=JMP I EFUN3I FEXP, GETSGN /TAKE ABSOLUTE VALUE SPA CLA JMS I NEGP DCA T3 /C(SIGN)=-1 IF I X2.L.0 FINT FMUL LG2E FPUT I X2 FEXT JMS I INTEGER DCA FLAG2 /SAVE LOX ORDER DATA FINT FNOR FPUT I XSQ2 FGET I X2 FSUB I XSQ2 FPUT I X2 FMUL I X2 FPUT I XSQ2 FADD DF FPUT TEMP FGET CF FDIV TEMP FSUB I X2 FADD AF FPUT TEMP FGET BF FMUL I XSQ2 FADD TEMP FPUT TEMP FGET I X2 FDIV TEMP FMUL TWO FADD ONE FEXT TAD FLAG2 TAD EXP DCA EXP ISZ T3 RETURN FINT FPUT I X2 FGET ONE FDIV I X2 FEXT RETURN /&5 /CONSTANTS FOR FEXP X2, X XSQ2, XSQR AF, 0004 2372 1402 BF, 7774 2157 5157 CF, 0012 5454 0343 DF, 0007 2566 5341 LG2E, 0001 2705 2435 ONE, 0001 2000 0000 TWO, 0002 2000 0000 NEGP, FNEG FLAG2, 0 TEMP, 0 0 0 0 PUSH1, 0 /CONNECTOR FOR FIELD 0 PUSHJ DCA .+2 PUSHJ 0 CIF CDF L JMP I PUSH1 PUSHFF, PUSHF /TO GET FLAC INTO FLD. 0 FLAC /TPUSHJ;PUSHFF;TPOPF;LOC POPJ MMINSK, JMS I MINSKI /FLD 0 MINSKI POPJ /TPUSHJ;MMINSK /&6 /MAIN ALGORITHM FOR ARCTANGENT ARCALG, FINT FGET I X2 FMUL I X2 FPUT I XSQ2 FMUL BET2 FADD BET1 FMUL I XSQ2 FADD BETZ FPUT TEMP FGET ALF2 FMUL I XSQ2 FADD ALF1 FMUL I XSQ2 FADD ALFZ FMUL I X2 FDIV TEMP FEXT JMP I .+1 ARCRTN /CONSTANTS - FLOATING ARC TANGENT ALFZ, 0000 2437 1643 ALF1, 7777 3304 4434 ALF2, 7773 3306 5454 BETZ, 0000 2437 1646 BET1, 0000 2427 2323 BET2, 7775 3427 7052 FILER, CIF L JMP I .+1 FILEST MAGNET, CIF CDF L JMP I .+1 FELD /&7 /FLOATING POINT ARC TANGENT *5000 ARTN, GETSGN /TAKE ABSOLUTE VALUE SPA CLA JMS FNEG DCA T3 FINT FPUT I X1 FSUB I CON1 FEXT GETSGN SPA CLA JMP GO /LESS THAN ONE FINT FGET I CON1 FDIV I X1 FPUT I X1 FEXT CLA CMA GO, DCA FLAG1 /SIGN FLAG OF RESULT JMP I .+1 ARCALG ARCRTN, ISZ FLAG1 /RETURN HERE JMP I EXIT1 FINT FPUT I X1 FGET I PI2 FSUB I X1 FEXT JMP I .+1 EXIT1, EXIT2 /CONSTANTS FOR ARCTANGENT X1, X PI2, PIOT CON1, ONE /&8 /FLOATING LOGARITHM FLOG, GETSGN SPA SNA ERROR3 /0 OR - ARGUMENT FOR LOG FINT FPUT I TEM FSUB I CON1 FEXT GETSGN SNA RETURN SMA CLA JMP STARTL FINT FGET I CON1 FDIV I TEM FPUT I TEM FEXT CLA CMA STARTL, DCA T3 TAD P13 DCA EXP CMA TAD I TEM DCA HORD DCA LORD DCA OVER2 IAC DCA I TEM FINT FMUL LOG2 FPUT I X1 FGET I TEM FSUB I CON1 FPUT I TEM FMUL LOG8 FADD LOG7 FMUL I TEM FADD LOG6 FMUL I TEM FADD LOG5 FMUL I TEM FADD L4 FMUL I TEM FADD L3 FMUL I TEM FADD L2 FMUL I TEM FADD L1 FMUL I TEM FADD I X1 FEXT JMP I EXIT1 /&9 L1, 0000 3777 7742 L2, 7777 4000 4100 L3, 7777 2517 0307 L4, 7776 4113 7211 /LOGARITHM CONSTANTS LOG5, 7776 2535 3301 LOG6, 7775 4746 0771 LOG7, 7774 2236 4304 LOG8, 7771 4544 1735 TEM, TEMP LOG2, 0 2613 4414 FLAG1, 0 FNEG, 0 JMS I MINSKI CLA CMA JMP I FNEG XPUSHA, 0 CIF L JMS I .+2 JMP I XPUSHA MPUSHA TERMER, 0 /CHECK FOR TERMINATOR (;,CR,SPACE OR ,) SORTC GLIST-1 ISZ TERMER CIF CDF L JMP I TERMER /&10 /FLOATING POINT SINE AND COSINE *5200 FCOS, FINT /COS(X)=SIN(PI/2-X) FPUT X FGET PIOT FSUB X FEXT FSIN, GETSGN SMA SZA CLA JMP MOD GETSGN SMA CLA RETURN /YES SIN(0)=0 JMS I MINSKI CMA /NO:SIN(-X)=-SIN(X) MOD, DCA T3 FINT FDIV TWOPI /REDUCE X MODULO 2 PI FPUT XSQR FEXT JMS I INTEGER FINT FNOR FPUT X FGET XSQR FSUB X FMUL TWOPI FPUT X FSUB PI /X .L. PI? FEXT GETSGN SPA CLA JMP PCHECK /YES FINT /NO, SIN(X-PI)=-SIN(X) FPUT X FEXT TAD T3 CMA DCA T3 /&11 PCHECK, FINT /X.L.PI/2? FGET X FSUB PIOT FEXT GETSGN SPA CLA JMP PALG /YES FINT /NO FGET PI /SIN(X)=SIN(PI-X) FSUB X FPUT X FEXT PALG, FINT FGET X FDIV PIOT FPUT X FMUL X FPUT XSQR FGET C9 FMUL XSQR FADD C7 FMUL XSQR FADD C5 FMUL XSQR FADD C3 FMUL XSQR FADD PIOT FMUL X FEXT EXIT2, ISZ T3 RETURN JMS I MINSKI RETURN /&12 /CONSTANTS AND POINTERS TWOPI, 0003 3110 3755 3235 PI, 0002 3110 3755 3235 PIOT, 0001 /USED BY SINE AND COSINE 3110 3755 3235 X, 0000 0 0 0 XSQR, 0 0 0 0 /SINE CONSTANTS C9, 7764 2501 7015 1042 C7, 7771 5464 5514 6150 C5, 7775 2431 5361 4736 C3, 0000 5325 0414 3167 /END OF EXTENDED FUCTIONS............. /&13 XTAB, PUSHJ EVAL-1 FENT FADD I TRND /LET'S ROUND OFF FEXT JMS I INTEGER CIA TAD TABC IAC SMA JMP BACK DCA CNTRX TAD SPACE PRINTC ISZ CNTRX JMP .-3 BACK, CLA CLL JMP I .+1 TASK TRND, FLP5 SPACE, 240 /&14 /INPUT-OUTPUT ROUTINES FOR THE /FOCAL FLOATING POINT PACKAGE /IN THE COMMENTS BELOW:- /F=NUMBER OF DIGITS TO BE OUTPUT =FISW /D=NUMBER OF DEZIMAL PLACES =DECP /E=DEZIMAL EXPONENT =BEXP /P=NUMBER OF PLACES REMAINING TO BE /PRINTED BEFORE DEZIMAL POINT *5400 DIGITS=12 /NUMBER OF DEZIMAL DIGITS OUT TGO, 0 DCA SCOUNT /SAVE MAX. NUMBER OF DIGITS AVAILABLE - SET COUNT TAD FISW AND FPRNT-1 BSW RAR DCA T1 TAD T1 CIA /NO, COMPUTE FIELD SIZES SNA TAD MD DCA FCOUNT TAD FISW /(JMP FPRNT) - FOR NO ROUNDING SNA /FLOATING OUTPUT ? JMP R6 /YES, ROUND UP TO MAX. NO. OF PLACES AND P77 DCA DECP TAD FCOUNT TAD DECP SPA /F-D .G. 0 ? JMP .+5 /YES CLA CMA /NO TAD T1 DCA DECP /MAKE D=F-1 CMA TAD T3 /COMPARE DEZ. EXPONENT SMA /F-D .G. E ? CLA /NO, ROUND OF TO .F PLACES TAD T1 /YES SPA /D+E.L.0 ? JMP FPRNT-2 /YES, NO ROUNDING NEEDED, GO TO PRINT TAD MD /NO, ROUND TO D+E PLACES SMA /TO A MAX OF D PLACES CLA /&15 R6, TAD RND2 /*ROUND UP* DCA T2 /SAVE NUMBER+1 OF PLACES TO ROUND TO TAD I BUFST TAD T2 /SET UP BUFFER ADDRESS AT WHICH DCA PLCE /ROUNDING OFF SHOULD START TAD T2 CIA /SETUP COUNT OF MAX NO DCA T2 /OF CARRIES ALLOWABLE TAD K5 /LITTLE EXTRA ON FIRST DIGIT RET, ISZ I PLCE /ADD ONE TO DIGIT AT CURRENT POSITION TAD I PLCE TAD OM12 SPA CLA /CARRY REQUIRED ? JMP FPRNT /NO, GO TO OUTPUT DCA I PLCE /YES, MAKE CURRENT DIGIT ZERO ISZ T2 /BEGIN OF BUF REACHED ? JMP DECR /NO, DECREMENT BUF ADDR. AND REPEAT ISZ I PLCE /YES, SET MANTISSA TO .1 ISZ T3 /COMPENSATE BY INCREMENTING EXP 7600 /CLA - REFERENCED FPRNT, TAD FISW /AUTO-INDEX REG ALREADY SET - *PRINT* SNA CLA /F=0 ? JMP FLOUT /YES, OUTPUT AS FLOAT NUMBER TAD FCOUNT TAD T3 SMA SZA /E .G. F ? JMP FLOUT-1 /YES, CONVERT TO E FORMAT TAD DECP SMA /E.L.F-D ? CLA /NO, P=E CIA /YES, TAKE P=F-D TAD T3 CIA DCA T1 /SETUP -P BACK1, TAD T3 /PRINT DD.DDD TAD T1 SNA CLA /B=E ? JMP DIG /YES, PRINT DIGIT TAD T1 /NO, IAC SPA CLA /P .G. 1 ? TAD M20 /YES, TAKE SPACE (240-260); OTHERWISE IN, JMS OUTA /ZERO PRINT CHARAKTER ISZ T1 /P CHARAKTERS PRINTED ? JMP BACK1 /NO TAD PER /YES PRINTC /PRINT DEZ POINT JMP BACK1 /&16 DECR, CMA /BACKUP TO TOP OF BUF TAD PLCE DCA PLCE JMP RET K5, 5 MD, -DIGITS RND2, DIGITS+1 OM12, -12 BUFST, SADR OPUT, OUTDG DECP, 0 /MODIFYABLE LOCATIONS SCOUNT, 0 FCOUNT, 0 PLCE=. OUTA, 0 /MODIFIED REGISTERS JMS I OPUT /PRINT CHAR ISZ FCOUNT /F CHARS PRINTED ? JMP I OUTA /NO, RETURN JMP I TGO /YES, NUMBER FINISHED DIG, CMA TAD T3 /REDUCE E BY ONE DCA T3 ISZ SCOUNT /ALL SIGNIFICANT FIGURES USED ? JMP .+4 /NO CMA /YES DCA SCOUNT /RESET COUNT TO -1 JMP IN /AND LEAVE C(AC)=0 TAD I FLTXR /TAKE NEXT DIGIT FROM BUF JMP IN /DO FLOATING OUTPUT,PLEASE CLA /IF OUTPUT TOO LARGE FLOUT, JMS I OPUT /PRINT "0" TAD PER PRINTC /PRINT "." ISZ TGO /2ND RETURN TAD I FLTXR /TAKE NEXT DIG FROM BUF JMS OUTA /PRINT IT ISZ SCOUNT /TEST FOR END OF INPUT JMP .-3 /AND REPEAT CMA DCA SCOUNT /OUTPUT EXTRA ZERO'S JMP .-5 RESOLV, 0 TAD SIGNF SPA CLA JMS I MINSKI JMP I RESOLV /&17 /DOUBLE PRECISION DEZIMAL BINARY /INPUT AND CONVERSION FOR + OR - XXX.... *5600 DECONV, 0 DCA LORD DCA EXP /ZERO THE EXP AND DCA HORD /INITIALIZE FLAC DCA OVER2 DCA DNUMBR DCA SIGNF TAD CHAR /ALLOW KEYBOARD SIGN CHECKS TAD MPLUS SNA JMP .+6 /PLUS SIGN; GET NEXT TAD M2 /CHECK MINUS SIGN SZA CLA JMP .+4 CMA /INIT SIGN CHECK TO POS. DCA SIGNF JMS I XINPUT /GET NEXT TAD CHAR /A SPACE PERHAPS ? TAD MSPACE SNA CLA JMP .-4 JMS DECON JMP I DECONV /&18 DECON, 0 TAD CHAR /TEST LEAD. CHAR FOR TERMINATOR TAD MINE SNA CLA JMP I DECON /E TESTN JMP I DECON /. JMP DTST /OTHER TAD SORTCN /N DSAVE, DCA DIGIT /YES JMS MULT10 /REMAIN MUST =0 SINCE OVERFL. IS CHECKED ISZ DNUMBR /COUNT DIGITS SZA CLA ERROR2 /INPUT OVERFL ERROR JMS I XINPUT JMP DECON+1 /CONTINUE DTST, TAD CHAR /ALLOW A-Z TAD MINUSA SPA CLA JMP I DECON TAD CHAR TAD MINUSZ SZA SMA CLA JMP I DECON /USE 6 BITS OF ASCII TAD CHAR AND P77 JMP DSAVE MINE, -305 MINUSZ, -332 MPLUS, -253 MSPACE, -240 XINPUT, INPUT /&19 MULT10, 0 /ROUTINE TO MULTIPLY FLAC BY 10 TAD OVER2 DCA OVER1 TAD LORD /DOUBLE PRECISION WORD DCA AC1L /BY 10(DEZ) TAD HORD /REMAIN=REMAINDER DCA AC1H DCA REMAIN /CLEAR OVERFLOW WORD JMS MULT2 /CALL SR TO JMS MULT2 /MULT BY 2 JMS DUBLAD /CALL DOUBLE ADD JMS MULT2 TAD DIGIT /ADD LAST DIGIT RECEIVED DCA OVER1 DCA AC1L DCA AC1H JMS DUBLAD TAD REMAIN /EXIT WITH REMAINDER JMP I MULT10 /IN AC REMAIN, 0 DIGIT, 0 /STORAGE FOR DIGIT DNUMBR, 0 /= NUMBER OF DIGITS MULT2, 0 /MULTIPLY OVER2, LORD, HORD BY TWO TAD OVER2 CLL RAL /CARRY INSERT BIT IS IN LINK DCA OVER2 TAD LORD RAL DCA LORD TAD HORD RAL DCA HORD TAD REMAIN RAL DCA REMAIN JMP I MULT2 /&20 DUBLAD, 0 /TRIPLE PRECISION ADDITION CLA CLL TAD OVER2 TAD OVER1 DCA OVER2 RAL TAD LORD TAD AC1L DCA LORD RAL TAD HORD TAD AC1H DCA HORD RAL TAD REMAIN DCA REMAIN JMP I DUBLAD DIV1, 0 /SHIFT OPERAND RIGHT CLA CLL /TRIPLE PRECISION TAD AC1H SPA CLL CML RAR DCA AC1H TAD AC1L RAR DCA AC1L TAD OVER1 RAR DCA OVER1 ISZ EX1 JMP I DIV1 JMP I DIV1 MGETC, 0 /GET FAKE FOR LOWER FIELD GETC CIF L JMP I MGETC /&21 /FLOATING OUTPUT CONVERSION ROUTINE *6000 FLOUTP, 0 TAD PEQ /IT'S A SPACE !! PRINTC /(CLA) - TO SUPPRESS TAD HORD /NUMBER .G. 0 ? SMA CLA TAD SMSP /PRINT "-" OR A SPACE TAD SMIN PRINTC JMS I ABSOL2 FGO2, DCA T3 /INITIALIZE DEZ EXP TAD EXP /IS EXP 0-4 ? SPA JMP FGO3 /TOO LARGE: MULT BY 1/10 SZA TAD M4 SPA SNA CLA JMP FGO4 FINT FMUL I PPTEN FEXT IAC TAD T3 JMP FGO2 FGO3, FINT FMUL I TENPT FEXT CMA JMP .-6 /&22 FGO4, DCA I DPT /MULTIPLY BY TWO TO POSITION BIT0 DCA I REPT /CLEAR OVERFLOW WORD TAD SADR /INIT BUFFER POINTER DCA FLTXR TAD EXP /COMPUTE BITS IN 1ST DIGIT CMA CLL DCA OUTDG /TEMP COUNT TAD DCOUNT /SETUP COUNT OF TOTAL OUTPUT DCA EXP JMS I DOUBLE /ROTATE OUT THE 1ST 4 BITS ISZ OUTDG JMP .-2 TAD I REPT /TEST FOR 10-15,0,1-9 SNA JMP FGO5 /IGNORE 1ST ZERO TAD FM12 SPA CLA JMP .+7 /0-9 IAC DCA I FLTXR /OUTPUT A 1 ISZ EXP /COUNT THE DIGIT TAD FM12 /CORRECT REMAINDER ISZ T3 /BUMP DECIMAL EXP NOP TAD I REPT /COMPUTE RESULTANT OR SECOND DIGIT ISZ T3 NOP SKP FGO5, JMS I M10PT /IE. .672X10=6+.72.. ETC. DCA I FLTXR ISZ EXP /ALL DIGITS OUTPUT?? JMP .-3 /NO:CONTINUE TAD SADR /INIT BUFFER POINTER DCA FLTXR TAD DCOUNT JMS I ROUND /OUTPUT MANTISSA JMP I FLOUTP /FIXED POINT DONE TAD CHRT /PRINT "E" PRINTC /&23 /OUTPUT THE EXPONENT TAD T3 /TAKE ABSOLUTE VALUE OF EXPONENT SPA CIA DCA HORD /SAVE + POWER TAD T3 /PRINT SIGN SMA CLA TAD M2 TAD SMIN PRINTC TAD HORD ISZ EXP TAD M144 SMA JMP .-3 TAD C144 DCA HORD /SAVE TENS AND UNITS CMA /OUTPUT HUNDREDS TAD EXP SZA /UNLESS ZERO JMS OUTDG TAD HORD /PRINT TWO DIGITS JMS I PRNTI JMP I FLOUTP PRNTI, PRNT CHRT, 305 /E SMSP, 240-255 PEQ, 240 /SPACE!!!!!! SMIN, 255 M144, -144 /-100 C144, 0144 /+100 M4, -4 FM12, -12 DCOUNT, -DIGITS-1 /NUMBER OF DIGITS TO OUTPUT PPTEN, PTEN /IEI DPT, DIGIT REPT, REMAIN /OVERFLOW FROM INTEGER MULTIPLY M10PT, MULT10 SADR, BUFFER-1 ROUND, TGO /ACTUAL OUTPUT ROUTINE TENPT, TEN ABSOL2, ABSOLV /&24 OUTDG, 0 /OUTPUT ONE DIGIT TAD C260 PRINTC JMP I OUTDG THISD, 0 CDF T TAD I THISLN CDF P JMP I THISD PT1D, 0 CDF T TAD I PT1 CDF P JMP I PT1D AXIND, 0 CDF T DCA I AXIN CDF P JMP I AXIND /&25 /FLOATING POINT INPUT *6200 FLINTP, 0 /IF C(AC)=0, USE CHAR SZA CLA /IF C(AC)#0, GET NEXT JMS I XIN /GET FIRST CHAR TAD CHAR /IGNORE LEADING SPACES TAD M240 SNA CLA JMP .-4 JMS I DPCVPT /READ FIRST DIGIT GROUP TAD CHAR /AND SET "SIGNF" TAD MPER SZA CLA /ENDED BY PERIOD? JMP FIGO1 JMS I XIN /YES, READ SECOND GROUP DCA I DPN JMS I DCONP TAD I DPN /SAVE NUMBER OF DIGITS IN T3 CMA IAC FIGO1, DCA T3 /NO TAD P43 DCA EXP JMS I RESOL5 JMS I INORM /NORMALIZE FIRST ,THEN FINT /SAVE NUMBER FPUT I PT1 FEXT TAD CHAR TAD MINUSE SZA CLA /"E" READ IN? JMP ENDFI+3 /NO JMS I XIN /YES, READ 3RD DIGIT GROUP JMS I DPCVPT /I.E. CONVERT DECIMAL EXPONENT JMS I RESOL5 TAD OVER2 TAD T3 /C(SEXP) PLACES TO RIGHT OF LAST DIGIT DCA T3 /&26 /COMPENSATE FOR DECIMAL EXPONENTS ENDFI, FINT /RESTORE MANTISSA FGET I PT1 FEXT TAD T3 /TEST DECIMAL EXPONENT SNA JMP I FLINTP /FINISHED SMA CLA JMP FIGO4 FINT /. IS TO THE LEFT: FMUL PTEN /TIMES .1000 FPUT I PT1 FEXT IAC JMP .+6 FIGO4, FINT /. IS TO THE RIGHT: FMUL TEN /TIMES TEN FPUT I PT1 FEXT CMA TAD T3 DCA T3 JMP ENDFI+3 TEN, 0004 2400 0000 0000 PTEN, 7775 3146 3146 3150 MINUSE, -305 DPCVPT, DECONV DCONP, DECON RESOL5, RESOLV DPN, DNUMBR XIN, INPUT INORM, DNORM P43, 43 /&27 FRAN, FENT /PSEUDO-RANDOM NUMBER FGET RNDM /X(1)=(2^17+3)*X(0) MOD 2^16 FPUT ADDR FEXT TAD M16 DCA T1S JMS I DOUBLE ISZ T1S JMP .-2 JMS I ADDO JMS I DOUBLE JMS I ADDO FINT FPUT RNDM FEXT DCA EXP CLA CLL CMA RAR /=3777 AND HORD DCA HORD /BE POSITIVE IT'S POSITIVE JMP I EFUN3I M16, -16 ADDO, DUBLAD RNDM=. T1S, 0 4421 3040 0001 /&28 XRTD, 0 CDF T TAD I XRT CDF P JMP I XRTD ABSOLV, 0 TAD HORD DCA SIGNF TAD HORD SPA CLA JMS I MINSKI JMP I ABSOLV MINUS2, 0 /NEGATE OPERAND CLA CLL /TRIPLE PRECISION TAD OVER1 CMA IAC DCA OVER1 TAD AC1L CMA SZL IAC CLL DCA AC1L TAD AC1H CMA SZL IAC CLL DCA AC1H JMP I MINUS2 PAGE /&29 /FLOATING POINT INTERPRETER FOR FOCAL FPNT, 0 7600 /CLA;REFERENCED CLL TAD I FPNT /GET NEXT INSTRUCTION SNA JMP I FPNT /FAST EXIT DCA JUMP TAD JUMP AND C200 /GET PAGE BIT SNA CLA /PAGE ZERO? JMP .+3 /YES TAD FPNT+1 /NO AND FPNT /C(FPNT) 0-4 CONTAINS PAGE BITS DCA ADDR TAD P177 /GET 7 BIT ADRESS AND JUMP TAD ADDR DCA ADDR TAD INDRCT /INDIRECT BIT =1? AND JUMP SNA CLA JMP LOOP01 /NO- GO ON TAD I ADDR /YES, DEFER W/O AUTO-INDEX DCA ADDR LOOP01, ISZ FPNT CMA TAD ADDR DCA FLTXR2 TAD JUMP /GET COMMAND CLL RTL RTL AND P17 /GET BITS 0-2,I.E. OPCODE SNA JMP FLGT TAD TABLE /LOOK UP THE TABLE DCA JUMP TAD I JUMP SNA JMP FLPT DCA JUMP TAD CEX1 /SAVE FLOATING ARGUMENT,UNLESS 'GET' OR 'PUT' DCA FLTXR TAD MFLT DCA CNTR TAD I FLTXR2 DCA I FLTXR ISZ CNTR JMP .-3 JMP I JUMP /GO THERE /&30 JUMP, 0 ADDR=EX1 INDRCT, 0400 TABLE, ITABLE FLPT, TAD CEXP /EXP TO (ADDR) JMP .+5 FLGT, TAD CEXP /(ADDR) TO EXP DCA FLTXR2 CMA TAD ADDR DCA FLTXR /SAVE 'FROM' ADRESS TAD MFLT /3 OR 4 WORDS DCA CNTR TAD I FLTXR DCA I FLTXR2 ISZ CNTR JMP .-3 JMP FPNT+1 CEXP, EXP-1 CEX1, EX1-1 FLSU, JMS I OPMINS /FSUB = 2, NEGATE THE OPERAND FLAD, JMS I ALGN /FLAD = 1, FIRST ALIGN EXPONENTS JMP FPNT+1 /RETURN IF NO ALIGMENT IS POSSIBLE JMS I RAR2 /TRIPLE PRECISION ADDITION JMS I RAR1 /SINCE BITS ARE SHIFTED JMS I TRAD /RIGHT NORF, JMS I NORM /NORMALIZE THE RESULT JMP FPNT+1 /HINT: USE 700X FOR FUNCTIONS /&31 /INTERPRETIVE POWER FLEX, TAD HORD /ZERO? SZA CLA JMP .+6 ZERO, DCA EXP /YES DCA HORD DCA LORD DCA OVER2 JMP FPNT+1 PUSHF /AC TO A + POWER FLAC PUSHF /SETUP ARGUMENT (THE EXPONENT) EX1 POPF FLAC JMS I INTEGER /ONLY POSITIVE, INTEGER EXPONENTS SPA JMP .+5 /(COULD DIVIDE) CMA DCA JUMP /TEMP STORAGE NOP TAD HORD SZA CLA ERROR2 /TOO LARGE OR NEGATIVE EXPONENT PUSHF /INITIALIZE TO ONE FLTONE POPF FLAC POPF ITER1 JMP .+6 PUSHF ITER1 POPF EX1 JMS I MULT /"MULT" ISZ JUMP JMP .-6 JMP FPNT+1 /&32 FLMY, JMS I MULT /MULTIPLY JMP FPNT+1 OPMINS, MINUS2 MULT, DMULT NORM, DNORM ALGN, ALIGN RAR1, DIV1 RAR2, DIV2 TRAD, DUBLAD ITABLE=.-1 FLAD FLSU FLDV FLMY FLEX 0000 NORF ACMINS, 0 /ROUTINE TO COMPLEMENT FLAC - VIA "MINSKI" CLL CLA TAD OVER2 /TRIPLE PRECISION NEGATION CMA IAC /OF FLOATING AC DCA OVER2 TAD LORD CMA SZL IAC CLL DCA LORD TAD HORD CMA SZL IAC CLL DCA HORD JMP I ACMINS /&33 ALIGN, 0 /SUBROUTINE TO ALIGN TAD HORD /BINARY POINTS SNA TAD LORD SNA CLA /IS MANTISSA ZERO? JMP NOX1 /YES, RESULT=OPERAND TAD AC1H /NO, IS OPERAND ZERO? SNA TAD AC1L SNA TAD OVER1 SNA CLA JMP I ALIGN /YES, EXIT TAD EX1 CMA IAC TAD EXP SNA /ARE EXPONENTS EQUAL? JMP ADONE DCA ACMINS TAD ACMINS SMA /NO CIA /NEGATE AND DCA AMOUNT /SAVE THE DIFFERENCE TAD AMOUNT TAD TEST2 SPA CLA /CAN THE EXPONENTS BE ALIGNED? JMP NOX /NO, USE LARGER OF THE TWO TAD ACMINS /YES, SHIFT THE SMALLER SMA CLA JMP ASHFT JMS DIV2 ISZ AMOUNT JMP .-2 JMP ADONE /&34 ASHFT, CMA TAD EX1 DCA EX1 JMS I TAG1 ISZ AMOUNT JMP .-2 ADONE, ISZ ALIGN JMP I ALIGN NOX, TAD EX1 /MISSION IMPOSSIBLE! SMA CLA /CHECK FOR SIGN DIFFERENCE JMP NOX2 TAD EXP SMA CLA JMP I ALIGN /-+ JMP .+3 /-- NOX2, TAD EXP SMA CLA TAD ACMINS /TEMP STORAGE OF DIFFERENCE, SMA SZA CLA /-BOTH POSITIVE EXP OR BOTH NEG JMP I ALIGN /OK (+-) NOX1, TAD EX1 /USE LARGER DCA EXP TAD AC1H DCA HORD TAD AC1L DCA LORD TAD OVER1 DCA OVER2 JMP I ALIGN AMOUNT, 0 TAG1, DIV1 P27, 27 ABSOL, ABSOLV RESOL, RESOLV /&35 /LEAVE 12 BIT ANSWER IN AC UPON RETURN /LEAVE FLAC AS AN INTEGER FIX, 0 /VIA (INTEGER) JMS I ABSOL TAD EXP /TEST FOR FRACTION SPA SNA CLA JMP FIXM /DOUBLE CHECK FOR MINUS ONE IAC DCA OVER1 TAD P27 /INIT ALIGNEMENT DCA EX1 JMS ALIGN /DO THE ALIGNEMENT TO AN INTEGER TEST2, 0043 /ALREADY DONE; (27) FOR 3-WORD ISZ OVER2 JMP .+4 ISZ LORD SKP ISZ HORD DCA OVER2 /CLEAR THE FRACTION JMS I RESOL CLA CLL /CLEAR LINK FOR GENERAL PURPOSE TAD LORD /EXIT WITH LOW ORDER RESULT IN AC JMP I FIX FIXM, DCA EXP /CLEAR EXPONENT DCA HORD DCA LORD JMP TEST2+6 DIV2, 0 /SHIFT FLAC RIGHT CLA CLL TAD HORD SPA CML RAR DCA HORD TAD LORD RAR DCA LORD TAD OVER2 RAR DCA OVER2 ISZ EXP JMP I DIV2 JMP I DIV2 SPECIAL=. /INPUT CHARACTERS 337 /LEFT ARROW 377 /RUBOUT 212 /L.F. 375 /ALT MODE 214 /^L - IGNORED IN ASK /NEXT LOC ALWAYS NEGATIVE: CALLED FROM FLTP PACKAGE /&36 /(A+B+C)*(D+E+F)=C*F,C*E,B*F,C*D,A*F,B*E,A*E,B*D,A*D MULTY, 4000 /5-PRECISION MULTIPLY WITH IAC /PRODUCT IN TRIPLE PRECISION TAD EX1 /ADD EXPONENTS + 1 JMS SIGN /AND DETERMINE SIGN OF RESULT SPA CLA JMS I MINI TAD C MQL MUY F DCA I (DATUM-5 TAD C MQL MUY E DAD DATUM-5 DST DATUM-5 SZL CLA ISZ I (DATUM-3 TAD B MQL MUY F DAD DATUM-5 DST DATUM-5 SZL CLA ISZ I (DATUM-3 TAD C MQL MUY D DAD DATUM-4 DST DATUM-4 SZL CLA ISZ I (DATUM-2 TAD A MQL MUY F DAD DATUM-4 DST DATUM-4 SZL CLA ISZ I (DATUM-2 /&37 TAD B MQL MUY E DAD DATUM-4 DST DATUM-4 SZL CLA ISZ I (DATUM-2 TAD A MQL MUY E DAD DATUM-3 DST DATUM-3 SZL CLA ISZ I (DATUM-1 TAD B MQL MUY D DAD DATUM-3 DST DATUM-3 SZL CLA ISZ I (DATUM-1 TAD A MQL MUY D DAD DATUM-2 DST DATUM-2 JMP I MULTY MINI, MINUS2 REVIT, ZERO DIVIDE, DUBDIV MLDV, MULDIV A=HORD B=LORD C=OVER2 D=AC1H E=AC1L F=OVER1 /&38 /THIS SUBROUTINE PREPARES MULTIPLY AND DIVIDE /FOR ANY COMBINATION OF SIGNED ARGUMENTS AND FOR ZERO /THE RESULT OF EITHER IS ZERO IF FLAC = 0 /RESULT OF MULTIPLY IS ZERO IF EITHER IS ZERO; /DIVISION BY ZERO IS CHECKED BERFORE THIS /ROUTINE IS CALLED /THE CALLING AC CONTAINS AN UPDATE VALUE FOR THE /EXPONENT, THE RETURNING AC CONTAINS THE SIGN OF /THE ARGUMENT FOR FURTHER TESTING BY EACH ROUTINE. SIGN, 0 /TEST AND SAVE SIGN OF RESULT TAD EXP /COMPUTE NEW EXP FOR MUL-DIV. DCA EXP CLL CML RAR /LOAD 4000 TO XOR THE SIGN BITS AND HORD TAD AC1H SMA CLA /RESULT MAY BE ZERO CMA DCA SIGNF /+=-1;-=0 TAD HORD SNA JMP I REVIT /ANSWER IS ZERO SPA CLA /TAKE ABSOLUTE VALUE OF FLAC JMS I MINSKI TAD AC1H SNA /RESULT OF EITHER MAY BE ZERO JMP I REVIT JMP I SIGN FLDV, TAD AC1H /4:DIVIDE SNA CLA ERROR2 /DIVISION BY ZERO TAD EX1 /SUBTRACT EXPONENTS+1 CMA IAC IAC JMS SIGN /SET UP SIGNS SMA CLA JMS I MINI /NEGATE DIVISOR JMS I DIVIDE /DIVIDE JMS I MLDV JMP I .+1 FPNT+1 DAC, JMS I INTEGE /DAC FUNCTION CIF CDF 30 JMP I .+1 DAC30 PAGE /&39 DMULT, 0 /HEAD AND DATA FOR MULTIPLY DCA DATUM-1 DCA DATUM-2 DCA DATUM-3 DCA DATUM-4 JMS I DMULTY CLA CLL TAD DATUM-1 DCA HORD TAD DATUM-2 DCA LORD TAD DATUM-3 DCA OVER2 JMS MULDIV JMP I DMULT DMULTY, MULTY MIF, -43 DATUM=.+5 MP1, 0 MP2, 0 MP3, 0 MP4, 0 MP5, 0 /&40 DUBDIV, 0 /2 OR 3 PRECISION DIVIDE DCA MP4 DCA MP1 TAD MIF /INIT BIT COUNTER DCA MP3 SKP DV3, JMS I DOUBLE /SHIFT FLAC LEFT CLL TAD OVER1 /----FROM HERE 4-WORD TAD OVER2 DCA MP5 RAL TAD AC1L /COMBINE ONE POSITION AND TAD LORD DCA MP2 /SAVE RESULT RAL TAD HORD /ADD OVERFLOW TAD AC1H SNL /SKIP IF OVERFLOW JMP .+6 DCA HORD /UPDATE FLAC TAD MP5 DCA OVER2 TAD MP2 DCA LORD CLA /CLEAR ACCUMULATOR TAD MP1 /SAVE OVERFLOW BITS CIRCULARLY RAL DCA MP1 TAD MP4 RAL DCA MP4 TAD DNORM RAL DCA DNORM ISZ MP3 /TEST FOR END OF DIVIDE JMP DV3 TAD DNORM DCA HORD TAD MP4 DCA LORD TAD MP1 DCA OVER2 JMP I DUBDIV /&41 MULDIV, 0 /TERMINATE MULTIPLY AND DIVIDE ISZ SIGNF /CORRECT FOR SIGN JMS I MINSKI JMS DNORM JMP I MULDIV TEST4, 0 /TEST FOR 4000 TAD HORD SPA CIA SPA CLA JMS I XRAR2 /SHIFT BACK JMP I TEST4 XRAR2, DIV2 ABSOL3, ABSOLV RESOL3, RESOLV /&42 DNORM, 0 /SUBROUTINE TO NORMALIZE FLAC JMS I ABSOL3 /MAKE IT POSITIVE JMS TEST4 /TEST FOR 4000 TAD HORD /TEST LARGE SHIFTS SZA CLA JMP LOP TAD LORD SPA /DON'T MAKE IT NEGATIVE JMP LOP+1 DCA HORD TAD OVER2 DCA LORD DCA OVER2 TAD FOURTN /12 BIT SHIFT TAD EXP DCA EXP LOP, TAD LORD MQL TAD HORD NMI SNA DCA EXP /IT'S REALLY ZERO DCA HORD SCA SNA JMP EXIT3 /NO SHIFT CIA TAD EXP /ADJUST EXPONENT DCA EXP SCA DCA SHIFT /FOR SHIFTING THE REST TAD OVER2 MQL TAD LORD SHL SHIFT, 0 DCA LORD MQA DCA OVER2 EXIT3, JMS I RESOL3 JMS TEST4 /DON'T LEAVE 4000 JMP I DNORM FOURTN, -14 PGETLN, 0 GETLN CIF CDF L JMP I PGETLN PAGE /&43 /FLOATING SQUARE ROOT FUNCTION XSQRT, FINT FPUT FPAC1 /VALUE FEXT /NEWTON'S METHOD IS USED GETSGN SPA CLA ERROR2 /NUMBER IS NEGATIVE = IMAGINARY ROOTS TAD EXP /LINK =0 FROM FINT SPA /MATCH THE SIGN WITH LINK BIT CML RAR DCA ITER1 /MAKE FIRST APPROXIMATION SZL /TEST LSB OF EXP ISZ ITER1 NOP TAD SQCON1 DCA ITER1+1 DCA ITER1+2 DCA ITER1+3 TAD FPAC1+1 SNA TAD FPAC1+2 SNA CLA JMP SQEND /NUMBER = 0 CLCU, FINT FGET FPAC1 FDIV ITER1 FADD ITER1 FEXT /&44 CLA CMA TAD EXP DCA EXP TAD EXP CMA IAC TAD ITER1 SZA CLA /ARE EXPONENTS EQUAL? JMP ROOTGO /NO TAD HORD /ARE HIGH ORDER MANTISSAS EQUAL? CMA IAC TAD ITER1+1 SZA CLA JMP ROOTGO /NO TAD LORD CMA IAC TAD ITER1+2 /DO LOW ORDER MANTISSAS AGREE? SMA CMA IAC /WITHIN ONE BIT? IAC SMA CLA RETURN ROOTGO, FINT FPUT ITER1 FEXT JMP CLCU SQEND, DCA EXP RETURN SQCON1, 3015 BUFFER=. ITER1, 0 0 0 0 FPAC1, 0 0 0 BUFFER+13 /&45 /THIS IS THE "LIBRARY HEAD" *7503 LIB, SPNOR /IGNORE SPACES TAD TELSW /WAIT FOR OUTPUT TO FINISH SZA CLA /(DECTAPE SYSTEMS REALLY NEED THIS!) JMP .-2 DCA GOSWIT /I.E. TO 'PROC' FOR REST OF LINE TAD CHAR /MOVE CURRENT CHARACTER DOWN IOF CIF CDF L /CALL LOWER FIELD JMP I (LOWLIB TAD (JMP I GOSWIT+1 /RETURN TO APPROPIATE ROUTINE TAD GOSWIT DCA GOSWIT GOSWIT, JMP I .+1 PROC START1 LGOSUB GOTO+1 /STORAGE FUNCTION FCOM;512 SINGLE PRECISION VALUES XCOM, JMS I INTEGER CLL TAD CTEST /TEST OVERFLOW SZL CLA ERROR2 TAD LORD RAL /*2 TAD CMSTA PUSHA /STORE ADRESS TAD CHAR /2ND ARGUMENT? TAD MCOMA SZA CLA JMP GET /&46 PUSHJ /'PUT' EVAL-1 POPA DCA INDX CDF L TAD EXP /GET EXPONENT DCA I INDX ISZ INDX TAD HORD /GET HIGH-ORDER DCA I INDX JMP OUTCOM GET, POPA DCA INDX CDF L TAD I INDX DCA EXP /STORE IN EXPONENT ISZ INDX TAD I INDX DCA HORD /STORE IN HIGH-ORDER DCA LORD DCA OVER2 /CLEAR REST OF FLAC OUTCOM, CDF P JMP I EFUN3I CTEST, -1400 /768 VARIABLES;256 OVERLAPPING WITH I/O CMSTA, CMST /START OF COMMON XINTEG, 0 /CROSS FIELD JMS I INTEGER CIF CDF L JMP I XINTEG PAGE > IFNZRO FLTLST <XLIST>