.TITLE $NEG01 ; ; $NEG V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $NGI,$NGR,$NGD,$ERR ; INTEGER, REAL AND DOUBLE PRECISION NEGATION. ; CALLED IN THE POLISH MODE. ; NEGATES THE ITEM ON TOP OF THE STACK. R4=%4 R5=%5 SP=%6 $NGI: NEG @SP ;NEGATE AN ITEGER BVS OVER ;JUMP IF 100000 JMP @(R4)+ ;RETURN $NGR: $NGD: TST @SP BEQ ZERO ;JUMP IF 0 TO AVOID -0. ADD #100000,@SP ;INVERT FLOATING SIGN ZERO: JMP @(R4)+  .TITLE PDMP01 ; ; PDUMP V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL PDUMP,$OUTFI,$IOA,$IOF,$OTSV,$ERR ; THE FORTRAN PDUMP ROUTINE. ; CALLING SEQUENCE: ; JSR R5,PDUMP ; BR A ; .WORD LIMIT1 ; .WORD LIMIT2 ; .WORD TYPE ;  ; ANY REASONABLE NUMBER OF REPETITIONS OF THE ; ABOVE TRIPLET TO DUMP ADDITIONAL SEGMENTS OF ; USER STORAGE. ; ;A: ; EITHER LIMIT1 OR LIMIT2 MAY BE THE LOW LIMIT ; OF THE AREA TO BE DUMPED. IN ANY EV .TITLE $LCO01 ; ; $LCO V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $LCO ; $LCO LOGICAL TO ASCII CONVERSION ; CALLING SEQUENCE: ; PUSH FIELD START ADDRESS ; PUSH FIELD LENGTH ; PUSH LOGICAL VALUE ; JSR PC,$LCO ; R0 ... R3 ARE DESTROYED R0=%0 R1=%1 R2=%2 SP=%6 PC=%7 $LCO: MOV 4(SP),R0 ;GET FIELD WIDTH BGE WOK ;ASSURE NON-NEG CLR R0 WOK: MOV 6(SP),R1 ;GET FIELD START ADDRESS ADD R1,R0 ;GET POINTER T .TITLE $ICO01 ; ; $ICO V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $ICO,$OCO ; $OCO OCTAL TO ASCII CONVERSION ; $ICO INTEGER TO ASCII CONVERSION ; CALLING SEQUENCE: ; PUSH FIELD START LOCATION ; PUSH FIELD LENGTH ; PUSH VALUE ; JSR PC,$ICO (OR $OCO) ; ERROR WILL RETURN WITH C BIT SET ON ; R0, R1, R2, R3 ARE DESTROYED R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 SP=%6 PC=%7 $OCO: MOV #OCT-REL,R0 ;POINT TO OCTAL TABL OVER: JSR R5,$ERR ;ERROR 3,11 JMP @(R4)+ .BYTE 3 .BYTE 11. .END ENT STORAGE ; WILL BE DUMPED FROM THE LOWER LIMIT TO AND INCLUDING ; THE UPPER LIMIT. DEFINED TYPE CODES ARE AS FOLLOWS: ; 0 1 WORD OCTAL ; 1 1 WORD INTEGER ; 2 2 WORD OCTAL ; 3 2 WORD INTEGER ; 4 REAL ; 5 DOUBLE PRECISION R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PDUMP: MOV (R5)+,-(SP) ;GET NUMBER OF ARGUMENTS NEXT: DECB @SP ;COUNT ARGS BGE ARGS TST (SP)+ ;POP ARG COUNT RTS R5 ;ALL ARGUMENTS USED. RETURN TO USER ARGS: MOV (R5)+,R0 ;GET O END+1 MOV (SP)+,4(SP) ;MOVE RETURN UP MOV (SP)+,R2 ;GET VALUE TO BE CONVERTED CLR @SP ;CLEAR ERROR FLAG TST R2 ;TEST LOGICAL VALUE BEQ FALSE COM R2 BEQ TRUE COM @SP ;FLAG ARGUMENT NOT 0 OR -1 MOVB #'*,-(R0) ;MOVE OUT * BR FIELD FALSE: MOVB #'F,-(R0) ;OUTPUT FALSE BR FIELD TRUE: MOVB #'T,-(R0) ;OUTPUT TRUE FIELD: CMP R0,R1 ;CHECK FIELD END BLE DONE ;FIELD IS FULL MOVB #' ,-(R0) ;INSERT LEADING BLANKS BR FIELD DONE: ROL (SP)+ E BR GO $ICO: MOV #DEC-REL,R0 ;POINT TO DECIMAL TABLE GO: MOV R4,-(SP) MOV 8.(SP),R3 ;GET FIELD START MOV 6.(SP),R2 ;GET FIELD LENGTH BGE LPOS ;JUMP IF LENGTH NOT NEG CLR R2 CLR 6(SP) LPOS: MOV 4.(SP),R4 ;GET VALUE TO BE CONVERTED MOV #' ,-(SP) ;CLEAR SIGN CMP R0,#OCT-REL ;CHECK IF DOING OCTAL BEQ POS ;YES, GIVE MAGNITUDE RESULT TST R4 BGE POS ;JUMP IF + NEG R4 ;GET ABSOLUTE VALUE MOV #'-,@SP ;SAVE - POS: CLR -(SP) ;SET FENCE AFIRST OF TRIPLET DECB @SP ;COUNT BLT ERROR MOV (R5)+,R1 ;GET SECOND LIMIT DECB @SP BLT ERROR MOV @(R5)+,R2 ;GET TYPE BLT NEXT ;NOT A LEGAL TYPE CMP R2,#5 BGT NEXT ;DITTO ASL R2 ;WORD ALIGN SUB R0,R1 ;GET SMALLER LIMIT IN R0 BGE INC ;JUMP IF R1 HIGH ADD R1,R0 ;SWAP R0 AND R1 NEG R1 INC: MOVB ADB(R2),R3 ;GET # OF BYTES/ITEM ASR R3 ;DIVIDE R1 BY IT ASR: ASR R1 ASR R3 BGT ASR ;LOOP INC R1 ;GET # OF ELEMENTS TO DUMP M;FLUSH FLAG AND SET C BIT RTS PC .END z DD PC,R0 REL=. TST: TST @R0 BEQ MOV ;JUMP IF ALL POWERS DONE CLR R1 SUB: SUB @R0,R4 ;SEE IF CURRENT POWER WILL GO AGAIN BLO BACK INC R1 ;BUMP DIGIT BR SUB BACK: ADD (R0)+,R4 ;TOO MUCH, BACK UP TST R1 BNE NZERO ;JUMP IF DIGIT NOT 0 TST @SP BEQ TST ;JUMP IF NO NON-ZERO DIGITS YET NZERO: ADD #60,R1 ;CONVERT TO ASCII MOV R1,-(SP) BR TST MOV: ADD R2,R3 ;POINT TO FIELD END ADD #60,R4 ;CONVERT LEAST SIGNIFICANT DIGIT MOVB R4,-(R3) DEC .TITLE $DCO01 ; ; $DCO V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $ECO,$FCO,$GCO,$DCO ; $ECO THE E CONVERSION OUTPUT ROUTINE FOR REALS ; $FCO THE F CONVERSION OUTPUT ROUTINE FOR REALS ; $GCO THE G CONVERSION OUTPUT ROUTINE FOR REALS ; $DCO THE D CONVERSION ROUTINE FOR DOUBLES ; CALLING SEQUENCE: ; PUSH FIELD START ; PUSH FIELD LENGTH ; PUSH D PART OF W.D SPECIFICATION ; PUSH P SCALE ; PUSH VALUE TO BE OUTPUT ; JSR PC,$OV R1,-(SP) ;BUILD ADB FOR $IOA. DIMENSION MOV ADB(R2),-(SP) ;PUSH ADB TYPE FLAGS MOV R0,-(SP) ;PUSH ARRAY START TO ADB MOV SP,-(SP) ;PUSH ADB POINTER FOR $IOA MOV #1,-(SP) ;PUSH # OF ADB'S MOV FMT(R2),-(SP) ;PUSH FORMAT TYPE FOR $OUTFI MOV @#$OTSV,R0 MOV 2(R0),-(SP) ;GET OUTPUT DEVICE NUMBER JSR R4,POLSH ;ENTER POLISH MODE .WORD $OUTFI,$IOA,$IOF,UNPOL ;WRITE OUT ARRAY UNPOL: ADD #6,SP ;FLUSH ADB BR NEXT ;GO FOR NEXT TRIPLET ; ERROR: JSR R5,$ERR R: DEC R2 BLE FULL ;JUMP IF COUNT EXHAUSTED MOVB (SP)+,-(R3) ;MOVE DIGIT BNE DECR ;JUMP IF NOT THE FENCE MOVB (SP)+,@R3 ;MOVE OUT THE SIGN FILL: DEC R2 BEQ DONE ;JUMP IF FIELD FILLED MOVB #' ,-(R3) ;MOVE IN LEADING BLANKS BR FILL FULL: TST (SP)+ BNE ERROR ;NUMBER TOO BIG FOR FIELD CMP #' ,(SP)+ BNE ERROR ;JUMP IF NO ROOM FOR - DONE: MOV (SP)+,R4 MOV (SP)+,4(SP) ;MOVE RETURN UP TST (SP)+ ;FLUSH VALUE ROL (SP)+ ;FLUSH FLAG AND SET C BECO (OR $FCO) (OR $GCO) (OR $DCO) ; R0, R1, R2, R3 ARE DESTROYED R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 POINT=2 BEXP=4 EXP=6 TYPE=12. P=16. D=18. L=20. S=22. $GCO: MOV #42403,R0 ;FLAG G FORMAT BR XCO $FCO: CLR R0 ;FLAG F FORMAT BR XCO $DCO: MOV (SP)+,R0 ;POP RETURN MOV (SP)+,R1 ;GET HIGHEST ORDER ARG MOV (SP)+,R2 ;GET NEXT MOV @SP,R3 ;THIRD ARG WORD MOV #42002,@SP ;FLAG D FORMAT MOV R4,-(SP) ;SAVE R4 MOV 4(SP;ERROR 4,14 RTS R5 .BYTE 4 .BYTE 14. ; ADB: .WORD 50002 ;OCTAL 1 WORD .WORD 50002 ;DECIMAL 1 WORD .WORD 50004 ;OCTAL 2 WORD .WORD 50004 ;DECIMAL 2 WORD .WORD 54004 ;REAL .WORD 60010 ;DOUBLE PRECISION ; FMT: .WORD OFMT,IFMT,OFMT,IFMT,GFMT,DFMT OFMT: .ASCII /(8O8)/ IFMT: .ASCII /(8I8)/ GFMT: .ASCII /(4G15.7)/ DFMT: .ASCII /(3D22.14)/ ; .EVEN POLSH: TST (SP)+ JMP @(R4)+ .END P`?  .TITLE $LCI01 ; ; $LCI V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $LCI ; $LCI ASCII TO LOGICAL CONVERSION ; CALLING SEQUENCE: ; PUSH FIELD START ; PUSH FIELD WIDTH ; JSR PC,$LCI ; RETURNS WITH LOGICAL RESULT ON TOP OF STACK. ; R0 ... R3 ARE DESTROYED R0=%0 R1=%1 R2=%2 R3=%3 SP=%6 PC=%7 $LCI: MOV 2(SP),R0 ;GET WIDTH BGE WOK ;ASSURE NON-NEG CLR R0 WOK: MOV 4(SP),R1 ;GET FIELD START ADD R1,R0 ;GIT ON IF ERROR RTS PC ERROR: TST (SP)+ BNE ERROR TST (SP)+ ;FLUSH SIGN MOV 8.(SP),R3 STARS: MOVB #'*,(R3)+ ;FILL FIELD WITH * DEC 6(SP) BGT STARS ;JUMP IF MORE TO DO COM 6(SP) ;FLAG ERROR BR DONE DEC: .WORD 10000.,1000.,100.,10.,0 OCT: .WORD 100000,10000,1000,100,10,0 .END ),R4 ;GET LOWEST ORDER ARG MOV R0,4(SP) ;SAVE RETURN BR XCO1 $ECO: MOV #42402,R0 ;FLAG E FORMAT XCO: MOV (SP)+,R3 ;SAVE RETURN MOV (SP)+,R1 ;GET HIGH ORDER ARG MOV (SP)+,R2 ;GET LOW ORDER ARG MOV R3,-(SP) ;PUSH RETURN MOV R0,-(SP) ;PUSH TYPE CLR R3 ;CLEAR LOW ORDER REGISTERS MOV R4,-(SP) ;SAVE R4 CLR R4 XCO1: MOV R5,-(SP) ;SAVE R5 AND CONTINUE ALL TYPES CLR -(SP) ;CLEAR EXP CLR -(SP) ;CLEAR BEXP CMP -(SP),-(SP) ;ROOM FOR POINT AND SIGNET END +1 MOV (SP)+,@SP ;MOVE RETURN UP CLR -(SP) ;CLEAR ERROR FLAG CLR 4(SP) ;CLEAR RESULT = FALSE AGAIN: MOVB (R1)+,R3 BICB #200,R3 CMPB R3,#'T ;CHECK FOR TRUE BEQ TRUE CMPB R3,#'F ;CHECK FOR FALSE BEQ DONE CMPB R3,#' ;CHECK BLANK BNE ERROR ;JUMP IF NOT T, F, OR BLANK CMP R1,R0 ;CHECK FIELD LIMIT BLT AGAIN ;JUMP IF MORE ERROR: COM @SP ;SET ERROR RETURN DONE: ROL (SP)+ ;FLUSH FLAG AND SET C BIT RTS PC ;RETURN CONTROL TRUE: COM 4 ADD S(SP),L(SP) ;POINT 1 BEYOND END OF FIELD MOV S(SP),R0 CLEAR: MOVB #' ,(R0)+ ;BLANK OUT FIELD CMP R0,L(SP) BLT CLEAR ROL R1 ;GET ARG SIGN ROL @SP ;SAVE IT SWAB R1 MOVB R1,BEXP(SP) ;GET BINARY EXPONENT BNE NONZ ;JUMP IF ARG NOT 0 MOV L(SP),R3 SUB #2,R3 ;POINT TO NEXT TO LAST SLOT CMP R3,S(SP) BGE MOV0 ;JUMP IF WITHIN FIELD MOVB #'*,@S(SP) ;NO ROOM FOR 0. SO USE * BR JDONE MOV0: MOVB #'0,(R3)+ ;INSERT 0. MOVB #'.,@R3 JDONE: .TITLE $ICI01 ; ; $ICI V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $ICI,$OCI ; $OCI ASCII TO OCTAL CONVERSION ; $ICI ASCII TO INTEGER CONVERSION ; CALLING SEQUENCE: ; PUSH CHARACTER FIELD START ; PUSH CHARACTER FIELD LENGTH ; JSR PC,$ICI OR $OCI ; RETURNS WITH INTEGER RESULT ON TOP OF STACK. R0=%0 R1=%1 R2=%2 SP=%6 PC=%7 $OCI: MOV #67,-(SP) ;SET OCTAL FLAGS BR GO $ICI: MOV #471,-(SP) ;SET DECIMAL FL(SP) ;SET RETURN TRUE BR DONE .END .TITLE $DCI01 ; ; $DCI V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $DCI,$RCI ; $DCI --- ASCII TO DOUBLE CONVERSION. ; $RCI --- ASCII TO REAL CONVERSION. ; CALLING SEQUENCE: ; PUSH ADDRESS OF START OF FIELD ; PUSH LENGTH OF FIELD ; PUSH FORMAT SCALE D FROM W.D ; PUSH P FORMAT SCALE ; JSR PC,$DCI (OR $RCI) R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 NUMEND=0 POINTL=2 DIGITS=4 BEXP=6 ESIGN=8. SIGN=! JMP DONE NONZ: SEC ;INSERT NORMAL BIT ROR R1 CLRB R1 ;LEFT JUSTIFY FRACTION SWAB R2 BISB R2,R1 CLRB R2 SWAB R3 BISB R3,R2 CLRB R3 SWAB R4 BISB R4,R3 CLRB R4 SUB #200,BEXP(SP) ;REMOVE EXCESS 128 FROM BINARY EXP BLT DIV ;JUMP IF BINARY EXPONENT NEG BEQ NORM ;JUMP IF NO SCALING TO DO MUL: TST R1 ;BINARY EXPONENT IS POSITIVE BLT MUL1 ;JUMP IF FRACTION OVERFLOW IMPENDING ASL R4 ;DOUBLE FRACTION ROL R3 ROL R2 ROL R1 D"AGS GO: MOV R1,-(SP) ;SAVE R1 MOV 8.(SP),R1 ;GET STRING START ADD 6(SP),8.(SP) ;GET END+1 MOV 4(SP),6(SP) ;FIDDLE RETURN POINTER MOV R0,4(SP) ;SAVE R0 MOV R2,-(SP) ;SAVE R2 CLR -(SP) ;CLEAR SIGN CLR R0 ;CLEAR WORK SPACE START: MOVB (R1)+,R2 ;GET NEXT CHAR. BIC #177600,R2 CMPB R2,#' BNE SIGNS ;JUMP IF NOT BLANK CMP R1,12.(SP) BLT START ;JUMP IF MORE TO SCAN BR SIGN ;DONE SIGNS: CMPB R2,#'+ BEQ FIELD ;JUMP IF + CMPB R2,#'- $10. EXP=12. P=30. D=32. ERF=26. LENGTH=34. TEMP=LENGTH RESULT=P START=36. END=START $RCI: CLR -(SP) ;CLEAR ERROR FLAG INC @SP ;SET REAL CONVERSION FLAG BR CONV $DCI: CLR -(SP) ;CLEAR ERROR FLAG AND SET FOR DOUBLE CONV: MOV R0,-(SP) MOV R1,-(SP) MOV R2,-(SP) MOV R3,-(SP) MOV R4,-(SP) MOV R5,-(SP) CLR -(SP) ;CLEAR EXP CLR -(SP) ;CLEAR SIGN CLR -(SP) ;CLEAR ESIGN MOV #65.,-(SP) ;INITIALIZE BEXP MOV #18.,-(SP) ;INITIALIZE MAX DIGITS %EC BEXP(SP) ;COMPENSATE EXPONENT BGT MUL ;JUMP IF MORE BINARY SCALING TO DO BR NORM MUL1: JSR PC,MUL45 ;GET 4/5 FRACTION INC EXP(SP) ;MULTIPLY BY 10 SUB #3,BEXP(SP) ;AND DIVIDE BY 8 BGT MUL ;JUMP IF BINARY EXPONENT STILL POS. BEQ NORM ;JUMP IF EXPONENT GONE NOW DIV: CMP R1,#146314 ;BINARY EXPONENT IS NEGATIVE BHIS DIV1 ;JUMP IF NO ROOM FOR 5/4 FRACTION CMP BEXP(SP),#-3 BGT DIV1 ;JUMP IF NOT ENOUGH BINARY EXP LEFT JSR PC,MUL54 ;MULTIPLY FRACTION BY &BNE NUMCK ;JUMP IF NOT - INC @SP ;SET SIGN - BR FIELD NEXT: MOVB (R1)+,R2 ;GET NEXT CHAR. BIC #177600,R2 CMPB R2,#' BNE NUMCK ;JUMP IF NOT BLANK MOVB #60,R2 ;BLANK =ZERO NUMCK: CMPB R2,#'0 BLT ERROR ;JUMP IF TOO SMALL CMPB R2,6(SP) BGT ERROR ;JUMP IF TOO BIG SUB #60,R2 ;MAKE NUMERIC ASL R0 ;R0=BASE*R0+R2 BVS ERROR TSTB 7(SP) ;OCTAL OR BINARY BEQ OCTAL SUB R0,R2 OCTAL: ASL R0 BVS ERROR ASL R0 BVS ERROR SUB R2' .TITLE REAL01 ; ; REAL V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL REAL ; THE FORTRAN REAL FUNCTION. ; CALLING SEQUENCE: ; JSR R5,REAL ; BR A ; .WORD #COMPLEX ARG ;A: ; RETURNS THE REAL PART OF ARG IN RO,R1. R0=%0 R1=%1 R5=%5 REAL: MOV 2(R5),R1 ;GET ARG ADDRESS MOV (R1)+,R0 ;GET HIGH ORDER REAL MOV @R1,R1 ;GET LOW ORDER RTS R5 ;RETURN TO USER .END (CLR -(SP) ;CLEAR POINTL CLR -(SP) ;CLEAR NUMEND MOV START(SP),R5 ;GET FIELD START ADDRESS ADD LENGTH(SP),END(SP) ;POINT TO END +1 CLR R0 ;CLEAR NUMERIC WORK SPACE CLR R1 CLR R2 CLR R3 SCAN: MOVB (R5)+,R4 ;GET NEXT INPUT CHARACTER BIC #177600,R4 CMPB R4,#' ;TEST FOR BLANK BNE SIGNS ;IF NOT BLANK LOOK FOR + OR - CMP R5,START(SP) ;CHECK END OF FIELD BLT SCAN ;IF NOT DONE GO GET NEXT JMP ZERO ;ENTIRE FIELD IS BLANK SIGNS: CMPB R4,#'+ ;CHE)5/4 DEC EXP(SP) ;DIVIDE BY 10 ADD #2,BEXP(SP) ;MULTIPLY BY 4 BR DIV2 DIV1: JSR PC,RIGHT ;DIVIDE BY 2 DIV2: INC BEXP(SP) ;MULTIPLY BY 2 BNE DIV ;HIT IT AGAIN IF BIN.EXP. NOT GONE ; AT THIS POINT THE BINARY EXPONENT IS 0 ; AND THE FRACTION IS IN R1, R2, R3 AND R4. NORM: CLR R0 ;CLEAR OVERFLOW ACCUMULATOR NORM1: JSR PC,MUL54 ;MULTIPLY FRACTION BY 5/4 JSR PC,MUL8 ;AND NOW BY 8 TST R0 BNE NORMD ;JUMP IF AN INTEGER PART RESULTS DEC EXP(SP) ;DECREMENT EXP*,R0 BVS ERROR FIELD: CMP R1,12.(SP) BLT NEXT ;JUMP IF MORE FIELD TO SCAN SIGN: ROR (SP)+ ;TEST SIGN BCS DONE ;JUMP IF - NEG R0 ;MAKE + BVS NEGM ;JUMP IF -NEGMAX CLC ;SET SUCCESS FLAG DONE: MOV (SP)+,R2 ;RESTORE R2 MOV (SP)+,R1 ;RESTORE R1 ROL (SP)+ ;FLUSH FLAG AND SET C BIT IF ERROR MOV R0,4(SP) ;RETURN RESULT MOV (SP)+,R0 RTS PC ERROR: TST (SP)+ ;FLUSH SIGN NEGM: CLR R0 COM 4(SP) ;SET ERROR FLAG BR DONE .END ,CK FOR + SIGN BEQ FIELD ;IF FOUND IGNORE IT CMPB R4,#'- ;CHECK FOR - SIGN BNE NUMCK ;IF NOT FOUND CHECK NUMERICS INC SIGN(SP) ;SET - SIGN FLAG BR FIELD NEXT: MOVB (R5)+,R4 ;GET NEXT INPUT CHARACTER BIC #177600,R4 CMPB R4,#' ;CHECK FOR BLANKS BNE NUMCK MOV #'0,R4 ;TREAT BLANK AS 0 NUMCK: CMPB R4,#'0 ;CHECK FOR LEGAL CHARACTER BLT PNTCK ;CHECK FOR DECIMAL POINT BNE NONZ ;JUMP IF NOT 0 TST R0 ;CHECK TO SEE IF ANY NON-ZERO DIGITS FOUND BNE -ONENT BR NORM1 ;GO AGAIN TO GET AN INTEGER PART ; AT THIS POINT THE MOST SIGNIFICANT NON ZERO DIGIT IS IN R0 NORMD: TSTB TYPE(SP) ;TEST CONVERSON TYPE BEQ FFMT ;JUMP IF F FORMAT RORB TYPE(SP) BCC EFMT ;JUMP IF E FORMAT OR D FORMAT TST EXP(SP) ;G FORMAT BLT EFMT ;JUMP IF RESULT <.1 CMP EXP(SP),D(SP) BGT EFMT ;JUMP IF RESULT >10**D CLRB TYPE(SP) ;MAKE TYPE F INSTEAD OF G SUB #4,L(SP) ;LEAVE ROOM FOR BLANKS ON RIGHT SUB EXP(SP),D(SP) ;DECREASE D BY #/ .TITLE CPLX01 ; ; CMPLX V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL CMPLX ; THE FORTRAN CMPLX FUNCTION: ; C=CMPLX(R1,R2) ------- > C=R1+IR2. ; CALLING SEQUENCE: ; JSR R5,CMPLX ; BR A ; .WORD #R1 ; .WORD #R2 ;A: ; RETURNS COMPLEX RESULT C IN R0 - R3. ; R0=%0 R1=%1 R2=%2 R3=%3 R5=%5 CMPLX: MOV 2(R5),R3 ;GET R1 ADDRESS MOV (R3)+,R0 ;GET HIGH ORDER R1 MOV @R3,R1 ;GET LOW ORDER MOV 4(R5),R3 ;GET 0NONZ TST R1 BNE NONZ TST R2 BNE NONZ TST R3 BEQ FIELD NONZ: CMPB R4,#'9 BGT EXPCK ;CHECK FOR EXPONENT DEC DIGITS(SP) ;COUNT AS A SIGNIFICANT DIGIT BGE A2I ;JUMP IF WE CAN USE THIS DIGIT INC EXP(SP) ;COMPENSATE FOR SKIPPED DIGIT BR FIELD A2I: SUB #60,R4 ;CONVERT ASCII TO INTEGER JSR PC,MUL5 ;MULTIPLY BY 5 JSR PC,LEFT ;DOUBLE RESULT FOR 10 ADD R4,R3 ;ADD IN CURRENT DIGIT ADC R2 ADC R1 ADC R0 ;END OF CONVERT FOR THIS DIGIT FI1 OF DIGITS LEFT OF . CLR P(SP) ;SUSPEND P SCALE FFMT: MOV EXP(SP),R5 ;F FORMAT FFMTE: ADD D(SP),R5 ADD P(SP),R5 JSR PC,ROUND ;ROUND BY ADDING 5*10**-P-D-E MOV L(SP),R5 SUB D(SP),R5 TSTB TYPE(SP) BNE FF5 ;JUMP IF NOT F CONVERSION ADD EXP(SP),P(SP) ;COMBINE P AND EXP BLE FF5 ;JUMP IF THERE IS NO INTEGER PART IN RESULT SUB P(SP),R5 SUB #2,R5 ;SIGN SLOT IS S+L-D-E-P-2 JSR PC,ISIGN ;INSERT SIGN AND CHECK WIDTH BR FF3 ;JUMP TO INSERT IDGITS FF2 .TITLE CNJG01 ; ; CONJG V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL CONJG ; THE FORTRAN CONJG FUNCTION. ; CALLING SEQUENCE: ; JSR R5,CONJG ; BR A ; .WORD #COMPLEX ARG ;A: ; RETURNS THE COMPLEX CONJUGATE OF ARG IN ; R0 - R3. ; R0=%0 R1=%1 R2=52 R3=%3 R5=%5 CONJG: MOV 2(R5),R3 ;GET ARG ADDRESS MOV (R3)+,R0 ;GET REAL PART MOV (R3)+,R1 MOV (R3)+,R2 ;GET IMAGINARY PART ADD #100000,R2 ;NEGATE IT 3R2 ADDRESS MOV (R3)+,R2 ;GET HIGH ORDER R2 MOV @R3,R3 ;GET LOW ORDER RTS R5 ;RETURN TO USER .END 4ELD: CMP R5,END(SP) ;CHECK FOR END OF FIELD BLT NEXT MOV R5,@SP ;POINTER TO LAST NUMERIC TO NUMEND SCALE: TST R0 BNE SCALE1 ;JUMP IF NUMBER NOT 0 TST R1 BNE SCALE1 TST R2 BNE SCALE1 TST R3 BEQ ZERO ;INPUT NUMBER IS 0 SCALE1: CMP @SP,R5 ;CHECK NUMEND BNE NOP ;JUMP IF THERE WAS AN EXPONENT FIELD SUB P(SP),EXP(SP) ;USE THE FORMAT P SCALE NOP: TST POINTL(SP) BNE POINT ;JUMP IF THERE WAS A DECIMAL POINT MOV D(SP),@SP ;USE THE D SCALE POIN55: SUB #3,R5 ;SIGN SLOT IS S+L-D-3 JSR PC,ISIGN ;GO INSERT SIGN AND CHECK WIDTH MOVB #'0,(R5)+ ;INSERT LEADING 0 MOVB #'.,(R5)+ ;INSERT . FF4: CMP R5,L(SP) ;CHECK FIELD END BGE FF3 ;JUMP IF FIELD FULL MOVB #'0,(R5)+ ;PUT IN ANOTHER LEADING ZERO BR FF4 FF3: MOV L(SP),R5 SUB D(SP),R5 DEC R5 ;LOCATION FOR . MOV R5,POINT(SP) ;REMEMBER ITS LOCATION TST P(SP) BGT FF6 INC R5 ;POINT TO SLOT FOR FIRST NON-ZERO DIGIT FF6: SUB P(SP),R5 JSR PC,6 MOV @R3,R3 RTS R5 ;RETURN TO USER .END FT: SUB POINTL(SP),@SP SUB @SP,EXP(SP) ;FORM COMPLETE DECIMAL EXPONENT BGT MUL ;MULTIPLY BY 10**EXP BLT DIV ;JUMP IF DECIMAL EXPONENT IS NEG JMP FLOAT ;JUMP IF EXP IS 0 MUL: CMP R0,#31462 BHI MDIV ;JUMP IF FRACT TOO BIG TO MULT BY 5 JSR PC,MUL5 ;FRACT=5*FRACT INC BEXP(SP) ;TIMES 2 DEC10: DEC EXP(SP) ;OVER 10 BGT MUL ;JUMP IF MORE DECIMAL EXPONENT JMP FLOAT ;DECIMAL EXPONENT GONE MDIV: JSR PC,MUL54 ;MULTIPLY BY 5/4 ADD #3,BEXP(SP) ;TIMES 8 BREDIGITS ;GO INSERT ALL DIGITS TSTB TYPE(SP) BEQ DONE ;ALL THROUGH IF F FORMAT BR EFMTE ;GO FINISH E FORMAT EFMT: SUB #4,L(SP) ;MAKE ROOM FOR E FIELD CLR R5 TST P(SP) BLE FFMTE ;PROCESS AS F FMT & RETURN TO EFMTE MOV D(SP),R5 ;GET ROUNDING FACTOR INC R5 JSR PC,ROUND ;GO USE IT MOV L(SP),R5 ;POINT TO SIGN SLOT SUB D(SP),R5 SUB #3,R5 JSR PC,ISIGN ;GO CHECK WIDTH AND INSERT SIGN MOV R5,POINT(SP) ;R3 POINTS TO LEADING DIGIT SLOT ADD P(SP)G .TITLE CABS01 ; ; CABS V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL CABS,$DVR,$MLR,$ADR,$FCALL,SQRT ; CABS --- THE FORTRAN COMPLEX ABSOLUTE ; VALUE FUNCTION. R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 CABS: MOV R5,-(SP) ;SAVE RETURN MOV 2(R5),R4 ;GET ARG POINTER MOV @R4,R0 ;GET HIGH ORDER REAL PART MOV 4(R4),R1 ;GET HIGH ORDER IMAGINARY ASL R0 ;GET ABS VALUES ASL R1 CMP R0,R1 ;GET MAX"DDD """"" """"DD@DDDD@D """@DD@DD"" "@D""DD"@D """""@DDDDDD"""ADDB COXX4d dh4dKX4d8X4dX4d iKX4d8X4d*X4djIqO4d#'LϚ4d+304d.6{4d7S04dHP6}64dT`xb4dWsO\4dd O\4dmg=4dngOu4dwg4dg=4dg=4dR4dSX4duX4d ρ4dρ4dzyρ4diϚ4d:X4d99Ϛ4da'ρ4d4dW4dϚ4da O\4d <O\4d#X4dh4d h4d/04d 04d 04d $D C%%8a ͋,L w6B ` 5 &  }E >u   d5cU@  Y*  & * D &( 5I'4b Q$ BBB"   U@ e  "U%Gef. U U Bb 0 * BI,POINT(SP) ;SAVE LOCATION FOR . JSR PC,DIGITS ;GO PROCESS ALL DIGITS EFMTE: SUB P(SP),EXP(SP) ;CORRECT EXPONENT FOR P MOV L(SP),R3 MOVB TYPE+1(SP),(R3)+ ;MOVE OUT E OR D MOV EXP(SP),R4 BGE EXPP ;JUMP IF EXPONENT POSITIVE NEG R4 ;GET ABSOLUTE VALUE MOVB #'-,(R3)+ ;INSERT - BR EXPE1 EXPP: MOVB #' ,(R3)+ ;INSERT BLANK FOR + EXPE1: MOVB #'0,@R3 ;CLEAR TENS DIGIT EXPE3: SUB #10.,R4 ;TEST FOR TENS BLT EXPE2 INCB @R3 ;ACCUMULATE TENS BR EXPE3 EXJ DEC10 ;GO DIVIDE BY 10 PNTCK: CMPB R4,#'. BNE ERROR ;JUMP IF NOT A DECIMAL POINT POINTF: TST POINTL(SP) BNE ERROR ;JUMP IF A . ALREADY ENCOUNTERED MOV R5,POINTL(SP) ;SAVE A POINTER TO THE . +1 BR FIELD ;GO FOR NEXT CHARACTER ERROR: COMB ERF+1(SP) ;FLAG ERROR ZERO: CLR R0 ;RESULT IS 0 CLR R1 CLR R2 CLR R3 JMP STORE ;GO PUSH RESULT AND RETURN EXPCK: CMPB R4,#'E BEQ EXPT ;JUMP IF E CMPB R4,#'D BNE ERROR ;IF NOT E OR D THEN ERROR EXPT: MK BHIS REHI ;JUMP IF REAL BIGGER MOV 6(R4),-(SP) ;PUSH IM MOV 4(R4),-(SP) MOV 2(R4),-(SP) ;PUSH RE MOV @R4,-(SP) MOV 6(R4),-(SP) ;IM AGAIN MOV 4(R4),-(SP) BR DIV REHI: TST R0 BEQ ZERO ;JUMP IF ARG IS 0 MOV 2(R4),-(SP) ;PUSH RE MOV @R4,-(SP) MOV 6(R4),-(SP) ;PUSH IM MOV 4(R4),-(SP) MOV 2(R4),-(SP) ;PUSH RE MOV @R4,-(SP) DIV: JSR R4,POLSH ;ENTER POLISH MODE .WORD $DVR,DUP ;GET 2 COPIES OF MIN/MAX .WORD $MLR,ONE,$ADR ;GET MINL .TITLE AIAG01 ; ; AIMAG V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL AIMAG ; THE FORTRAN AIMAG FUNCTION. ; CALLING SEQUENCE: ; JSR R5,AIMAG ; BR A ; .WORD #COMPLEX ARG ;A: ; RETURNS THE IMAGINARY PART OF ARG IN R0,R1. ; R0=%0 R1=%1 R5=%5 AIMAG: MOV 2(R5),R1 ;GET ARG ADDRESS CMP (R1)+,(R1)+ ;POINT TO IMAGINARY PART MOV (R1)+,R0 ;GET HIGH ORDER IMAG MOV @R1,R1 ;GET LOW ORDER RTS R5 ;RETURN TO USER .MPE2: ADD #72,R4 ;GET POSITIVE UNITS MOVB R4,1(R3) ;MOVE UNITS OUT DONE: ADD #8.,SP MOV (SP)+,R5 MOV (SP)+,R4 MOV (SP)+,6(SP) ;MOVE FLAG AND RETURN UP MOV (SP)+,6(SP) CMP (SP)+,(SP)+ ;FLUSH JUNK ROL (SP)+ ;SET C BIT IF ERROR RTS PC ;RETURN TO CALLER ; MULTIPLY CONTENTS OF R1 ... R4 BY 5/4. ; ANY OVERFLOW GOES INTO R0. MUL54: MOV R1,-(SP) ;5/4X=X+X/4 MOV R2,-(SP) MOV R3,-(SP) MOV R4,-(SP) JSR PC,RIGHT ;X/2 JSR PC,RIGHT ;X/4 ADC RNOV R5,@SP ;SAVE POINTER TO END OF NUM +1 DEC @SP ;DECREMENT NUMEND MOV R3,TEMP(SP) CLR R3 CMP R5,END(SP) BGE ERROR ;JUMP IF NO ROOM FOR EXP MOVB (R5)+,R4 BIC #177600,R4 CMPB R4,#'+ ;CHECK FOR +EXP BEQ EFLD1 CMPB R4,#'- ;CHECK FOR -EXP BNE ENUM ;GO CHECK FOR NUMERIC INC ESIGN(SP) ;FLAG EXPONENT NEGATIVE EFLD1: CMP R5,END(SP) BGE ERROR EFLD2: MOVB (R5)+,R4 ;GET NEXT CHAR BIC #177600,R4 ENUM: CMPB R4,#' ;CHECK FOR BLANK BNE ENUM1O/MAX**2 +1 .WORD ROOT ;SQRT(1 +(MIN/MAX)**2) DUP: MOV 2(SP),-(SP) ;GET 2 COPIES OF STACK ITEM MOV 2(SP),-(SP) JMP @(R4)+ ONE: CLR -(SP) ;PUSH A 1. MOV #40200,-(SP) JMP @(R4)+ ROOT: MOV SP,R5 ;POINT TO 1+(MIN/MAX)**2 MOV #SQRT,R4 ;POINT TO SQRT JSR PC,$FCALL ;GO GET SQUARE ROOT MOV R0,@SP ;PUT ON STACK MOV R1,2(SP) JSR R4,POLSH .WORD $MLR,RTN ;SCALE BY MAX RTN: MOV (SP)+,R0 ;POP RESULT TO REGS BIC #100000,R0 ;MAKE + MOV (SP)+,R1 OUTPEND Q4 ;ROUND ADC R3 ADC R2  ADC R1 ADD (SP)+,R4 ADC R3 ADC R2 ADC R1 ADC R0 ADD (SP)+,R3 ADC R2 ADC R1 ADC R0 ADD (SP)+,R2 ADC R1 ADC R0 ADD (SP)+,R1 ADC R0 RTS PC ;RETURN TO CALLER ; ; MUL45: MOV #16.,R5 ;MULTIPLY R1...R4 BY 4/5 JSR PC,RIGHT MOV R4,-(SP) MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) M451: JSR PC,RIGHT JSR PC,RIGHT MOV #2,R0 M452: JSR PC,RIGHT ADD 6(SP),R4 ADC R3 ADC R2 ADR MOV #'0,R4 ;TREAT BLANK AS 0 ENUM1: CMPB R4,#'0 BLT ERROR CMPB R4,#'9 BGT ERROR ;NOT A VALID CHAR SUB #60,R4 ;CONVERT ASCII TO INTEGER ASL R3 ;X=10*X+D ADD R3,R4 ASL R3 ASL R3 ADD R4,R3 ;END OF ABOVE COMMENT CMP R5,END(SP) BLT EFLD2 ;JUMP IF MORE FIELD TO GO TST ESIGN(SP) ;CHECK EXPONENT SIGN BEQ ENUM2 ;JUMP IF IT IS + NEG R3 ;MAKE USER EXPONENT - ENUM2: ADD R3,EXP(SP) ;GET COMPLETE DECIMAL EXPONENT MOV TEMP(SP),R3 JMP SCS: MOV (SP)+,R5 ;GET RETURN CLR R2 ;IMAGINARY PART OF RESLT IS 0 CLR R3 RTS R5 ZERO: CLR R0 ;RESULT IS 0 CLR R1 BR OUT POLSH: TST (SP)+ JMP @(R4)+ .END UC R1 ADD 4(SP),R3 ADC R2 ADC R1 ADD 2(SP),R2 ADC R1 ADD @SP,R1 DEC R0 BGT M452 DEC R5 BGT M451 ADD #8.,SP ;FLUSH MULTIPLIER RTS PC ; ; MULTIPLY THE CONTENTS OF R0 ... R4 BY 8. ; NO OVERFLOW IS ANTICIPATED MUL8: MOV R5,-(SP) MOV #3,R5 MUL81: ASL R4 ROL R3 ROL R2 ROL R1 ROL R0 DEC R5 BGT MUL81 MOV (SP)+,R5 RTS PC ERROR: TST (SP)+ ;POP RETURN MOV S(SP),R3 ;POINT TO FIELD BEGIN MOV L(SP),R4 ;GET FIELVALE ;GO SCALE THE NUMERIC PART DIV: TST R0 BLT DIV1 ;JUMP IF FRACT LEFT JUSTIFIED DIV2: DEC BEXP(SP) ;LEFT JUSTIFY NUMERIC BITS JSR PC,LEFT BPL DIV2 DIV1: MOV #16.,R4 ;SET FOR SIXTEEN ITERATIONS JSR PC,RIGHT MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) ;INITIALIZE QUOTIENT MOV R0,-(SP) DIV3: JSR PC,RIGHT CLC JSR PC,RIGHT MOV #2,R5 CLC DIV4: JSR PC,RIGHT ADD 6(SP),R3 ADC R2 ADC R1 ADC R0 ADD 4(SP),R2 ADC R1 ADC R0 ADX .TITLE TANH01 ; ; TANH V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL TANH,EXP,$ADR,$SBR,$DVR,$FCALL ; THE FORTRAN TANH FUNCTION ; CALLING SEQUNCE: ; JSR R5,TANH ; BR A ; .WORD ARGUMENT ADDRESS ;A: ; RETURNS (EXP(2*ARG) -1)/(EXP(2*ARG)+1) IN R0,R1. ; R0=%0 R1=%1 R4=%4 R5=%5 SP=%6 PC=%7 TANH: MOV R5,-(SP) ;SAVE RETURN POINTER MOV 2(R5),R5 ;GET ARG ADDRESS MOV @R5,R0 ;GET HIGH ORDER ARG BEQ ZERO ;JUMYD END +1 TSTB TYPE(SP) ;CHECK IF END MODIFIED BEQ STARS ;NO, THIS IS F FORMAT ADD #4,R4 ;PUT BACK EXPONENT SPACE STARS: MOVB #'*,(R3)+ ;FILL FIELD WITH * CMP R3,R4 BLT STARS ;JUMP IF MORE TO GO COM TYPE(SP) ;FLAG ERROR BR DONE ; ; ROUND THE CONTENTS OF R0 ... R4 TO THE PRECISION ; SPECIFIED BY R5. ; THIS ROUTINE IS SHORTER THAN THE TABLE THAT ; OTHERWISE WOULD BE NEEDED. ROUND: CMP R5,#20. BGT ROUND1 ;JUMP IF NOT WORTH ROUNDING MOV R5,BEXP+0+2(SP) ZD 2(SP),R1 ADC R0 ADD @SP,R0 DEC R5 ;COUNT TWICE BGT DIV4 DEC R4 BGT DIV3 ADD #8.,SP ;POP DIVIDEND SUB #3,BEXP(SP) INC EXP(SP) ;BUMP DECIMAL EXPONENT BLT DIV ;JUMP IF MORE TO DO FLOAT: DEC BEXP(SP) ;POST NORMALIZE THE RESULT JSR PC,LEFT BCC FLOAT ADD #200,BEXP(SP) ;SET EXCESS 128 BLE UNDER ;NUMBER TOO SMALL TO REPRESENT CMP BEXP(SP),#377 BGT OVER ;JUMP IF NUMBER TOO BIG CLRB R3 BISB R2,R3 SWAB R3 CLRB R2 BISB R[ .TITLE SNCO01 ; ; SINCOS V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL SIN,COS,$ADR,$MLR,$SBR,$DVR,$INTR ; SIN COS THE REAL SIN AND COSINE FUNCTIONS ; CALLING SEQUENCE: ; JSR R5,SIN (OR COS) ; BR A ; .WORD ARG ADDRESS ;A: ; RETURNS SIN OR COS OF ARG IN R0 AND R1 R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 COS: MOV 2(R5),R4 ;GET ARGUMENT ADDRESS CLR -(SP) ;MAKE ROOM FOR QUADRANT FLAG MOV 2(R4\P IF ARG=0 ASL R0 CLRB R0 SWAB R0 ;GET EXPONENT CMP R0,#205 BLT TAN ;JUMP IF ABS(ARG) <16. MOV #40200,R0 ;ANSWER IS 1.*SIGN(ARG) CLR R1 TST @R5 ;TEST ARG SIGN BGE OUT ADD #100000,R0 ;MAKE -1. BR OUT TAN: MOV 2(R5),-(SP) ;PUSH 2*ARG ON STACK MOV @R5,-(SP) ADD #200,@SP ;DOUBLE ARG MOV SP,R5 ;SET UP CALL TO EXP. ARG POINTER MOV #EXP,R4 ;POINT TO EXP JSR PC,$FCALL MOV R1,-(SP) ;PUSH E**2ARG MOV R0,-(SP) CLR -(SP) ;PUSH 1];SAVE ROUNDING PRECISION IN TEMP BEQ ROUND3 ;JUMP IF ROUND IS TO LEADING DIGIT BLT ROUND1 ;JUMP IF NO ROUNDING TO DO MOV R0,-(SP) MOV R1,-(SP) MOV R2,-(SP) MOV R3,-(SP) MOV R4,-(SP) MOV #100000,R1 ;INSERT .5 CLR R2 CLR R3 CLR R4 RNDF: DEC BEXP+0+2+10.(SP) ;COUNT PRECISION BEQ RNDD ;JUMP IF DONE JSR PC,MUL45 ;MULTIPLY BY 4/5 JSR PC,RIGHT JSR PC,RIGHT JSR PC,RIGHT ;DIVIDE BY 8 BR RNDF ;GO CHECK IF DONE WITH FACTOR RNDD: CLR R^1,R2 SWAB R2 CLRB R1 BISB R0,R1 ;MOVE OUT LOWEST ORDER BITS SWAB R1 CLRB R0 BISB BEXP(SP),R0 ;INSERT THE BINARY EXPONENT SWAB R0 ;PUT IN THE RIGHT ORDER ROR SIGN(SP) ;TEST THE ARITHMETIC SIGN JSR PC,RIGHT ;INSERT IN RESULT ADC R3 ADC R2 ADC R1 ;FINAL ROUND ADC R0 BVS OVER ;JUMP IF OVERFLOW BCS OVER STORE: TSTB ERF(SP) ;TEST REAL/DOUBLE FLAG BEQ DPREC ;JUMP IF DOUBLE ROL R2 ;ROUND TO REAL PRECISION ADC R1 ADC R0 BVS_),-(SP) ;PUSH ARGUMENT MOV @R4,-(SP) MOV #007733,-(SP) ;PUSH PI/2 MOV #040311,-(SP) JSR R4,POLSH ;ENTER POLISH MODE .WORD $ADR,SINCOS ;COS(X)=SIN(X+PI/2) SIN: MOV 2(R5),R4 ;GET ARGUMENT ADDRESS CLR -(SP) ;MAKE ROOM FOR QUADRANT FLAG MOV 2(R4),-(SP) MOV @R4,-(SP) ;PUSH ARGUMENT SINCOS: ASL @SP ;REMOVE AND SAVE SIGN ROR 4(SP) ;IN QUADRANT FLAG ROR @SP MOV #007733,-(SP) ;PUSH 2*PI MOV #040711,-(SP) JSR R4,POLSH ;ENTER POLISH MODE .WORD`. MOV #40200,-(SP) MOV R1,-(SP) ;PUSH E**2ARG MOV R0,-(SP) CLR -(SP) MOV #40200,-(SP) ;PUSH 1. JSR R4,POLSH ;GET (E**2X -1)/(E**2X +1) .WORD $SBR,UP,$ADR,$DVR,UNPOL UNPOL: MOV (SP)+,R0 ;POP RESULT MOV (SP)+,R1 OUT: MOV (SP)+,R5 ;RESTORE RETURN RTS R5 ;RETURN TO USER ZERO: CLR R0 CLR R1 BR OUT ; UP: MOV (SP)+,10.(SP) ;MOVE STACK ITEM UP MOV (SP)+,10.(SP) JMP @(R4)+ ; POLSH: TST (SP)+ JMP @(R4)+ .END a0 ADD (SP)+,R4 ;ADD FRACTION TO RND FACTOR ADC R3 ADC R2 ADC R1 ADD (SP)+,R3 ADC R2 ADC R1 ADD (SP)+,R2 ADC R1 ADD (SP)+,R1 ADC R0 ADD (SP)+,R0 ROUND2: CMP #10.,R0 BGT ROUND1 ;JUMP IF NO OVERFLOW INC EXP+2(SP) ;BUMP DECIMAL EXPONENT ROUND1: RTS PC ;RETURN TO CALLER ROUND3: ADD #5,R0 ;ROUND MOST SIGNIFICANT DIGIT BR ROUND2 ; ; INSERT A - IF NECESSARY AND CHECK THAT THE FIELD ; IS WIDE ENOUGH TO CONTAIN THE RESULT. ISIGN: CMP b OVER BCS OVER ;JUMP IF OVERFLOW ON ROUND MOV R0,R2 ;MOVE HIGH ORDER RESULT UP MOV R1,R3 DPREC: MOV R0,RESULT(SP) ;STORE RESULT ON STACK MOV R1,RESULT+2(SP) MOV R2,RESULT+4(SP) MOV R3,RESULT+6(SP) ADD #14.,SP ;CLEAR STACK OF JUNK MOV (SP)+,R5 MOV (SP)+,R4 MOV (SP)+,R3 MOV (SP)+,R2 MOV (SP)+,R1 MOV (SP)+,R0 TSTB @SP ;TEST REAL/DOUBLE FLAG BEQ RETRN ;JUMP IF DOUBLE MOV (SP)+,2(SP) ;PUSH FLAG UP MOV (SP)+,2(SP) ;PUSH RETURN UP Rc $DVR ;X/2PI .WORD DUP ;2 COPIES .WORD $INTR ;INT(X/2PI) .WORD $SBR ;FRACT(X/2PI) .WORD X4 ;4*FRACT(X/2PI) .WORD DUP ;2 COPIES .WORD $INTR ;INT(4*FRACT(X/2PI)) .WORD QUAD ;SAVE INT(......) .WORD $SBR ;Y=FRACT(4*FRACT(X/2PI)) .WORD QSET ;REDUCE Y TO (-1,1) QSETRE: .WORD DUP ;2 COPIES .WORD DUP ;3 COPIES .WORD $MLR ;Y*Y .WORD POLY ;PUSH COEFFICIENTS .WORD $MLR ;A4*Y**2 .WORD $ADR ;A4*Y**2+A3 .WORD $MLR .WORD $ADR .WORD eR5,S-0+2(SP) ;COMPARE SIGN SLOT WITH FIELD BEGIN BLT SPCK ;JUMP IF IT MAY NOT FIT ROR 0+2(SP) ;TEST SIGN BCC ISR ;JUMP IF + MOVB #'-,@R5 ;INSERT - ISR: INC R5 ;POINT TO LEADING DIGIT SLOT RTS PC ;RETURN SPCK: ROR 0+2(SP) ;TEST SIGN BCS ERROR ;JUMP IF IT'S - 'CAUSE THERE ISN'T ROOM INC R5 ;POINT TO LEADING DIGIT SLOT CMP R5,S+2(SP) BLT ERROR ;JUMP IF NO ROOM FOR IT EITHER RTS PC ; ; EXTRACT LEADING DIGITS FROM R0 ... R4 AND FILL IN ; THE AREA STfETRN: ROL (SP)+ ;FLUSH FLAG AND SET C BIT IF ERROR RTS PC ; OVER: UNDER: JMP ERROR ; MUL54: CMP R0,#146314 BLO MUL54A ;JUMP IF ROOM FOR 5/4 * FRACT CLC JSR PC,RIGHT ;DIVIDE BY 2 INC BEXP+0+2(SP) ;MULTIPLY BY 2 MUL54A: MOV R0,-(SP) MOV R1,-(SP) MOV R2,-(SP) MOV R3,-(SP) CLC JSR PC,RIGHT ;HALF CLC JSR PC,RIGHT ;QUARTER BR MUL5A ;GO GET F+F/4 MUL5: MOV R0,-(SP) ;MULT BY 5 MOV R1,-(SP) MOV R2,-(SP) MOV R3,-(SP) JSR PC,LEg$MLR .WORD $ADR .WORD $MLR .WORD $ADR .WORD $MLR ;((((A4*Z+A3)*Z+A3)*Z+A2)*Z   ;+A1)*Z+A0)*Z Z=Y*Y .WORD RTN RTN: MOV (SP)+,R0 ;POP HIGH ORDER RESULT MOV (SP)+,R1 TST (SP)+ ;POP QUADRANT FLAG BGE RTN1 ;JUMP IF ARGUMENT WAS + ADD #100000,R0 ;SIN(-X)=-SIN(X) RTN1: RTS R5 ;BACK TO CALLER ; DUP: MOV 2(SP),-(SP) ;DUPLICATE STACK ITEM MOV 2(SP),-(SP) JMP @(R4)+ ; X4: TST @SP ;CHECK FOR 0 FRACTION BEQ RTN ;QUIT NOW INCB 1(SP) ;Qh .TITLE DSIN01 ; ; DSINCS V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL DSIN,DCOS,$ADD,$MLD,$SBD,$DVD,$DINT ; DSIN DCOS THE DOUBLE PRECISION SIN AND COS ; FUNCTIONS. ; CALLING SEQUENCE: ; JSR R5,DSIN (OR DCOS) ; BR A ; .WORD ARG ADDRESS ;A: ; RETURNS SIN OR COS OF ARG IN R0 - R3. R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 DCOS: MOV R5,-(SP) ;SAVE RETURN POINTER MOV 2(R5),R4 ;GET ARGUMENT ADDRiARTING AT THE ADDRESS IN R5 AND ; BOUNDED BY THE MODIFIED FIELD END. DIGITS: CMP #10.,R0 ;CHECK IF OVERFLOW IN R0 BGT DIG1 ;JUMP IF ONLY ONE DIGITS WORTH MOVB #'1,(R5)+ ;OUTPUT OVERFLOW SUB #10.,R0 ;CORRECT R0 FOR NEXT DIGIT DIG1: CMP POINT+2(SP),R5 ;CHECK FOR . SLOT BNE DIG2 MOVB #'.,(R5)+ ;INSERT THE . DIG2: CMP L+2(SP),R5 ;CHECK END OF FIELD BLE DIGR ;JUMP IF DONE DIG3: ADD #60,R0 ;CONVERT TO ASCII MOVB R0,(R5)+ ;PUT IT IN FIELD CLR R0 JSR PCjFT ;DOUBLE JSR PC,LEFT ;QUADRUPLE MUL5A: ADD (SP)+,R3 ADC R2 ADC R1 ADC R0 ADD (SP)+,R2 ADC R1 ADC R0 ADD (SP)+,R1 ADC R0 ADD (SP)+,R0 RTS PC ;CODES MAY BE TESTED ON RETURN LEFT: ASL R3 ROL R2 ROL R1 ROL R0 RTS PC RIGHT: ROR R0 ROR R1 ROR R2 ROR R3 RTS PC .END kUADRUPLE STACK ITEM JMP @(R4)+ ; QUAD: BIS @SP,8.(SP) ;SAVE QUADRANT NUMBER JMP @(R4)+ ; QSET: TSTB 4(SP) ;TEST QUADRANT BEQ Q13 ;JUMP IF FIRST OR THIRD QUAD ADD #100000,@SP ;NEGATE STACK ITEM CLR -(SP) ;PUSH A FLOATING 1. MOV #40200,-(SP) JSR R4,POLSH ;ENTER POLISH .WORD $ADR,QSETR ;X=1.-X QSETR: MOV #QSETRE,R4 ;POINT BACK INTO LIST Q13: ASRB 5(SP) ;TEST QUADRANT ; BCC QOUT ;JUMP IF FIRST OR SECOND ADD #100000,@SP ;NEGATE STACK ITEM QOUT:lESS CLR -(SP) ;MAKE ROOM FOR QUADRANT FLAG MOV 6(R4),-(SP) MOV 4(R4),-(SP) MOV 2(R4),-(SP) ;PUSH ARGUMENT MOV @R4,-(SP) MOV #064302,-(SP) MOV #121041,-(SP) MOV #007732,-(SP) ;PUSH PI/2 MOV #040311,-(SP) JSR R4,POLSH ;ENTER POLISH MODE .WORD $ADD,SINCOS ;COS(X)=SIN(X+PI/2) DSIN: MOV R5,-(SP) ;SAVE RETURN MOV 2(R5),R4 ;GET ARGUMENT ADDRESS CLR -(SP) ;MAKE ROOM FOR QUADRANT FLAG MOV 6(R4),-(SP) MOV 4(R4),-(SP) MOV 2(R4),-(SP) MO,MUL54 ;MULTIPLY FRACTION BY 5/4 JSR PC,MUL8 ;AND BY 8 BR DIG1 ;GO CONVERT TO ASCII DIGR: RTS PC ;RETURN TO CALLER ; ; SHIFT THE CONTENTS OF R1 .. R4 RIGHT 1. RIGHT: CLC ROR R1 ROR R2 ROR R3 ROR R4 RTS PC .END o JMP @(R4)+ ; POLY: MOV (SP)+,R0 ;SAVE Y*Y MOV (SP)+,R1 MOV #CONSTS,R2 ;POINT TO LIST OF COEFFICIENTS MOV #5,R3 BR POLY1 POLY2: MOV R1,-(SP) ;PUSH Y*Y MOV R0,-(SP) POLY1: MOV (R2)+,-(SP) MOV (R2)+,-(SP) DEC R3 ;COUNT COEFFICIENTS BGT POLY2 JMP @(R4)+ POLSH: TST (SP)+ JMP @(R4)+ CONSTS: .WORD 007733 .WORD 040311 ;1.570796318 ; .WORD 056741 .WORD 140045 ;-.645963711 ; .WORD 032130 .WORD 037243 ;.0796896793 ; .WORD pV @R4,-(SP) ;PUSH ARGUMENT SINCOS: ASL @SP ;CLEAR SIGN AND SAVE IT ROR 8.(SP) ;IN QUADRANT FLAG ROR @SP MOV #064302,-(SP) MOV #121041,-(SP) MOV #007732,-(SP) ;PUSH 2*PI MOV #040711,-(SP) JSR R4,POLSH ;ENTER POLISH MODE .WORD $DVD ;X/2PI .WORD DUP ;2 COPIES .WORD $DINT ;INT(X/2PI) .WORD $SBD ;FRACT(X/2PI) .WORD X4 ;4*FRACT(X/2PI) .WORD DUP ;2 COPIES .WORD $DINT ;INT(4*FRACT(X/2PI)) .WORD QUAD ;SAVE INT(......) .WORD $SBD ;Y=q .TITLE CSIN01 ; ; CSINCS V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL CSIN,CCOS,SIN,COS,EXP,$FCALL,$ADR .GLOBL $SBR,$DVR,$MLR ; CSIN --- COMPLEX SINE ROUTINE. ; CCOS --- COMPLEX COSINE ROUTINE. ; CALLING SEQUENCE: ; JSR R5,CSIN (OR CCOS) ; BR A ; .WORD #(X+IY) ;A: ; RETURNS COMPLEX RESULT IN R0 - R3. ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 CSIN: CLR -(SP) ;FLAG CSIN BR SINCOS CCOS: r .TITLE PWRI01 ; ; $PWRI V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $PWRI,$MLR,$DVR,$ERR ; REAL BASE TO INTEGER EXPONENT PROCESSING ; CALLED IN THE POLISH MODE. ; THE INTEGER EXPONENT IS @SP ; THE REAL BASE IS AT 2(SP) AND 4(SP). ; THIS ROUTINE REPLACES THEM WITH R**I. R4=%4 R5=%5 SP=%6 $PWRI: MOV @SP,-(SP) ;DUPLICATE EXPONENT BGE EPOS ;JUMP IF + NEG @SP ;GET ABS VALUE OF EXPONENT EPOS: MOV R4,-(SP) ;SAVE R4 s023143 .WORD 136231 ;-.00467376557 ; .WORD 153672 .WORD 035036 ;.00015148419 .END tFRACT(4*FRACT(X/2PI)) .WORD QSET ;REDUCE Y TO (-1,1) QSETRE: .WORD DUP ;2 COPIES .WORD DUP ;3 COPIES .WORD $MLD ;Y*Y .WORD POLY ;PUSH COEFFICIENTS XPAND: .WORD $MLD,$ADD,$MLD,$ADD,$MLD,$ADD,$MLD,$ADD .WORD $MLD,$ADD,$MLD,$ADD,$MLD,$ADD,$MLD,$ADD .WORD $MLD ;Y*P(Y*Y) .WORD RTN RTN: MOV (SP)+,R0 ;POP HIGH ORDER RESULT MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 TST (SP)+ ;POP QUADRANT FLAG BGE RTN1 ;JUMP IF ARGUMENT WAS + ADD #100000,R0 ;SINuMOV @PC,-(SP) ;FLAG CCOS SINCOS: MOV R5,-(SP) ;SAVE RETURN MOV 2(R5),R5 ;GET ARG POINTER MOV R5,-(SP) ;SAVE IT MOV #SIN,R4 ;POINT TO SIN JSR PC,$FCALL ;GET SIN (X) MOV (SP)+,R5 ;GET X ADDRESS AGAIN MOV R1,-(SP) ;SAVE SINE MOV R0,-(SP) MOV #COS,R4 ;POINT TO COS JSR PC,$FCALL MOV R1,-(SP) ;PUSH COS (X) MOV R0,-(SP) CMP -(SP),-(SP) ;GET SPACE FOR IM(RESULT) MOV 12.(SP),R5 ;GET ARG POINTER MOV 2(R5),R5 CMP (R5)+,(R5)+ ;POINT TO Y vASR 2(SP) ;TEST EXPONENT BCC EVEN ;JUMP IF EVEN MOV 8.(SP),-(SP) ;R TO WORK SPACE MOV 8.(SP),-(SP) TST 6(SP) ;TEST REST OF EXPONENT BEQ DONE1 ;JUMP IF EXP WAS 1 BR EVODD EVEN: CLR -(SP) ;PUT 1. IN WORK SPACE MOV #40200,-(SP) TST 6(SP) ;TEST REST OF EXPONENT BNE EVODD ;JUMP IF EXPONENT NOT 0 TST 10.(SP) ;TEST R BNE DONE1 ;JUMP IF BASE NOT 0 BR ERROR1 ;0**0 NOT DEFINED EVODD: MOV 12.(SP),-(SP) ;GET R MOV 12.(SP),-(SP) SQUAR: MOV 2(SP)x(-X)=-SIN(X) RTN1: MOV (SP)+,R5 RTS R5 ;BACK TO CALLER ; DUP: MOV 6(SP),-(SP) ;DUPLICATE STACK ITEM MOV 6(SP),-(SP) MOV 6(SP),-(SP) MOV 6(SP),-(SP) JMP @(R4)+ ; X4: TST @SP ;CHECK FOR 0 FRACTION BEQ RTN ;QUIT NOW INCB 1(SP) ;QUADRUPLE STACK ITEM JMP @(R4)+ ; QUAD: BIS @SP,16.(SP) ;SAVE QUADRANT NUMBER JMP @(R4)+ ; QSET: TSTB 8.(SP) ;TEST QUADRANT BEQ Q13 ;JUMP IF FIRST OR THIRD QUAD ADD #100000,@SP ;NEGATE STACK ITEM CLR -(SP) yMOV #EXP,R4 ;POINT TO EXP JSR PC,$FCALL MOV R1,-(SP) ;PUSH EXP (Y) MOV R0,-(SP) CLR -(SP) ;PUSH A 1. MOV #40200,-(SP) MOV R1,-(SP) MOV R0,-(SP) JSR R4,POLSH .WORD $DVR,DUP ;GET EXP (-Y) .WORD $ADR,UP ;GET SUM .WORD $SBR,HALV ;GET DIFFERENCE DUP: MOV 6(SP),-(SP) ;GET 2 COPIES MOV 6(SP),-(SP) MOV 6(SP),-(SP) MOV 6(SP),-(SP) JMP @(R4)+ ; UP: MOV (SP)+,10.(SP) ;SAVE SUM OF EXPONENTIALS MOV (SP)+,10.(SP) JMP @(R4)+ ; HALV: z,-(SP) ;DUPLICALTE CURRENT POWER OF R MOV 2(SP),-(SP) JSR R4,POLSH ;SQUARE CURRENT POWER OF R .WORD $MLR,ASR ASR: ASR 10.(SP) ;TEST EXPONENT BIT BCC SQUAR ;JUMP IF 0 MOV 6(SP),-(SP) ;GET PARTIAL RESULT MOV 6(SP),-(SP) MOV 6(SP),-(SP) ;GET R**2**N MOV 6(SP),-(SP) JSR R4,POLSH ;FORM NEW PARTIAL RESULT .WORD $MLR,UNPOL UNPOL: MOV (SP)+,6(SP) ;STORE IN WORK SPACE MOV (SP)+,6(SP) TST 10.(SP) ;TEST REMAINDER OF EXPONENT BNE SQUAR ;JUMP IF MORE { .TITLE PWRR01 ; ; $PWRR V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $PWRR,ALOG,EXP,$MLR,$FCALL,$ERRA ; REAL BASE TO REAL EXPONENT PROCESSING ; CALLED IN THE POLISH MODE. ; THE BASE (B) IS AT 4(SP) AND 6(SP), AND ; THE EXPONENT (E) IS AT @SP AND 2(SP). ; THIS ROUTINE REPLACES THEM WITH B**E. R0=%0 R1=%1 R2=%2 R4=%4 R5=%5 SP=%6 PC=%7 $PWRR: MOV (SP)+,R0 ;GET EXPONENT MOV (SP)+,R1 MOV SP,R2 ;KEEP POINTER TO |CLR -(SP) CLR -(SP) ;PUSH A FLOATING 1. MOV #40200,-(SP) JSR R4,POLSH ;ENTER POLISH .WORD $ADD,QSETR ;X=1.-X QSETR: MOV #QSETRE,R4 ;POINT BACK INTO LIST Q13: ASRB 9.(SP) ;TEST QUADRANT ; BCC QOUT ;JUMP IF FIRST OR SECOND ADD #100000,@SP ;NEGATE STACK ITEM QOUT: JMP @(R4)+ ; POLY: MOV (SP)+,R0 ;SAVE Y*Y MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 MOV #CONSTS+8.,R4 ;POINT TO LIST OF COEFFICIENTS MOV #9.,R5 ;NINE CONSTANTS BR POLY1 POLY2: }SUB #200,@SP ;GET HALF THE DIFFERENCE BCS UNDER ;JUMP IF UNDERFLOW BVS UNDER SUB: SUB #200,4(SP) ;HALF THE SUM TST 18.(SP) ;CHECK FLAG BNE COS0 ;JUMP IF CCOS MOV 10.(SP),-(SP) ;GET COS (X) MOV 10.(SP),-(SP) JSR R4,POLSH .WORD $MLR,SIN1 ;GET COS (X) SINH (Y) .WORD $MLR,SOUT ;GET SIN (X) COSH (Y) SIN1: MOV (SP)+,6(SP) ;SAVE PRODUCT MOV (SP)+,6(SP) MOV 10.(SP),-(SP) ;GET SIN (X) MOV 10.(SP),-(SP) JMP @(R4)+ ; COS0: MOV 14.(SP),-(SP) ;G~TO DO DONE: CMP (SP)+,(SP)+ ;FLUSH R**2**N DONE1: TST 8.(SP) ;TEST EXPONENT SIGN BGE EPLUS ;JUMP IF + MOV 2(SP),-(SP) ;MOVE R**+I DOWN MOV 2(SP),-(SP) BEQ ERROR ;JUMP IF R=0 CLR 6(SP) ;INSERT A 1. MOV #40200,4(SP) JSR R4,POLSH ;GET 1/R**+I .WORD $DVR,EPLUS EPLUS: MOV (SP)+,8.(SP) ;MOVE RESULT UP MOV (SP)+,8.(SP) MOV (SP)+,R4 ;RESTORE R4 CMP (SP)+,(SP)+ ;FLUSH EXPONENTS JMP @(R4)+ ;RETURN TO CALLER ERROR: CMP (SP)+,(SP)+ ;FLUSH STACK B MOV R4,-(SP) ;SAVE REGISTERS MOV R5,-(SP) MOV R1,-(SP) ;PUSH EXPONENT MOV R0,-(SP) BGE EPZ ;JUMP IF E >=0 TST @R2 ;CHECK B BLT ERROR ;JUMP IF E <0 AND B <0 BEQ ERROR1 ;JUMP IF E <0 AND B =0 BR BPOS ;JUMP IF E <0 AND B >0 EPZ: TST @R2 ;CHECK B BGT BPOS ;JUMP IF B >0 BEQ B0 ;JUMP IF B =0 TST @SP ;CHECK E BEQ ONE ;JUMP IF B <0 AND E =0 BR ERROR ;JUMP IF B <0 AND E >0 B0: TST @SP ;CHECK E BGT ZERO ;JUMP IF E =0 AND B >0 BR MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) ;PUSH Y*Y MOV R0,-(SP) POLY1: MOV -(R4),-(SP) ;PUSH CONSTANT MOV -(R4),-(SP) MOV -(R4),-(SP) MOV -(R4),-(SP) DEC R5 ;COUNT COEFFICIENTS BGT POLY2 MOV #XPAND,R4 JMP @(R4)+ POLSH: TST (SP)+ JMP @(R4)+ .WORD 026716,106703 ;.587061098171E-11 .WORD 045277,146362 ; .WORD 130467,136273 ;-.66843217206396E-9 .WORD 103054,123153 ; .WORD 032164,074657 ;.5692134872719023E-7 .WORD 047254,154742 ; ET SIN (X) MOV 14.(SP),-(SP) ADD #100000,@SP ;NEGATE IT JSR R4,POLSH .WORD $MLR,COS1 ;GET SIN (X) -SINH (Y) .WORD $MLR,COUT ;GET COS (X) COSH (Y) COS1: MOV (SP)+,10.(SP) ;SAVE PRODUCT MOV (SP)+,10.(SP) JMP @(R4)+ ; COUT: CLR R4 ;FLAG COS SOUT: MOV (SP)+,R0 ;REAL PART TO REGS MOV (SP)+,R1 MOV (SP)+,R2 ;IMAGINARY PART TO REGS MOV (SP)+,R3 TST R4 ;CHECK MODE BEQ OUT ;JUMP IF CCOS CMP (SP)+,(SP)+ ;FLUSH SIN (X) OUT: MOV (SP)+,R5 TSTERROR1: JSR R5,$ERR ;ERROR 3,21 BR EPLUS .BYTE 3 .BYTE 21. POLSH: TST (SP)+ JMP @(R4)+ .END ERROR1 BPOS: MOV #ALOG,R4 ;POINT TO ALOG MOV R2,R5 ;POINT TO B JSR PC,$FCALL ;GO GET LOG(B) MOV R1,-(SP) ;PUSH ALOG(B) MOV R0,-(SP) JSR R4,POLSH ;GET E*ALOG(B) .WORD $MLR,UNPOL UNPOL: MOV SP,R5 ;POINT TO E*LN(B) MOV #EXP,R4 ;POINT TO EXP JSR PC,$FCALL OUT: CMP (SP)+,(SP)+ ;FLUSH E*LN(B) MOV (SP)+,R5 MOV (SP)+,R4 MOV R0,@SP ;PUT RESULT ON STACK MOV R1,2(SP) JMP @(R4)+ ;RETURN TO CALLER ONE: MOV #402,R0 ;RETURN 1. BR ZERO1 ERROR .WORD 133561,101646 ;-.3598843007208693E-5 .WORD 167216,134016 ; .WORD 035050,036032 ;.1604411847068221E-3 .WORD 041214,103131 ; .WORD 136231,064546 ;-.4681754135302643E-2 .WORD 071423,125024 ; .WORD 037243,032743 ;.7969262624616544E-1 .WORD 035655,051557 ; .WORD 140045,056747 ;-.6459640975062462 .WORD 030455,171222 ; CONSTS: .WORD 040311,007732 ;1.570796326794897 .WORD 121041,064302 ; .END (SP)+ ;FLUSH FLAG RTS R5 ;RETURN TO USER UNDER: CLR @SP ;ZERO UNDERFLOW CLR 2(SP) BR SUB POLSH: TST (SP)+ JMP @(R4)+ .END : MOV #12003,R0 ;ERROR 3,20 BR ECALL ERROR1: MOV #11403,R0 ;ERROR 3,19 ECALL: JSR R5,$ERRA ZERO: CLR R0 ;RETURN 0 ZERO1: CLR R1 BR OUT POLSH: TST (SP)+ JMP @(R4)+ .END .TITLE PWDD01 ; ; $PWDD V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS ; .CSECT .GLOBL $PWDD,$PWDR,DLOG,DEXP,$MLD,$FCALL,$ERRA .GLOBL $PWRD ; DOUBLE BASE TO REAL OR DOUBLE EXPONENT PROCESSING ; CALLED IN THE POLISH MODE. ; THE EXPONENT (E) IS ON TOP OF THE STACK, ; AND THE BASE (B) IS THE SECOND ITEM ON THE STACK. R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 $PWRD: MOV (SP)+,R0 ;GET DOUBLE EXPONENT MOV (SP)+,R1 MOV .TITLE PWDI01 ; ; $PWDI V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $PWDI,$MLD,$DVD,$ERR ; DOUBLE BASE TO INTEGER EXPONENT PROCESSING ; CALLED IN THE POLISH MODE. ; THE INTEGER EXPONENT IS @SP ; THE DOUBLE BASE IS AT 2(SP) THRU 8.(SP). ; THIS ROUTINE REPLACES THEM WITH D**I. R4=%4 R5=%5 SP=%6 $PWDI: MOV @SP,-(SP) ;DUPLICATE EXPONENT BGE EPOS ;JUMP IF + NEG @SP ;GET ABS VALUE OF EXPONENT EPOS: MOV R4,-(SP) ;SAVE .TITLE PWII01 ; ; $PWII V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL $PWII,$MLI,$ERR ; INTEGER BASE (B) TO INTEGER EXPONENT (E) PROCESSING ; CALLED IN THE POLISH MODE ; E IS @SP, AND B IS AT 2(SP) ; THIS ROUTINE REPLACES THEM WITH B**I ; R0=%0 R4=%4 R5=%5 SP=%6 $PWII: MOV (SP)+,R0 ;GET EXPONENT BLE EXPLE ;JUMP IF E <=0 MOV R4,-(SP) ;SAVE REGS MOV R5,-(SP) MOV R0,R5 ;E TO SAFE REGISTER ASR R5 ;TEST E B(SP)+,R2 MOV (SP)+,R3 MOV 2(SP),-(SP) ;MAKE BASE DOUBLE PRECISION MOV 2(SP),-(SP) CLR 4(SP) CLR 6(SP) BR PWD ;JOIN PWDD $PWDR: MOV (SP)+,R0 ;GET REAL EXPONENT MOV (SP)+,R1 CLR R2 CLR R3 BR PWD ;JOIN $PWDD $PWDD: MOV (SP)+,R0 ;GET EXPONENT MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 PWD: MOV R4,-(SP) ;SAVE REGISTERS MOV R5,-(SP) MOV SP,R5 CMP (R5)+,(R5)+ ;POINT TO BASE MOV R3,-(SP) ;PUSH EXPONENT MOV R2,-(SP) MOV R1,-( .TITLE MIX102 ; ; MIMAX1 V002A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL AMAX1,MAX1,AMIN1,MIN1,$CMR,$RI ; THE FORTRAN AMAX1,MAX1,AMIN1,MIN1 FUNCTIONS ; CALLING SEQUENCE: ; JSR R5,AMAX1 (0R MAX1,AMIN1,MIN1) ; BR A ; .WORD ADDRESS OF FIRST ARGUMENT ; . ; . ; . ; .WORD ADDRESS OF LAST ARGUMENT ;A: ; AMAX1 (AMIN1) RETURNS THE LARGEST (SMALLEST) ; REAL ARGUMENT IN R0, R1. ; MAX1 (MIN1) RETURNS THE INTEGER EQUIVALENT OF ; THER4 ASR 2(SP) ;TEST EXPONENT BCC EVEN ;JUMP IF EVEN MOV 12.(SP),-(SP) ;D TO WORK SPACE MOV 12.(SP),-(SP) MOV 12.(SP),-(SP) MOV 12.(SP),-(SP) TST 10.(SP) ;TEST REST OF EXPONENT BEQ DONE1 ;JUMP IF EXP WAS 1 BR EVODD EVEN: CLR -(SP) ;PUT 1. IN WORK SPACE CLR -(SP) CLR -(SP) MOV #40200,-(SP) TST 10.(SP) ;TEST REST OF EXPONENT BNE EVODD ;JUMP IF EXPONENT NOT 0 TST 14.(SP) ;TEST D BNE DONE1 ;JUMP IF BASE NOT 0 BR ERROR1 ;0**0 NOT DIT BCC EVEN ;JUMP IF E EVEN MOV 4(SP),-(SP) ;B TO WORK SPACE TST R5 ;TEST REST OF EXPONENT BEQ DONE ;JUMP IF ALL DONE BR EVODD EVEN: MOV #1,-(SP) ;1 TO WORK SPACE EVODD: MOV 6(SP),-(SP) ;GET B SQUAR: MOV @SP,-(SP) ;SQUARE CURRENT POWER OF B JSR R4,POLSH ;GO $MLI .WORD $MLI,ASR ASR: ASR R5 ;TEST E BIT BCC SQUAR ;JUMP IF A 0 MOV @SP,-(SP) ;GET B**2**N MOV 4(SP),-(SP) ;GET PARTIAL RESULT FROM WORK JSR R4,POLSH ;FORM NEW PARTIAL RESULT .WSP) MOV R0,-(SP) BGE EPZ ;JUMP IF E >=0 TST @R5 ;CHECK B BLT ERROR ;JUMP IF E <0 AND B <0 BEQ ERROR1 ;JUMP IF E <0 AND B =0 BR BPOS ;JUMP IF E <0 AND B >0 EPZ: TST @R5 ;CHECK B BGT BPOS ;JUMP IF B >0 BEQ B0 ;JUMP IF B =0 TST @SP ;CHECK E BEQ ONE ;JUMP IF B <0 AND E =0 BR ERROR ;JUMP IF B <0 AND E >0 B0: TST @SP ;CHECK E BGT ZERO ;JUMP IF E =0 AND B >0 BR ERROR1 BPOS: MOV #DLOG,R4 ;POINT TO DLOG JSR PC,$FCALL ;GET DLOG(B) M RESULT OF AMAX1 (AMIN1) IN R0. ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 AMIN1: MOV @PC,-(SP) ;SET MIN FLAG BR MINMAX ; MIN1: MOV @PC,-(SP) ;SET MIN FLAG BR MIN1A ; MAX1: CLR -(SP) ;SET MAX FLAG MIN1A: MOV (R5)+,-(SP) ;GET NUMBER OF ARGS CLRB 1(SP) BR MMD ; AMAX1: CLR -(SP) ;FLAG MAX MINMAX: MOV (R5)+,-(SP) ;GET NUMBER OF ARGS MMD: TST -(SP) ;GET POINTER SPACE MMA: MOV (R5)+,@SP ;GET ITEM ADDRESS DECB 2(SP) ;COUNT ITEFINED EVODD: MOV 20.(SP),-(SP) MOV 20.(SP),-(SP) MOV 20.(SP),-(SP) MOV 20.(SP),-(SP) SQUAR: MOV 6(SP),-(SP) ;DUPLICATE CURRENT POWER OF D MOV 6(SP),-(SP) MOV 6(SP),-(SP) MOV 6(SP),-(SP) JSR R4,POLSH ;SQUARE CURRENT POWER OF R .WORD $MLD,ASR ASR: ASR 18.(SP) ;TEST EXPONENT BIT BCC SQUAR ;JUMP IF 0 MOV 14.(SP),-(SP) ;GET PARTIAL RESULT MOV 14.(SP),-(SP) MOV 14.(SP),-(SP) MOV 14.(SP),-(SP) MOV 14.(SP),-(SP) ;GET R**2**N MOV 14.(SP),-ORD $MLI,UNPOL UNPOL: MOV (SP)+,2(SP) ;PARTIAL RESLT TO WORK SPACE TST R5 ;TEST REST OF E BNE SQUAR ;JUMP IF MORE TO DO TST (SP)+ ;POP B**2**N DONE: MOV (SP)+,4(SP) ;MOVE RESULT UP MOV (SP)+,R5 ;RESTORE REGS MOV (SP)+,R4 JMP @(R4)+ ;RETURN TO USER ; EXPLE: BLT EXPLT ;JUMP IF E <0 TST @SP ;CHECK B BEQ ERROR ;JUMP IF E=0 AND B =0 ONE: MOV #1,@SP ;ANSWER IS 1 JMP @(R4)+ ;RETURN TO USER EXPLT: TST @SP ;TEST B BEQ ERROR ;JUMP IF E <0 AND B OV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) ;PUSH DLOG(B) MOV R0,-(SP) JSR R4,POLSH ;GET E*DLOG(B) .WORD $MLD,UNPOL UNPOL: MOV SP,R5 ;POINT TO E*LN(B) MOV #DEXP,R4 ;POINT TO DEXP JSR PC,$FCALL ;GET EXP(E*LN(B)) OUT: ADD #8.,SP ;FLUSH E*LN(B) MOV (SP)+,R5 MOV (SP)+,R4 MOV R0,@SP ;PUT RESULT ON STACK MOV R1,2(SP) MOV R2,4(SP) MOV R3,6(SP) JMP @(R4)+ ;RETURN TO USER ONE: MOV #402,R0 ;RETURN 1. BR ZERO1 ERROR: MOV #11003,R0 ;ERROR 3,EMS BLE MME ;JUMP IF DONE MMC: MOV @SP,R0 ;GET ITEM ADDRESS MOV 2(R0),-(SP) ;MOVE ITEM MOV @R0,-(SP) MOV @R5,R0 ;GET SECOND ITEM MOV 2(R0),-(SP) MOV @R0,-(SP) JSR R4,POLSH ;ENTER POLISH MODE .WORD $CMR,UNPOL ;GO COMPARE ITEMS UNPOL: BLT LOW ;JUMP IF FIRST IS LOW TST 4(SP) ;CHECK FLAG BEQ MMF ;JUMP IF MAX BR MMA LOW: TST 4(SP) BEQ MMA ;JUMP IF MAX MMF: TST (R5)+ ;POINT TO NEXT ITEM DECB 2(SP) ;COUNT ITEMS BGT MMC MME: MOV ((SP) MOV 14.(SP),-(SP) MOV 14.(SP),-(SP) JSR R4,POLSH ;FORM NEW PARTIAL RESULT .WORD $MLD,UNPOL UNPOL: MOV (SP)+,14.(SP) ;STORE IN WORK SPACE MOV (SP)+,14.(SP) MOV (SP)+,14.(SP) MOV (SP)+,14.(SP) TST 18.(SP) ;TEST REMAINDER OF EXPONENT BNE SQUAR ;JUMP IF MORE TO DO DONE: ADD #8.,SP ;FLUSH D**2**N DONE1: TST 12.(SP) ;TEST EXPONENT SIGN BGE EPLUS ;JUMP IF + MOV 6(SP),-(SP) ;MOVE D**+I DOWN MOV 6(SP),-(SP) MOV 6(SP),-(SP) MOV 6(SP),-(SP=0 BLT BLT ;JUMP IF B <0 DEC @SP ;GET BASE -1 BEQ ONE ;JUMP IF BASE WAS 1 CLR: CLR @SP ;ANSWER IS 0 JMP @(R4)+ ;RETURN TO USER BLT: ADD #2,@SP ;GET E +2 BLE CLR ;JUMP IF B <-1 ASR R0 ;TEST E BCC RTN ;JUMP IF EVEN NEG @SP ;ANSWER IS -1 RTN: JMP @(R4)+ ;RETURN TO USER ERROR: JSR R5,$ERR ;ERROR 3,15 JMP @(R4)+ .BYTE 3 .BYTE 15. ; POLSH: TST (SP)+ JMP @(R4)+ .END 18 BR ECALL ERROR1: MOV #10403,R0 ;ERROR 3,17 ECALL: JSR R5,$ERRA ZERO: CLR R0 ;RETURN 0 ZERO1: CLR R1 BR OUT ; POLSH: TST (SP)+ JMP @(R4)+ .END SP)+,R1 ;GET RESULT ADDRESS TST (SP)+ ;POP COUNT AND TEST FIX FLAG BEQ FIX ;JUMP IF MAX1 OR MIN1 MOV @R1,R0 ;RETURN RESULT TO USER MOV 2(R1),R1 TST (SP)+ ;POP MAX/MIN FLAG RTS R5 ; FIX: MOV 2(R1),-(SP) ;MOVE RESULT TO STACK MOV @R1,-(SP) JSR R4,POLSH .WORD $RI,UNPOL1 ;GO CONVERT REAL TO INTEGER UNPOL1: MOV (SP)+,R0 ;POP RESULT TO R0 TST (SP)+ ;POP MAX/MIN FLAG RTS R5 POLSH: TST (SP)+ JMP @(R4)+ .END ) BEQ ERROR ;JUMP IF D=0 CLR 14.(SP) ;INSERT A 1. CLR 12.(SP) CLR 10.(SP) MOV #40200,8.(SP) JSR R4,POLSH ;GET 1/D**+I .WORD $DVD,EPLUS EPLUS: MOV (SP)+,12.(SP) ;MOVE RESULT UP MOV (SP)+,12.(SP) MOV (SP)+,12.(SP) MOV (SP)+,12.(SP) MOV (SP)+,R4 ;RESTORE R4 CMP (SP)+,(SP)+ ;FLUSH EXPONENTS JMP @(R4)+ ;RETURN TO CALLER ERROR: ADD #8.,SP ;FLUSH STACK ERROR1: JSR R5,$ERR ;ERROR 3,16 BR EPLUS .BYTE 3 .BYTE 16. ; POLSH: TST (SP)+ JMP @(R4)+ .END .TITLE MOD01 ; ; MOD V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL MOD,$DVI,$MLI ; THE FORTRAN MOD FUNCTION ; CALLING SEQUENCE: ; JSR R5,MOD ; BR A ; .WORD ADDRESS OF FIRST ARGUMENT ; .WORD ADDRESS OF SECOND ARGUMENT ;A: ; RETURNS ARG1-(ARG1/ARG2)*ARG2 IN R0 ; R0=%0 R4=%4 R5=%5 SP=%6 MOD: MOV @2(R5),-(SP) ;PUSH FIRST ARG MOV @4(R5),-(SP) ;PUSH SECOND ARG MOV @2(R5),-(SP) MOV @4(R5),-(SP) JSR R4,POL .TITLE DIM01 ; ; DIM V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL DIM,$SBR ; THE FORTRAN DIM FUNCTION ; CALLING SEQUENCE: ; JSR R5,DIM ; BR A ; .WORD FIRST ARGUMENT ADDRESS ; .WORD SECOND ARGUMENT ADDRESS ;A: ; RETURNS ARG1-ARG2 IN R0 AND R1 IF ARG1>ARG2 ; RETURNS 0 OTHERWISE. ; R0=%0 R1=%1 R4=%4 R5=%5 SP=%6 DIM: MOV 2(R5),R0 ;GET FIRST ARG ADDRESS MOV 2(R0),-(SP) ;PUSH FIRST ARG MOV @R0,-(SP) MOVSH ;ENTER POLISH MODE .WORD $DVI,$MLI,SBI ;(ARG1/ARG2)*ARG2 SBI: SUB (SP)+,@SP ;ARG1-(ARG1/ARG2)*ARG2 MOV (SP)+,R0 ;POP RESULT POLSH: TST (SP)+ JMP @(R4)+ .END 4(R5),R0 ;GET SECOND ARG ADDRESS MOV 2(R0),-(SP) ;PUSH SECOND ARG ON STACK MOV @R0,-(SP) JSR R4,POLSH ;ENTER POLISH MODE .WORD $SBR,UNPOL UNPOL: MOV (SP)+,R0 ;POP DIFFERENCE BLT NEG ;JUMP IF ARG1 2**24, THE RESULT IS ; SIGN(ARG1)*PI/2. ; IF ARG2 <0 THE RESULT IS ARCTAN(ARG1/ARG2) + ; SIGN(ARG1)*PI. ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 ATAN2: CLR -(SP) ;CLEAR SIGN FLAG CLR -(SP) ;CLEAR ATAN2 BIAS CLR -(SP) CLR -(SP) ;CLEAR QUADRANT BIAS CLR -(SP) MOV 2(R5),R4 ;GET FIRST ARG ADDRESS MOV 2(R4),-(SP) ;GET FIRST ARG MOV @R4,-(SP) MOV @SP,R0 ;ARG1 TO R0 MOV 4(R5),R4 ;GET SECOND ARG ADDRESS MOV 2(R4),-(SP) : MOV (SP)+,R0 ;POP REAL RESULT MOV (SP)+,R1 RTS R5 ;RETURN TO CALLER HI: TST R2 ;CHECK FLAG BNE FLUSH ;JUMP IF AMIN0 BR NEXT ;AMAX0 ; POLSH: TST (SP)+ JMP @(R4)+ .END ;GET SECOND ARG MOV @R4,-(SP) MOV @SP,R1 ;ARG2 TO R1 BEQ INF ;JUMP IF DENOMINATOR IS 0 ASL R0 ;GET ABS VAL ARG1 CLRB R0 ;GET EXPONENT SWAB R0 ASL R1 CLRB R1 ;GET EXPONENT ARG2 SWAB R1 SUB R1,R0 ;GET EXPONENT DIFFERENCE CMP #26.,R0 ;CHECK MAGNITUDE BLT INF ;TREAT AS INFINITY DIV: JSR R4,POLSH .WORD $DVR,UNPOL ;GET ARG1/ARG2 UNPOL: TST @4(R5) ;IF ARG2 >0, BIAS =0 BGE ATANE ;IF ARG2<0, BIAS=SIGN(ARG1)*PI MOV #040511,8.(SP) ;PI M .TITLE DATN01 ; ; DATAN V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL DATAN,DATAN2,$ADD,$SBD,$MLD,$DVD ; THE FORTRAN DATAN AND DATAN2 FUNCTIONS ; CALLING SEQUENCE FOR DATAN: ; JSR R5,DATAN ; BR A ; .WORD ARGUMENT ADDRESS ;A: ; RETURNS ARCTAN(ARG) IN R0 AND R1. ; ; CALLING SEQUENCE FOR DATAN2: ; JSR R5,DATAN2 ; BR A ; .WORD ARGUMENT 1 ADDRESS ; .WORD ARGUMENT 2 ADDRESS ;A: ; RETURNS ACRTAN(ARG1/ARG2) IN R0 AND R1. ; .TITLE EXP01 ; ; EXP V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL EXP .GLOBL $ADR,$DVR,$IR,$MLR,$RI,$SBR,$ERRA ; EXP THE REAL EXPONENTIATION ROUTINE ; CALLING SEQUENCE: ; JSR R5,EXP ; BR A ; .WORD ARG ADDRESS ;A: ; RETURNS EXPONENTIAL IN R0 AND R1. ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 EXP: MOV 2(R5),R4 ;GET ARGUMENT POINTER MOV @R4,R0 ;GET HIGH ORDER ARG BGT POS ;JUMP IF ARG + OV #007733,10.(SP) TST @2(R5) ;TEST ARG1 BGE ATANE ADD #100000,8.(SP) ;-PI ATANE: TST @SP ;SET CODES BR ATAN1 ;JOIN MAIN ROUTINE INF: ADD #18.,SP ;FLUSH STACK MOV #040311,R0 ;ANS = SIGN(ARG1)*PI/2 MOV #007733,R1 TST @2(R5) ;TEST ARG1 BGE INFR ;JUMP IF +PI/2 ADD #100000,R0 ;-PI/2 INFR: RTS R5 ;RETURN TO USER ; ATAN: CLR -(SP) ;CLEAR SIGN FLAG CLR -(SP) ;CLEAR ATAN2 BIAS CLR -(SP) CLR -(SP) ;CLEAR QUADRANT BIAS CLR -(SP) MOV IF ABS(ARG1/ARG2) > 2**24, THE RESULT IS ; SIGN(ARG1)*PI/2. ; IF ARG2 <0 THE RESULT IS ARCTAN(ARG1/ARG2) + ; SIGN(ARG1)*PI. ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 DATAN2: MOV R5,-(SP) CLR -(SP) ;CLEAR SIGN FLAG CLR -(SP) ;CLEAR DATAN2 BIAS CLR -(SP) CLR -(SP) CLR -(SP) CLR -(SP) ;CLEAR QUADRANT BIAS CLR -(SP) CLR -(SP) CLR -(SP) MOV 2(R5),R4 ;GET FIRST ARG ADDRESS MOV 6(R4),-(SP) MOV 4(R4),-(SP) MOV 2(R4),-(SP)  CMP R0,#141662 BHI ZERO ;JUMP IF EXPONENT < -88.7 BR SMTST POS: CMP R0,#41660 BHI OVER ;JUMP IF EXPONENT > 87 SMTST: ASL R0 ;DUMP SIGN CMP R0,#63000 BLO ONE ;JUMP IF EXPONENT MAGNITUDE < 2**-28 TST -(SP) ;SAVE SPACE FOR SCALE CLR -(SP) ;PUSH A 1. MOV #40200,-(SP) MOV 2(R4),-(SP) ;GET LOW ORDER ARGUMENT MOV @R4,-(SP) ;HIGH ORDER MOV 2(R4),-(SP) ;NEED TWO COPIES OF IT MOV @R4,-(SP) JSR R4,POLSH ;ENTER POLISH MODE .WORD PL2E ;PUSH L .TITLE DEXP01 ; ; DEXP V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL DEXP,$ADD,$DVD,$SBD,$MLD,$ID,$DI .GLOBL $ERRA ; THE FORTRAN DEXP FUNCTION ; CALLING SEQUENCE: ; JSR R5,DEXP ; BR A ; .WORD ARGUMENT ADDRESS ;A: ; RETURNS E**ARG IN R0 - R3. ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 DEXP: MOV R5,-(SP) ;SAVE RETURN MOV 2(R5),R4 ;GET ARG POINTER MOV @R4,R0 ;GET HIGH ORDER ARG BGT POS ;JUMP 2(R5),R4 ;GET ARG ADDRESS MOV 2(R4),-(SP) ;GET LOW ORDER ARG MOV @R4,-(SP) ;GET HIGH ORDER ATAN1: BGE PLUS ;JUMP IF QUADRANT 1 OR 3 ADD #100000,@SP ;GET ABS VALUE INC 12.(SP) ;FLAG - PLUS: CMP @SP,#40200 ;CHECK IF <1. BLO LE1 ;JUMP IF <1. BGT GT1 ;>1. TST 2(SP) ;CHECK LOW ORDER BEQ LE1 ;=1. GT1: MOV #140311,4(SP) ;-PI/2 MOV #007733,6(SP) ;ATAN(X)=PI/2-ATAN(1/X) DEC 12.(SP) ;ADJUST SIGN MOV 2(SP),-(SP) ;MOVE ARG DOWN MOV 2(SP),-(SP) ;GET FIRST ARG MOV @R4,-(SP) MOV @SP,R0 ;ARG1 TO R0 MOV 4(R5),R4 ;GET SECOND ARG ADDRESS MOV 6(R4),-(SP) MOV 4(R4),-(SP) MOV 2(R4),-(SP) ;GET SECOND ARG MOV @R4,-(SP) MOV @SP,R1 ;ARG2 TO R1 BEQ INF ;JUMP IF DENOMINATOR IS 0 ASL R0 ;GET ABS VAL ARG1 CLRB R0 ;GET EXPONENT SWAB R0 ASL R1 CLRB R1 ;GET EXPONENT ARG2 SWAB R1 SUB R1,R0 ;GET EXPONENT DIFFERENCE CMP #58.,R0 ;CHECK MAGNITUDE BLT INF ;TREAT AS INFINITY DIV: JSR R4,OG2(E) .WORD $MLR .WORD $RI ;FIX LOG2(E)*X .WORD ESAVE ;SAVE EXPONENT SCALE .WORD $IR ;FLOAT IT .WORD PL2E ;PUSH LOG2(E) .WORD $DVR .WORD $SBR .WORD CFRACT ;PUSH CONTINUED FRACTION CONSTANTS .WORD $MLR ;Y*Y .WORD $ADR ;B1+Y*Y .WORD $DVR ;A1/(B1+Y*Y) .WORD $ADR ;Y+A1/(B1+Y*Y) .WORD $ADR ;A0+Y+A1/(B1+Y*Y) .WORD $DVR ;Y/(A0+Y+A1/(B1+Y*Y)) .WORD INC ;-2*Y/(A0+Y+A1/(B1+Y*Y)) .WORD $ADR ;1-2*Y/......... .WORD DUP ;DUPLICATE IT IF + CMP R0,#141662 ;ARG IS - BHI ZERO ;JUMP IF ARG <88.7 BR SMTST ;JUMP TO TEST SMALL MAGNITUDE ARG POS: CMP R0,#41660 BHI OVER ;JUMP IF ARG >87 SMTST: ASL R0 ;DUMP SIGN CMP R0,#43000 BLO ONE ;JUMP IF ARG MAGNITUDE <2**-60 SUB #20.,SP ;GET WORK SPACE ADD #8.,R4 ;POINT TO LOW ORDER ARG MOV -(R4),-(SP) ;PUSH ARG MOV -(R4),-(SP) MOV -(R4),-(SP) MOV -(R4),-(SP) MOV #013761,-(SP) ;PUSH LOG2(E) MOV #024534,-(SP) MOV #125073,-(SP) M MOV #40200,4(SP) ;INSERT 1. CLR 6(SP) JSR R4,POLSH ;COMPUTE 1./X .WORD $DVR,LE1 LE1: MOV 2(SP),-(SP) ;MOVE ARG DOWN MOV 2(SP),-(SP) CLR 4(SP) CLR 6(SP) CMP @SP,#037611 ;TAN(15) BLO LT15 ;JUMP IF LESS THAN TAN(15) BHI TRANS ;JUMP IF > CMP 2(SP),#030243 BLOS LT15 TRANS: MOV #040006,4(SP) ;INSERT PI/6 MOV #005222,6(SP) MOV @SP,R0 ;ARG TO REGS MOV 2(SP),R1 MOV #131727,-(SP) ;PUSH -ROOT 3 MOV #140335,-(SP) MOV R1,-(SP) MOVPOLSH .WORD $DVD,UNPOL ;GET ARG1/ARG2 UNPOL: TST @4(R5) ;IF ARG2 >0, BIAS =0 BGE ATANE ;IF ARG2<0, BIAS=SIGN(ARG1)*PI MOV #040511,16.(SP) ;PI MOV #007732,18.(SP) MOV #121041,20.(SP) MOV #064301,22.(SP) TST @2(R5) ;TEST ARG1 BGE ATANE ADD #100000,16.(SP) ;-PI ATANE: TST @SP ;SET CODES BR ATAN1 ;JOIN MAIN ROUTINE INF: ADD #36.,SP ;FLUSH STACK MOV #040311,R0 ;ANS = SIGN(ARG1)*PI/2 MOV #007732,R1 MOV #121041,R2 MOV #064301,R3 TST @.WORD $MLR ;(1-2*Y/.....)**2 .WORD SCALE ;EXIT POLISH MODE AND SCALE RESULT ONE: CLR R1 MOV #40200,R0 ;EXP(TINY) = 1. RTS R5 OVER: MOV #2404,R0 ;ERROR 4,5 BR ECALL ZERO: MOV #2405,R0 ;ERROR 5,5 ECALL: JSR R5,$ERRA CLR R0 ;RETURN 0 CLR R1 RTS R5 INC: ADD #100200,@SP ;MULTIPLY BY -2.0 JMP @(R4)+ ;GO BACK TO LIST ; DUP: MOV 2(SP),-(SP) ;DUPLICATE STACK ITEM MOV 2(SP),-(SP) JMP @(R4)+ ; PL2E: MOV #125073,-(SP) ;PUSH LOG2(E) MOV #402OV #40270,-(SP) JSR R4,POLSH ;ENTER POLISH MODE .WORD $MLD ;Y=X*LOG2(E) .WORD DUP .WORD $DI ;INT(X*LOG2(E)) .WORD ADJST .WORD $ID ;Z=INT(X*LOG2(E)),Y>=0; Z=Z-1,Y<0 .WORD $SBD .WORD M16 ;D=16*(X*LOG2(E)-FLOAT(Z)) .WORD DUP ;2 COPIES .WORD $DI .WORD DSAVE ;SAVE INTEGER PART OF 2**Y .WORD $ID ;E=D-INT(D) .WORD $SBD,D16 ;E/16 .WORD DUP,DUP ;GET 3 COPIES .WORD $MLD ;E*E .WORD UNPOL ONE: MOV #40200,R0 ;RESULT IS 1. BR Z1 OVER R0,-(SP) ;PUSH ARG CLR -(SP) ;PUSH 1. MOV #40200,-(SP) MOV #131727,-(SP) ;PUSH ROOT3 MOV #040335,-(SP) MOV R1,-(SP) ;PUSH ARG MOV R0,-(SP) JSR R4,POLSH ;TRANSFORM ARG ;  (ROOT3*X-1)/(ROOT3 +X) .WORD $MLR,$SBR,UP,$SBR,$DVR,LT15 LT15: MOV @SP,R0 ;GET ARG MOV 2(SP),R1 MOV R1,-(SP) ;GET THREE COPIES MOV R0,-(SP) MOV R1,-(SP) MOV R0,-(SP) JSR R4,POLSH .WORD $MLR ;GET ARG**2 .WORD POLY ;SET UP COEFFICIENTS .WORD $MLR,$ADR,$MLR,2(R5) ;TEST ARG1 BGE INFR ;JUMP IF +PI/2 ADD #100000,R0 ;-PI/2 INFR: RTS R5 ;RETURN TO USER ; DATAN: MOV R5,-(SP) CLR -(SP) ;CLEAR SIGN FLAG CLR -(SP) ;CLEAR ATAN2 BIAS CLR -(SP) CLR -(SP) CLR -(SP) CLR -(SP) ;CLEAR QUADRANT BIAS CLR -(SP) CLR -(SP) CLR -(SP) MOV 2(R5),R4 ;GET ARG ADDRESS MOV 6(R4),-(SP) MOV 4(R4),-(SP) MOV 2(R4),-(SP) ;GET LOW ORDER ARG MOV @R4,-(SP) ;GET HIGH ORDER ATAN1: BGE PLUS ;JUMP IF QUADRANT 1 OR70,-(SP) JMP @(R4)+ ; ESAVE: MOV @SP,10.(SP) ;SAVE EXPONENT SCALE JMP @(R4)+ ; CFRACT: ROL @SP ;SHIFT MODIFIED ARG ROL R0 ;SAVE SIGN SUB #400,@SP ;DIVIDE BY 2. BLOS ZFRACT ;UNDERFLOW. MAKE ARG 0 ROR R0 ;GET SIGN BACK ROR @SP MOV @SP,R0 ;GET MODIFIED ARGUMENT MOV 2(SP),R1 ;IN REGISTERS MOV #036602,-(SP) ;PUSH -12.01501675 *********** MOV #141100,-(SP) MOV R1,-(SP) MOV R0,-(SP) MOV #071571,-(SP) ;PUSH 601.8042667 *************** MO: MOV #1004,R0 ;ERROR 4,2 BR ECALL ZERO: MOV #2005,R0 ;ERROR 5,4 ECALL: JSR R5,$ERRA CLR R0 ;RESULT IS 0 Z1: CLR R1 CLR R2 CLR R3 BR OUT UNPOL: MOV (SP)+,R0 ;POP E*E TO REGS MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 ; MOV #033343,-(SP) ;PUSH P0=7.213503410844819083 MOV #015345,-(SP) MOV #152405,-(SP) MOV #040746,-(SP) ; MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) MOV R0,-(SP) ; MOV #153703,-(SP) ;PUSH P1=.057761135831801928$ADR,$MLR,$ADR .WORD $MLR,$ADR,$MLR,$ADR .WORD $ADR ;P(X)+0 IF X<=1, P(X)-PI/2 IF X>1 .WORD SIGN ;ADJUST SIGN .WORD $ADR ;ADD ATAN2 BIAS .WORD EXIT EXIT: MOV (SP)+,R0 ;POP RESULT TO REGS MOV (SP)+,R1 TST (SP)+ ;POP SIGN FLAG RTS R5 ;RETURN TO USER ; UP: MOV (SP)+,10.(SP) ;MOVE STACK ITEM UP MOV (SP)+,10.(SP) JMP @(R4)+ ; POLY: MOV (SP)+,R0 ;POP POLY ARG MOV (SP)+,R1 MOV #CONSTS+4,R2 ;POINT TO COEFFICIENT TABLE MOV #5,R3 ;LOOP 5 B 3 ADD #100000,@SP ;GET ABS VALUE INC 24.(SP) ;FLAG - PLUS: CMP @SP,#40200 ;CHECK IF <1. BLO LE1 ;JUMP IF <1. BGT GT1 ;>1. TST 2(SP) ;CHECK LOW ORDER BNE GT1 TST 4(SP) BNE GT1 TST 6(SP) BEQ LE1 ;=1. GT1: MOV #140311,8.(SP) ;-PI/2 MOV #007732,10.(SP) ;ATAN(X)=PI/2-ATAN(1/X) MOV #121041,12.(SP) MOV #064301,14.(SP) DEC 24.(SP) ;ADJUST SIGN MOV 6(SP),-(SP) ;MOVE ARG DOWN MOV 6(SP),-(SP) MOV 6(SP),-(SP) MOV 6(SP),-(SP) V #042426,-(SP) MOV #056133,-(SP) ;PUSH 60.0901907 *********** MOV #041560,-(SP) MOV R1,-(SP) MOV R0,-(SP) MOV R1,-(SP) MOV R0,-(SP) JMP @(R4)+ ; ZFRACT: CMP (SP)+,(SP)+ ;FLUSH CFRACT ARG ;   RESULT IS 1. SCALE: MOV 4(SP),R0 ;GET INTEGER PART OF X*LOG2(E) SWAB R0 ;MAKE IT INTO EXPONENT MODIFIER CLRB R0 ASR R0 ADD (SP)+,R0 ;ADD IN APPROXIMATION RESULT BMI OVER MOV (SP)+,R1 ;GET LOW ORDER PART TST (SP)+ ;FLUSH SCALE RTS R5 ;R MOV #153011,-(SP) MOV #113360,-(SP) MOV #037154,-(SP) ; MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) MOV R0,-(SP) ; MOV #171042,-(SP) ;PUSH Q0=20.8137711965230362973 MOV #074433,-(SP) MOV #101232,-(SP) MOV #041246,-(SP) ; JSR R4,POLSH .WORD $ADD,AUP ;A=E*E+Q0 TO WORK SPACE .WORD $MLD,$ADD,$MLD ;B=(E*E*P1+P0) .WORD TWICE ;DUPLICATE A AND B .WORD $ADD,ABUP ;A+B TO WORD SPACE .WORD $SBD,$DVD ;(A+B)/(A-B) .WORD SCALE ;APPLY SCALE FACR POLY1 POLY2: MOV R1,-(SP) ;PUSH ARG MOV R0,-(SP) POLY1: MOV -(R2),-(SP) ;PUSH CONSTANT MOV -(R2),-(SP) DEC R3 ;COUNT BGT POLY2 JMP @(R4)+ ; SIGN: TST 8.(SP) ;CHECK SIGN FLAG BEQ SIGN1 ADD #100000,@SP ;NEGATE RESULT FOR (-1,0) & (1,INF) SIGN1: JMP @(R4)+ .WORD 037305,035302 ;.0963034789 .WORD 137421,056514 ;-.1419574624 .WORD 037514,143333 ;.1999773201 .WORD 137652,125244 ;-.3333331319 CONSTS: .WORD 040200,000000 ;.9999999999 ; POLSMOV #40200,8.(SP) ;INSERT 1. CLR 10.(SP) CLR 12.(SP) CLR 14.(SP) JSR R4,POLSH ;COMPUTE 1./X .WORD $DVD,LE1 LE1: MOV 6(SP),-(SP) ;MOVE ARG DOWN MOV 6(SP),-(SP) MOV 6(SP),-(SP) MOV 6(SP),-(SP) CLR 8.(SP) ;INSERT A 0. CLR 10.(SP) CLR 12.(SP) CLR 14.(SP) CMP @SP,#037611 ;TAN(15) BLO LT15 ;JUMP IF LESS THAN TAN(15) BHI TRANS ;JUMP IF > CMP 2(SP),#030242 BHI TRANS BLO LT15 CMP 4(SP),#172366 BHI TRANS BLO LT15 CMP ETURN TO CALLER POLSH: TST (SP)+ ;ENTER POLISH MODE JMP @(R4)+ .END TORS SCALE: MOV #ROOTS2+8.,R5 ;POINT TO POWERS OF 2 ASR: ASR 8.(SP) ;SHIFT D BCC NOMULT ;JUMP IF BIT IS OFF MOV -(R5),-(SP) ;PUSH 2**((2**N)*D/16) MOV -(R5),-(SP) MOV -(R5),-(SP) MOV -(R5),-(SP) JSR R4,POLSH .WORD $MLD,ASR ;MULTIPLY BY ABOVE FACTOR AND TEST NOMULT: BEQ SCALE1 SUB #8.,R5 ;POINT TO NEXT POWER OF 2 BR ASR SCALE1: MOV (SP)+,R0 ;POP RESULT MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 TST (SP)+ ;FLUSH D MOV (SP)+,R4 ;GET Z H: TST (SP)+ JMP @(R4)+ .END 6(SP),#065261 BLOS LT15 TRANS: MOV #040006,8.(SP) ;INSERT PI/6 MOV #005221,10.(SP) MOV #140553,12.(SP) MOV #115454,14.(SP) MOV @SP,R0 ;ARG TO REGS MOV 2(SP),R1 MOV 4(SP),R2 MOV 6(SP),R3 MOV #062524,-(SP) MOV #041302,-(SP) MOV #131727,-(SP) ;PUSH -ROOT 3 MOV #140335,-(SP) MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) MOV R0,-(SP) ;PUSH ARG CLR -(SP) CLR -(SP) CLR -(SP) ;PUSH 1. MOV #40200,-(SP) MOV #062524,-(SP) MOV # SWAB R4 CLRB R4 ;MAKE INTO EXPONENT MODIFIER ASR R4 ADD R4,R0 ;APPLY TO RESULT BMI OVER ;JUMP IF OVERFLOW OUT: MOV (SP)+,R5 ;POP RETURN RTS R5 ;RETURN TO USER ; ADJST: TST @2(R5) ;TEST X BGE ARTN ;JUMP IF + DEC @SP ;Z=Z-1 ARTN: MOV @SP,28.(SP) ;SAVE Z AS AN INTEGER JMP @(R4)+ ; M16: ADD #1000,@SP ;16* STACK ITEM JMP @(R4)+ ; D16: SUB #1000,@SP ;1/16*STACK ITEM BPL D16R ;JUMP IF NO UNDERFLOW CLR @SP ;UNDERFLOW=0 D16R: JMP @(R041302,-(SP) MOV #131727,-(SP) ;PUSH ROOT3 MOV #040335,-(SP) MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) ;PUSH ARG MOV R0,-(SP) JSR R4,POLSH ;TRANSFORM ARG ;  (ROOT3*X-1)/(ROOT3 +X) .WORD $MLD,$SBD,UP,$SBD,$DVD,LT15 LT15: MOV @SP,R0 ;GET ARG MOV 2(SP),R1 MOV 4(SP),R2 MOV 6(SP),R3 MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) ;GET THREE COPIES MOV R0,-(SP) MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) MOV R0,-(SP) JSR R4,POLSH .WORD .TITLE CEXP01 ; ; CEXP V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL CEXP,SIN,$FCALL,$MLR,$SBR,COS,$MLC .GLOBL EXP ; CEXP --- COMPLEX EXPONENTIAL ; CALLING SEQUENCE: ; JSR R5,CEXP ; BR A ; .WORD #(X+IY) ;A ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 CEXP: MOV R5,-(SP) ;SAVE RETURN MOV 2(R5),R5 ;GET ARG POINTER CMP (R5)+,(R5)+ ;POINT TO Y MOV R5,-(SP) ;SAVE POINTER MOV #SIN,R4 ;4)+ ; DSAVE: MOV @SP,26.(SP) ;SAVE D AS AN INTEGER JMP @(R4)+ ; AUP: MOV (SP)+,38.(SP) ;A TO WORK SPACE MOV (SP)+,38.(SP) MOV (SP)+,38.(SP) MOV (SP)+,38.(SP) JMP @(R4)+ ; ABUP: MOV (SP)+,22.(SP) ;MOVE A+B TO WORD SPACE MOV (SP)+,22.(SP) MOV (SP)+,22.(SP) MOV (SP)+,22.(SP) JMP @(R4)+ ; DUP: MOV 6(SP),-(SP) ;DUPLICATE STACK ITEM MOV 6(SP),-(SP) MOV 6(SP),-(SP) MOV 6(SP),-(SP) JMP @(R4)+ ; TWICE: MOV #8.,R0 ;EIGHT ITEMS TW1: MOV  .TITLE ALOG01 ; ; ALOG V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL ALOG,ALOG10,$SBR,$ADR,$DVR,$MLR,$IR .GLOBL $ERR ; THE FORTRAN ALOG AND ALOG10 FUNCTIONS ; CALLING SEQUENCE: ; JSR R5,ALOG (OR ALOG10) ; BR A ; .WORD ARGUMENT ADDRESS ;A: ; RETURNS LN(ARG) (OR LOG10(ARG)) IN R0,R1. ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 ALOG10: MOV @PC,-(SP) ;GET 0004XX AS A FLAG BR LOG ALOG: CLR -(S $MLD ;GET ARG**2 .WORD POLY ;SET UP COEFFICIENTS XPAND: .WORD $MLD,$ADD,$MLD,$ADD,$MLD,$ADD .WORD $MLD,$ADD,$MLD,$ADD,$MLD,$ADD .WORD $MLD,$ADD,$MLD,$ADD,$MLD,$ADD .WORD $ADD ;P(X)+0 IF X<=1, P(X)-PI/2 IF X>1 .WORD SIGN ;ADJUST SIGN .WORD $ADD ;ADD ATAN2 BIAS .WORD EXIT EXIT: MOV (SP)+,R0 ;POP RESULT TO REGS MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 TST (SP)+ ;POP SIGN FLAG MOV (SP)+,R5 RTS R5 ;RETURN TO USER ; UP: MOV (SP)+,22.(SP) ;MGET SIN POINTER JSR PC,$FCALL ;CALL SIN MOV (SP)+,R5 ;GET Y POINTER MOV R1,-(SP) ;PUSH SIN(Y) MOV R0,-(SP) MOV #COS,R4 ;POINT TO COS JSR PC,$FCALL ;GET COS(Y) MOV R1,-(SP) ;PUT IT ON STACK MOV R0,-(SP) MOV 8.(SP),R5 ;GET ARG POINTER MOV 2(R5),R5 MOV #EXP,R4 ;GET EXP(X) JSR PC,$FCALL CLR -(SP) ;MAKE COMPLEX FORMAT CLR -(SP) MOV R1,-(SP) ;PUSH EXP(X) MOV R0,-(SP) JSR R4,POLSH .WORD $MLC,RTN ;EXP(X)*(COS(Y)+I*SIN(Y)) RTN: M14.(SP),-(SP) ;DUPLICATE 2 DOUBLES DEC R0 BGT TW1 JMP @(R4)+ ; POLSH: TST (SP)+ JMP @(R4)+ ; .WORD 040265,002363,031771,157145 ;2**1/2 .WORD 040230,033760,050615,134251 ;2**1/4 .WORD 040213,112701,161752,105727 ;2**1/8 ROOTS2: .WORD 040205,125303,063714,044173 ;2**1/16 .END P) ;FLAG ALOG LOG: MOV 2(R5),R4 ;GET ARG ADDRESS MOV #071030,-(SP) ;PUSH -1/2*LN(2) MOV #137661,-(SP) CMP -(SP),-(SP) ;GET WORK SPACE MOV 2(R4),-(SP) ;GET ARG MOV @R4,-(SP) BLE ERROR ;JUMP IF NOT POSITIVE ASL @SP MOVB 1(SP),12.(SP) ;GET EXPONENT MOVB #200,1(SP) ;TRANSFORM ARG TO (1/2,1) ROR @SP MOV #002363,-(SP) ;PUSH 1/2*ROOT2 MOV #040065,-(SP) MOV 6(SP),-(SP) ;PUSH X MOV 6(SP),-(SP) MOV #002363,-(SP) ;PUSH 1/2*ROOT2 MOV #04006OVE STACK ITEM UP MOV (SP)+,22.(SP) MOV (SP)+,22.(SP) MOV (SP)+,22.(SP) JMP @(R4)+ ; POLY: MOV (SP)+,R0 ;POP POLY ARG MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 MOV #CONSTS+8.,R4 ;POINT TO COEFFICIENT TABLE MOV #9.,R5 ;GET # OF CONSTANTS BR POLY1 POLY2: MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) ;PUSH ARG MOV R0,-(SP) POLY1: MOV -(R4),-(SP) ;PUSH CONSTANT MOV -(R4),-(SP) MOV -(R4),-(SP) MOV -(R4),-(SP) DEC R5 ;COUNT BGT POLY2 OV (SP)+,R0 ;PUT RESULT IN REGS MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 MOV (SP)+,R5 ;RESTORE RETURN RTS R5 POLSH: TST (SP)+ JMP @(R4)+ .END 5,-(SP) JSR R4,POLSH ;ENTER POLISH MODE .WORD $SBR,UP,$ADR,$DVR ;GET (X-ROOT2)/     ;(X+ROOT2) .WORD DUP,DUP ;GET THREE COPIES .WORD $MLR,REG,STACK,STACK,STACK ;SET UP POLYNOMIAL .WORD $MLR,$ADR,$MLR,$ADR,$MLR,$ADR,$MLR,$ADR   ;EXPAND POLYNOMIAL .WORD SCALE,$IR,PLN2,$MLR ;GET LN(EXP) .WORD $ADR,EXIT ;COMBINE WITH FRACTION     ;AND CHECK IF DONE .WORD $MLR,EXIT ;MULTIPLY BY LOG10(E) AND RETURN ; REG: MOV (SP)+,R0 ;POP Y MOV (SP)+,R1 MOV MOV #XPAND,R4 JMP @(R4)+ ; SIGN: TST 16.(SP) ;CHECK SIGN FLAG BEQ SIGN1 ADD #100000,@SP ;NEGATE RESULT FOR (-1,0) & (1,INF) SIGN1: JMP @(R4)+ .WORD 037065,150707 ;.0443895157187 .WORD 162300,163030 ; .WORD 137204,143233 ;-.06483193510303 .WORD 004010,000413 ; .WORD 037235,043002 ;.0767936896066 .WORD 027154,142446 ; .WORD 137272,025671 ;-.0909037114191074 .WORD 116412,065630 ; .WORD 037343,107047 ;.11111097898051048 .WORD 023625,025 .TITLE DLOG01 ; ; DLOG V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL DLOG,DLOG10,$SBD,$ADD,$DVD,$MLD,$ID .GLOBL $ERR ; THE FORTRAN DLOG AND DLOG10 FUNCTIONS ; CALLING SEQUENCE: ; JSR R5,DLOG (OR DLOG10) ; BR A ; .WORD ARGUMENT ADDRESS ;A: ; RETURNS LN(ARG) (OR LOG10(ARG)) IN R0 - R3. ; R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 DLOG10: MOV @PC,-(SP) ;GET 0004XX AS A FLAG BR LOG DLOG: CLR -#CONSTS+4,R2 ;POINT TO COEFFICIENTS BR STACKC STACK: MOV R1,-(SP) ;PUSH Y MOV R0,-(SP) STACKC: MOV -(R2),-(SP) ;PUSH COEFFICIENT MOV -(R2),-(SP) JMP @(R4)+ ; UP: MOV (SP)+,10.(SP) ;MOVE ITEM TO WORK SPACE MOV (SP)+,10.(SP) JMP @(R4)+ ; SCALE: CLR -(SP) BISB 6(SP),@SP ;GET EXPONENT SUB #200,@SP ;REMOVE EXCESS 128 JMP @(R4)+ ; DUP: MOV 2(SP),-(SP) MOV 2(SP),-(SP) ;DUPLICATE STACK ITEM JMP @(R4)+ ; PLN2: MOV #071030,-(SP) ;PUSH LN(2) 401 ; .WORD 137422,044444 ;-.14285714102825545 .WORD 071335,116151 ; .WORD 037514,146314 ;.19999999998729448 .WORD 146224,165650 ; .WORD 137652,125252 ;-.33333333333329930 .WORD 125252,113602 ; CONSTS: .WORD 040200,000000 ;.999999999999999 .WORD 000000,000000 ; POLSH: TST (SP)+ JMP @(R4)+ .END  .TITLE CLOG01 ; ; CLOG V001A ; ; COPYRIGHT 1971, DIGITAL EQUIPMENT CORPORATION, MAYNARD,MASS ; .CSECT .GLOBL CLOG,ATAN2,CABS,$FCALL,ALOG ; CLOG --- THE COMPLEX LOGARITHM FUNCTION ; CALLING SEQUENCE: ; JSR R5,CLOG ; BR A ; .WORD #(X+IY) ;A R0=%0 R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 SP=%6 PC=%7 CLOG: MOV R5,-(SP) ;SAVE RETURN POINTER MOV 2(R5),R0 ;POINT TO X MOV #RET,-(SP) ;SET UP CALL TO ATAN2 MOV #137,-(SP) ;JMP MOV R0,-(SP) ;.WORD X (SP) ;FLAG DLOG LOG: MOV R5,-(SP) ;SAVE RETURN POINTER MOV 2(R5),R4 ;GET ARG ADDRESS ADD #8.,R4 ;POINT TO LEAST SIGNIFICANT PART MOV #147572,-(SP) MOV #173721,-(SP) MOV #071027,-(SP) ;PUSH -1/2*LN(2) MOV #137661,-(SP) SUB #8.,SP ;GET WORK SPACE MOV -(R4),-(SP) ;GET ARG MOV -(R4),-(SP) MOV -(R4),-(SP) MOV -(R4),-(SP) BLE ERROR ;JUMP IF NOT POSITIVE ASL @SP MOVB 1(SP),26.(SP) ;GET EXPONENT MOVB #200,1(SP) ;TRANSFORM ARG TO (1/2,1) R MOV #040061,-(SP) JMP @(R4)+ ; EXIT: DECB 5(SP) ;CHECK FOR ALOG10 BLT LOGOUT ;NO, DONE MOV #055731,-(SP) ;PUSH LOG10(E) MOV #037736,-(SP) JMP @(R4)+ LOGOUT: MOV (SP)+,R0 ;POP RESULT MOV (SP)+,R1 TST (SP)+ ;FLUSH FLAG RTS R5 POLSH: TST (SP)+ JMP @(R4)+ ERROR: ADD #14.,SP JSR R5,$ERR ;ERROR 4,10 RTS R5 .BYTE 4 .BYTE 10. ; .WORD 037632,014525 ;.300974506 ; .WORD 037714,120036 ;.399659100 ; .WORD 040052,125332 ;.66666 CMP (R0)+,(R0)+ MOV R0,-(SP) ;.WORD Y MOV #402,-(SP) ;BR .+4 MOV SP,R5  ;JSR R5,ATAN2 JSR R0,ATAN2 RET: ADD #10.,SP ;FLUSH THE ABOVE MOV @SP,R5 ;GET ARG POINTER AGAIN MOV R1,-(SP) ;PUSH ATAN2(Y,X) MOV R0,-(SP) MOV 2(R5),R5 ;POINT TO ARG MOV #CABS,R4 ;POINT TO CABS JSR PC,$FCALL MOV R1,-(SP) ;PUSH CABS(ARG) MOV R0,-(SP) MOV SP,R5 ;POINT TO IT MOV #ALOG,R4 ;POINT TO ALOG JSR PC,$FCALL CMP (SP)+,(SP)+ ;FLUSH CABS(ARG) MOR @SP MOV #157145,-(SP) MOV #031771,-(SP) MOV #002363,-(SP) ;PUSH 1/2*ROOT2 MOV #040065,-(SP) MOV 14.(SP),-(SP) ;PUSH X MOV 14.(SP),-(SP) MOV 14.(SP),-(SP) MOV 14.(SP),-(SP) MOV #157145,-(SP) MOV #031771,-(SP) MOV #002363,-(SP) ;PUSH 1/2*ROOT2 MOV #040065,-(SP) JSR R4,POLSH ;ENTER POLISH MODE .WORD $SBD,UP,$ADD,$DVD ;GET (X-ROOT2)/     ;(X+ROOT2) .WORD DUP,DUP ;GET THREE COPIES .WORD $MLD,REG ;SET UP POLYNOMIAL XPAND: .WORD 9471 ; CONSTS: .WORD 040400,000000 ;1.99999999 .END OV (SP)+,R2 ;GET IM(RESULT) MOV (SP)+,R3 MOV (SP)+,R5 ;RESTORE RETURN RTS R5 .END $MLD,$ADD,$MLD,$ADD,$MLD,$ADD,$MLD,$ADD .WORD $MLD,$ADD,$MLD,$ADD,$MLD,$ADD   ;EXPAND POLYNOMIAL .WORD SCALE,$ID,PLN2,$MLD ;GET LN(EXP) .WORD $ADD,EXIT ;COMBINE WITH FRACTION     ;AND CHECK IF DONE .WORD $MLD,EXIT ;MULTIPLY BY LOG10(E) AND RETURN ERROR: ADD 24.,SP ;FLUSH JUNK JSR R5,$ERR BR EROUT .BYTE 4 .BYTE 3 ; REG: MOV (SP)+,R0 ;POP Y MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 MOV #CONSTS+8.,R4 ;POINT TO COEFFICIENTS MOV #7,R5 ;SEVEN CONSTANTS BR STACKC STACK: MOV R3,-(SP) MOV R2,-(SP) MOV R1,-(SP) ;PUSH Y MOV R0,-(SP) STACKC: MOV -(R4),-(SP) ;PUSH COEFFICIENT MOV -(R4),-(SP) MOV -(R4),-(SP) MOV -(R4),-(SP) DEC R5 ;COUNT CONSTANTS BGT STACK MOV #XPAND,R4 ;SET UP RETURN TO LIST JMP @(R4)+ ; UP: MOV (SP)+,22.(SP) ;MOVE ITEM TO WORK SPACE MOV (SP)+,22.(SP) MOV (SP)+,22.(SP) MOV (SP)+,22.(SP) JMP @(R4)+ ; SCALE: CLR -(SP) BISB 12.(SP),@SP ;GET EXPON`U%G !e *%&&pppl*  2  I fp ~*w&ŕŕE*  pQ $M ep ( .(D & * e&M "-* R E le*$W-@H0,M A2 U*HeK&&*l brENT SUB #200,@SP ;REMOVE EXCESS 128 JMP @(R4)+ ; DUP: MOV 6(SP),-(SP) MOV 6(SP),-(SP) ;DUPLICATE STACK ITEM MOV 6(SP),-(SP) MOV 6(SP),-(SP) JMP @(R4)+ ; PLN2: MOV #147572,-(SP) MOV #173721,-(SP) MOV #071027,-(SP) ;PUSH LN(2) MOV #040061,-(SP) JMP @(R4)+ ; EXIT: DECB 11.(SP) ;CHECK FOR ALOG10 BLT LOGOUT ;NO, DONE MOV #024162,-(SP) MOV #124467,-(SP) MOV #055730,-(SP) ;PUSH LOG10(E) MOV #037736,-(SP) JMP @(R4)+ LOGOUT: MOV (p N* eL %%8 *"FU%Gŕŕ*E pQ $M ep (*  & * e&M  O*&M  W E*$&  e&2*Hp  EeE`E& & $*l0pf$EA B` *xSP)+,R0 ;POP RESULT MOV (SP)+,R1 MOV (SP)+,R2 MOV (SP)+,R3 EROUT: MOV (SP)+,R5 ;RESTORE RETURN TST (SP)+ ;FLUSH FLAG RTS R5 POLSH: TST (SP)+ JMP @(R4)+ ; .WORD 037455,106270 ;.16948212488 .WORD 157166,174770 ; .WORD 037471,072731 ;.1811136267967 .WORD 137716,117115 ; .WORD 037543,111153 ;.22223823332791 .WORD 060101,135465 ; .WORD 037622,044436 ;.2857140915904889 .WORD 007306,063062 ; .WORD 037714,146314 ;.400000001206045365 0   h& &D \*&  ` ic *J1  6!'   6!6 *   ",X*   BaBa6A c JQ r*D  ! Z*h0   * x0 `~*c  J&"6U%G$ 0  *   .WORD 153450,165773 ; .WORD 040052,125252 ;.6666666666633660894 .WORD 125247,004643 ; CONSTS: .WORD 040400,000000 ;2.00000000000000261 .WORD 000000,000057 ; .END x* 9:-  -5@8*$! E*H 6 &M  $*l^ "U%Gwf& * p ,M )p* pT e L*ETTTTL&M *0 5  E Cae3* e D!K!*Df!.M &0 Ef.L Qh&0 L J*&M &&  *$&  R*Hmm$S # $**lm # *f0 Ze $M "*JU%G-B8< y*v! eeH! 6ŕ*ŕE pQ $M $.V[MkY@ox@t!k@=.'uE@'I@'I@(4R@o4N`@.LuE@LI@LI@%ep * (  & * e" D&M *&M e  C D v *$a(    *H& & eEfpE *l & e#E*  E  S* E e`eA G*LA   !W  s* L0(Y@y@R.y@@+}@+@4[M@.@9@9@9@9@{.9@9@0k@K@Kq@.֯o}@֯p}@֯}@گw@گq@6.گs@w@x@y@z@.{@|@}@~@}@.~@~@k@(л@ER@`.ES@!@@ձW@㱰 @. @ $ @&p@2.(@[ @)  Fe 2*  * .M $M "*DU%GŕŕE pQ $M `*hep (  &E * e&M o*&^ ep NE*$& & eEfp E  }*H &  & *l  L* 8  0,&r@(V[Mh"w w w /.~ }LI(4RkY( ~ t$ e . ox kYox"t!kQ&: 10w 6oxگwگqkYox kY(,X @ w$ w$w$2.& ox'I \*    *% 60 r*E   Ee* mLAN   . -*D $.M $M "U%G*hŕŕE pQ $M e[*p (  & * e&M M0'I 'IB.| 4e  5w .t!koxگw"گq(o4N`($.kY LILIo4N`kYLI LI 4.֯}kY@ox@t!k@.'uE@'I@'I@(4R@o4N`@.LuE@LI@LI@Y8@y@R.y@@+}@+@4[M@.@9@9@9@9@{.9@9@0k@K@Kq@.֯o}@֯p}@گw@گq@گs@.w@x@y@z@{@.|@}@~@}@~@{.~@k@(л@ER@ES@.!@@ձW@㱰 @ @ . $ @&p@2.(@V[M@[ @#<&r@(֯}h*w w  t F.~LI(4RkY$t!kD," b"&  #e .oxkYox&t!k]"F  6-h.oxwkYwkY,` *5@ B  $ y@4 .kY wo4N`kYLI&.LIo4N`kYLI LI LI