Google
 

Trailing-Edge - PDP-10 Archives - AP-D480B-SB_1978 - formsc.mac
There are 19 other files named formsc.mac in the archive. Click here to see a list.
	TITLE	FORDBM	%.4C(475) - DUMMY DBMS% FOR FORLIB
	SUBTTL	Mike Gilbert/JNG		22-Nov-75





;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1975,1977 BY DIGITAL EQUIPMENT CORPORATION


	SEARCH	FORPRM		;GET FOROTS SYMBOLS

	SEGMENT			;PUT INTO THE HIGH SEGMENT



	ENTRY	DBMS%		;IN CASE REAL DBPORT NOT IN FORLIB

DBMS%:	SETZ	0,		;INDICATE ERROR TO DBMS ROUTINES
	POPJ	P,

	PRGEND
	TITLE	.MXFOR FOR FORTRAN-10 & F40 SUBROUTINES
	SUBTTL	D.M. NIXON	23-OCT-73

;LINK-10 IF REQUESTED TO, WILL CHANGE ALL FORTRAN ENTRY POINTS TO
;	CAIA
;	PUSHJ	17,.MXFOR##		;F40 ENTRY
;	PUSHJ	17,.SAV15##		;FORTRAN-10 ENTRY
;
;THESE ROUTINES ALLOW ALL COMBINATIONS OF F40 AND FORTRAN-10
;MAIN PROGRAMS AND SUBROUTINES TO BE LOADED AND RUN TOGETHER.
;.JRA16## HANDLES MULTIPLE RETURNS

	ENTRY	.MXFOR
	<SIXBIT	/.MXFOR/>
.MXFOR: POP	17,TEMP#	;POP RETURN OFF STACK
	AOS	TEMP#		;SKIP RETURN (OVER PUSHJ CALL)
	PUSH	17,[0]		;INCASE NEW STYLE MULTIPLE RETURNS
	PUSH	17,15		;INCASE FORTRAN-10
	PUSHJ	17,@TEMP#	;AND GO TO REQUIRED ROUTINE
	  CAIA			;SINGLE RETURN
	JRST	MULRET		;MULTIPLE RETURN
	POP	17,15		;RESTORE AC15
	SKIPE	0(17)		;NON-ZERO FOR MULTIPLE RETURN
	HRR	16,0(17)	;SO GET RETURN ADDRESS
	POP	17,(17)		;RESTORE STACK
	HLRM	16,.+3		;STORE THE ENTRY POINT
	HRLI	16,(CAIA)	;SET UP THE SKIP INS
	HRRM	16,.+2		;STORE THE RETURN ADDRESS
	EXCH	16,.-.		;RESTORE 16 AND THE SKIP INS
	JRST	.-.		;RETURN TO THE CALLER

MULRET:	POP	17,15		;RESTORE AC15
	POP	17,(17)		;RESTORE STACK
	HLRM	16,.+3		;STORE THE ENTRY POINT
	HRLI	16,(CAIA)	;SET UP THE SKIP INS
	HRRM	16,.+2		;STORE THE RETURN ADDRESS
	EXCH	16,.-.		;RESTORE 16 AND THE SKIP INS
	JRST	@.-.		;RETURN TO THE CALLER

	ENTRY	.SAV15
	SIXBIT	/.SAV15/
.SAV15:	POP	17,TEMP#	;GET RETURN OFF STACK
	PUSH	17,15		;SAVE AC 15
	PUSHJ	17,@TEMP#	;GO TO REQUIRED ROUTINE
	  CAIA			;SINGLE RETURN
	JRST	[POP	17,15		;RESTORE AC 15
		POP	17,(17)		;RESTORE STACK
		JRST	@(16)]		;RETURN TO USER
	POP	17,15		;RESTORE 15
	POPJ	17,		;RETURN

	ENTRY	.JRA16
	SIXBIT	/.JRA16/
.JRA16:	AOS	0(17)		;RETURN TO MULTIPLE RETURN ADDRESS
	POPJ	17,		;GO TO IT

IF2,<PURGE TEMP,MULRET>
PRGEND
UNIVERSAL FORMSC %4.(120)	UNIVERSAL FILE TO ASSEMBLE THE FIX/FLOAT FUNCTIONS
SUBTTL	D. TODD /DRT 15-FEB-1973



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
	SEARCH	FORPRM
IF1,<			;PASS 1 ASSEMBLY ONLY
	DEFINE	FLT(X)<
	ENTRY	FLT.'X
	SIXBIT	/FLT.'X/
FLT.'X:
IFE CPU-KA10,<
	HLRE	X+1,X	;COPY THE HI HALT OF X TO LOW X+1
	HLL	X,X+1	;FILL UPPER PART OF X WITH THE SIGH
	FSC	X,233	;FLOAT THE LOW HALT OF THE INTEGER
	SKIPGE	X	;FOR NEGATIVE NUMBERS
	AOJE	X+1,FLT.XT	;CHANGE HIGH PART TO 2'S COMPLEMENT
	FSC	X+1,255	;FLOAT THE HIGH PART
	FADR	X,X+1	;COMBINE THE TWO PARTS
>
IFE CPU-KI10,<
	FLTR	X,X	;USE THE HARDWARE
>
FLT.XT:	POPJ	P,	;RETURN X=THE FLOATING POINT NUMBER
>
	DEFINE	IFX(X)<
	ENTRY	IFX.'X
	SIXBIT	/IFX.'X/
IFX.'X:
IFE CPU-KA10,<
	MULI	X,400		;SEPERATE THE FRACTION AND EXPONENT
	EXCH	X,X+1		;PUT PARTICAL RESULT IN X
	JUMPGE	X+1,IFX.XT	;JUMP IF POSITIVE
	TRC	X+1,-1	;NEGATE THE EXPONENT
	MOVNS	X		;POSITIVE FRACTION
IFX.XT:	ASH	X,-243(X+1)	;USE EXPONENT AS INDEX
	SKIPGE	X+1		;SKIP IF POSITIVE
	MOVNS	X		;NEGATE THE RESULT
>
IFE CPU-KI10,<
	FIX	X,X
>
	POPJ	P,		;RETRURN X=FIXED NUMBER
>
>		;END OF IF1,
	PRGEND
TITLE	FLOAT 	%4.(235) INTEGER TO REAL CONVERSION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	FLOAT
EXTERN	FLOAT.
FLOAT=FLOAT.
PRGEND
TITLE	FLOAT. 	%4.(235) INTEGER TO REAL CONVERSION
SUBTTL	D. TODD /DRT 15-FEB-1973



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;FROM	LIB40	V32.(415)

;36 BIT FLOAT FUNCTION
;CONVERTS A SIGNED FIXED POINT INTEGER TO FLOATING POINT
;BY BREAKING THE INTEGER INTO HIGH ORDER AND LOW ORDER
;FRACTIONS, CALCULATING AN EXPONENT, THEN ADDING THE TWO
;TOGETHER. SINGLE CONVERSION.

;THE ROUTINE IS CALLED AS FOLLOWS:
;	JSA	Q, FLOAT
;	EXP	ARG
;THE ANSWER IS RETURNED IN ACCUMULATOR A

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(FLOAT,.)	;[235] ENTRY TO FLOAT ROUTINE
	MOVE	T0,@(L)	;GET THE ARGUMENT
	PJRST	FLT.0##		;USE FLT.0 ROUTINE
	PRGEND
TITLE	IFIX 	%4.(235) REAL TO INTEGER CONVERSION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	IFIX
EXTERN	IFIX.
IFIX=IFIX.
PRGEND
TITLE	INT 	%4.(235) REAL TO INTEGER CONVERSION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	INT
EXTERN	INT.
INT=INT.
PRGEND
TITLE	IFIX. 	%4.(235) REAL TO INTEGER CONVERSION
SUBTTL	D. TODD /DRT 15-FEB-1973		ED YOURDON/KK/TWE/DMN



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;FROM	LIB40	V.32(415)


;36 BIT FIX FUNCTION
;AN INTEGER RESULT IS OBTAINED BY SEPARATING FRACTION AND
;EXPONENT. THE FRACTION IS SHIFTED N PLACES RIGHT, WHERE
;N = 43 - (EXPONENT-200) (OCTAL)

;THE CALLING SEQUENCE FOR THE ROUTINE IS AS FOLLOWS:
;	JSA	Q, IFIX
;	EXP	ARG
;OR
;	JSA	Q,INT
;	EXP	ARG

;THE ANSWER IS RETURNED IN ACCUMULATOR A

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(INT,.)		;[235] ENTRY TO INT ROUTINE.
	JRST	IFIX1		;GO TO MAIN ROUTINE.

	HELLO	(IFIX,.)	;[235] ENTRY TO IFIX ROUTINE
IFIX1:
	MOVE	T0,@(L)		;GET THE ARGUMENT
	PJRST	IFX.0##		;USE IFX.0
	PRGEND
TITLE FLT.0
SEARCH FORMSC,FORPRM
FLT 0
PRGEND
 
 
TITLE FLT.1
SEARCH FORMSC,FORPRM
FLT 1
PRGEND
 
 
TITLE FLT.2
SEARCH FORMSC,FORPRM
FLT 2
PRGEND
 
 
TITLE FLT.3
SEARCH FORMSC,FORPRM
FLT 3
PRGEND
 
 
TITLE FLT.4
SEARCH FORMSC,FORPRM
FLT 4
PRGEND
 
 
TITLE FLT.5
SEARCH FORMSC,FORPRM
FLT 5
PRGEND
 
 
TITLE FLT.6
SEARCH FORMSC,FORPRM
FLT 6
PRGEND
 
 
TITLE FLT.7
SEARCH FORMSC,FORPRM
FLT 7
PRGEND
 
 
TITLE FLT.10
SEARCH FORMSC,FORPRM
FLT 10
PRGEND
 
 
TITLE FLT.11
SEARCH FORMSC,FORPRM
FLT 11
PRGEND
 
 
TITLE FLT.12
SEARCH FORMSC,FORPRM
FLT 12
PRGEND
 
 
TITLE FLT.13
SEARCH FORMSC,FORPRM
FLT 13
PRGEND
 
 
TITLE FLT.14
SEARCH FORMSC,FORPRM
FLT 14
PRGEND
 
 
TITLE FLT.15
SEARCH FORMSC,FORPRM
FLT 15
PRGEND
 
 
TITLE IFX.0
SEARCH FORMSC,FORPRM
IFX 0
PRGEND
 
 
TITLE IFX.1
SEARCH FORMSC,FORPRM
IFX 1
PRGEND
 
 
TITLE IFX.2
SEARCH FORMSC,FORPRM
IFX 2
PRGEND
 
 
TITLE IFX.3
SEARCH FORMSC,FORPRM
IFX 3
PRGEND
 
 
TITLE IFX.4
SEARCH FORMSC,FORPRM
IFX 4
PRGEND
 
 
TITLE IFX.5
SEARCH FORMSC,FORPRM
IFX 5
PRGEND
 
 
TITLE IFX.6
SEARCH FORMSC,FORPRM
IFX 6
PRGEND
 
 
TITLE IFX.7
SEARCH FORMSC,FORPRM
IFX 7
PRGEND
 
 
TITLE IFX.10
SEARCH FORMSC,FORPRM
IFX 10
PRGEND
 
 
TITLE IFX.11
SEARCH FORMSC,FORPRM
IFX 11
PRGEND
 
 
TITLE IFX.12
SEARCH FORMSC,FORPRM
IFX 12
PRGEND
 
 
TITLE IFX.13
SEARCH FORMSC,FORPRM
IFX 13
PRGEND
 
 
TITLE IFX.14
SEARCH FORMSC,FORPRM
IFX 14
PRGEND
 
 
TITLE IFX.15
SEARCH FORMSC,FORPRM
IFX 15
PRGEND
 
 
TITLE	ADJ1.	%4.(142)

	SEARCH FORPRM

;AC ASSIGNMENTS
ARG==L		;ARG POINTER

TEMOFF==T0	;HOLDS OFFSET COMPUTATION
;T1==1	;HOLDS LOOP DOUNTER (DIMENSIONALITY)
;T2==2		;HOLDS MULTIPLIER COMPUTED
TABREG==T3	;HOLDS DESTROYED ARG POINTER


	;THE FOLLOWING ALGORITHM IS IMPLEMENTED TO
	;COMPUTE ARRAY FACTORS, OFFSET AND SIZE FOR THE
	;SPECIAL CASE WHEN ALL LOWER BOUNDS ARE A 
	;CONSTANT 1 AND ALL DIMENSIONS ARE ADJUSTABLE.
	;MULT(I) ARE MULTIPLIERS
	;U(I) ARE UPPER BOUNDS (EQUIVALENT TO RANGE)

	;OFFSET=MULT(1)
	;ARRAYSIZ=MULT(1)
	;DO 10 I=2,NUMBER OF DIMENSIONS-1
	;ARRAYSIZ=ARRAYSIZ*U(I-1)
	;MULT(I)=MULT(I-1)*U(I-1)
	;OFFSET=OFFSET+MULT(I)
;10	CONTINUE
	;OFFSET=-OFFSET+BASE ADDRESS OF ARRAY

	;THE PARAMTERS PASSED ARE (INORDER):
	;POINTER TO NUMBER OF DIMENSIONS
	;POINTER TO TEMP FOR ARRAYSIZ
	;BASE ADDRESS OF ARRAY
	;POINTER TO TEMP FOR OFFSET
	;MULT(1)
	;U(1)
	;MULT(2)
	;U(2)
	;	.
	;	.
	;	.
	;MULT(N)
	;U(N)

	;**NOTE THAT THE DOUBLE PRECISION/SINGLE PRECISION
	;IS HANDLED BY PASSING A 2/1 AS MULT(1).

	HELLO	(ADJ1.)
	PUSH	P,T2		;SAVE REGISTERS USED
	PUSH	P,TABREG	;

	MOVE	T1,@0(ARG)	;FETCH DIMENSIONALITY
	MOVE	TABREG,ARG	;COPY ARG REGISTER
	MOVE	TEMOFF,@4(ARG)	;GET OFFSET WITH MULT(1)
	MOVE	T2,TEMOFF	;GET MULT(1) WITH MULT(1)
	MOVEM	T2,@1(ARG)	;INITIALIZE ARRAYSIZ
LOOP1:	SOJLE	T1,LUPDUN	;QUIT IF DONE
	MOVE	T2,@5(TABREG)	;FETCH U(I-1)
	IMULM	T2,@1(ARG)	;MULTIPLY INTO ARRAYSIZ
	IMUL	T2,@4(TABREG)	;MULT BY MULT(I-1)
	MOVEM	T2,@6(TABREG)	;FORMING MULT(I)
	ADDI	TEMOFF,0(T2)	;KEEP SUM OF OFFSET FACTORS
	ADDI	TABREG,2	;ADVANCE POINTER
	JRST	LOOP1		;GO AROUND AGAIN

LUPDUN:	MOVN	TEMOFF,TEMOFF	;NEGATE OFFSET
	ADDI	TEMOFF,@2(ARG)	;ADD ARRAY BASE ADDRESS
	MOVEM	TEMOFF,@3(ARG)	;STORE VALUE OF OFFSET
	MOVE	T2,@5(TABREG)	;FETCH U(I) FOR LAST ARRAYSIZE MULTIPLY
	IMULM	T2,@1(ARG)	;MULTIPLY TO MEM IT IN

	POP	P,TABREG	;RESTORE REGISTERS
	POP	P,T2
	GOODBY
	PRGEND
	TITLE	ADJG.	%4.(324)


;REVISION HISTORY
;----------------
;EDIT	SPR	COMMENT
;----	---	-------
;
	SEARCH	FORPRM
;AC ASSIGNMENTS
ARG==L		;ARGUMENT LIST

TEMOFF==T0	;USED TO COMPUTE OFFSET
;T1==1		;USED TO HOLD LOOP COUNT (DIMENSIONALITY)
;T2==2		;USED TO HOLD MULTIPLIERS
TABREG==T3	;USED TO HOLD DESTROYED ARG PTR


	;THE FOLLOWING ALGORITHM IS IMPLEMENTED TO COMPUTE
	;ARRAY FACTORS AND OFFSET AND SIZE FOR THE
	;GENERAL CASE.

	;A PARTIALLY COMPUTED OFFSET MAY BE INPUT
	;THE ALGORITHM MAY START IN AN ARBITRARY PLACE AND MULT(1)
	;MAY BE 1 (STARTING FROM SCRATCH) OR ANOTHER VALUE.
	;THE ABILITY TO START ANYWHERE IS NECESSARY SINCE
	;FACTOR AND OFFSET INFO MAY ALREADY HAVE BEEN
	;COMPUTED FOR CONSTANT ARRAY BOUNDS APPEARING IN THE
	;LIST FIRST.
	;MULT(I) ARE THE FACTORS
	;U(I) ARE THE UPPER BOUNDS
	;L(I) ARE THE LOWER BOUNDS

	;OFFSET=MULT(1)*L(1)
	;ARRAYSIZ=MULT(1)
	;DO 10 I=2,NUMBER OF DIMENSIONS-1
	;TEMP=U(I-1)-L(I-1)+1
	;MULT(I)=MULT(I-1)*TEMP
	;OFFSET=OFFSET+MULT(I)
	;ARRAYSIZ=ARRAYSIZ*TEMP
;10	CONTINUE
	;OFFSET=-OFFSET+BASE ADDRESS OF ARRAY
	;TEMP=U(I)-L(I)+1
	;ARRAYSIZ=ARRAYSIZ*TEMP

	;THE PARAMTERS ARE (IN ORDER OF APPEARANCE)
	;POINTER TO NUMBER OF DIMENSIONS
	;POINTER TO ARRAY SIZE
	;BASE ADDRESS OF ARRAY
	;POINTER TO TEMP CONTAINING OFFSET
	;MULT(1)
	;U(1)
	;L(1)
	;MULT(2)
	;U(2)
	;L(2)
	;	.
	;	.
	;	.
	;MULT(N)

	HELLO	(ADJG.)
	PUSH	P,T2		;SAVE REGISTERS USED
	PUSH	P,TABREG	;

	MOVE	T1,@0(ARG)	;FETCH DIMENSIONALITY
	MOVE	TABREG,ARG	;COPY ARG REGISTER
	SETZ	TEMOFF,		;[324] CLEAR OFFSET
	MOVE	T2,@4(ARG)	;MULT(1) - (PASSED IN)
	MOVEM	T2,@1(ARG)	;INITIALIZE ARRAYSIZ
LOOP1:	IMUL	T2,@6(TABREG)	;MULT(1)*L(1)
	ADDI	TEMOFF,0(T2)	;ADD TO INITIAL OFFSET
	SOJLE	T1,LUPDUN	;QUIT IF DONE
	MOVE	T2,@5(TABREG)	;U(I-1)
	SUB	T2,@6(TABREG)	;MINUS L(I-1)
	ADDI	T2,1		;PLUS 1
	IMULM	T2,@1(ARG)	;MULTIPLY INTO ARRAYSIZ
	IMUL	T2,@4(TABREG)	;TIMES MULT(I-1)
	MOVEM	T2,@7(TABREG)	;EQUALS MULT(I)
	ADDI	TABREG,3	;INCREMENT TO NEXT BUNCH
	JRST	LOOP1		;GO AROUND AGAIN

LUPDUN:	MOVN	TEMOFF,TEMOFF	;NEGATE OFFSET
	ADDI	TEMOFF,@2(ARG)	;ADD BASE ADDRESS OF ARRAY
	MOVEM	TEMOFF,@3(ARG)	;STOR OFFSET
	MOVE	T2,@5(TABREG)	;GET U(I) FOR LAST ARRAYSIZ MULT
	SUB	T2,@6(TABREG)	;-L(I)
	ADDI	T2,1		;ADD ONE OF COURSE
	IMULM	T2,@1(ARG)	;MULT AND STACH IN ARRAY SIZE

	POP	P,TABREG	;RESTORE REGISTERS USED
	POP	P,T2
	GOODBY
	PRGEND
TITLE	ADJ. 	%4.(120) ;FROM LIB40 VERSION V.032(323)	VARIABLE DIMENSION SUBSCRIPT CALCULATOR
SUBTTL	D. TODD /DRT 15-FEB-1973	TOM OSTEN/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;ADJ. IS A PROGRAM CALLED AT RUN-TIME BY A FORTRAN PROGRAM
;TO CALCULATE THE MULTIPLIERS AND OFFSET FOR SUBSCRIPT CALCULATIONS
;FOR DIMENSIONS DECLARED AS SUBROUTINE ARGUMENTS. THE COMPILER
;GENERATES THE FOLLOWING SEQUENCE:
;	JSA	16, ADJ.
;	EXP	N		;DIMENSIONALITY OF ARRAY
;	ARG	X, TEMP+N+1	;ARG IS A NO-OP, X IS THE TYPE 
				;OF THE ARGUMENT,TEMP IS A PNTR
				;TYPE,TEMP+N+1 POINTS TO END OF
				;MULTIPLIER TABLE
;	EXP	U1		;ADDRESS OF NUMBER WHICH IS THE 
;				;UPPER BOUND FOR FIRST SUBSCRIPT
;	EXP	L1		;ADDRESS OF NUMBER WHICH IS THE
;				;LOWER BOUND FOR FIRST SUBSCRIPT
;	.
;	.
;	.
;	EXP	LN		;LAST LOWER BOUND ADDRESS
;THE TEMP BLOCK IS CONSTRUCTED AS FOLLOWS:

;TEMP:	SIZE OF ARRAY (EQUAL TO MULTIPLIER N)
;	OFFSET
;	MULTIPLIER N-1
;	.
;	.
;	.
;	MULTIPLIER 1
;	MULTIPLIER 0

;THE I-TH MULTIPLIER, P(I), IS DESCRIBED BY:
;	P(0) = 1
;	P(I) = P(I-1) * (U(I) - L(I) + 1)

;THE OFFSET IS DESCRIBED BY
;	OFFSET = SUM FROM 1 TO N OF P(I-1)*L(I)

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(ADJ.)		;ENTRY TO ADJ. ROUTINE
	MOVEM	2,SAV2		;SAVE AC 2
	LDB	C,[POINT 3,1(Q),11]	;GET HI 3 BITS OF ARG TYPE
	SUBI	C,3		;0 RESULT MEANS D.P. OR COMPLEX
	MOVEM	C,ACFLD		;SAVE THE RESULT
	MOVNI	C, @(Q)		;GET MINUS COUNT OF DIMENSIONS
	MOVEI	B, @1(Q)	;GET TOP ADDRESS OF TEMP BLOCK
	ADDI	B, -1(C)	;SET B BACK TO BEGINNING OF TEMP BLOCK
	HRL	B, C		;AOBJN WORD IS (-CNT)ADDR
	MOVEI	A, 1		;INITIALIZE P(0) = 1
	SETZM	OFFSET		;INITIALIZE OFFSET=0

ADJ.1:	MOVEM	A, (B)		;STORE P(N)
	ADDI	Q, 2		;SET FOR NEXT PAIR OF DIMENSIONS
	MOVE	C, A		;COPY P(N)
	IMUL	C, @1(Q)	;P(N-1)*L(N)
	ADDM	C,OFFSET	;ADD INTO OFFSET
	MOVE	C, @(Q)		;GET U(N)
	SUB	C, @1(Q)	;U(N) - L(N)
	IMULI	A, 1(C)		;P(N-1)*(U(N) -L(N) +1)
	AOBJN	B, ADJ.1	;N=N+1, GO AROUND LOOP

	MOVE	C,OFFSET	;GET OFFSET BACK
	SKIPN	ACFLD		;WAS TYPE D.P. OR COMPLEX?
	ASH	C,1		;YES, MULTIPLY OFFSET BY 2 FOR
				;COMPLEX OR DOUBLE PRECISION ARG.
	MOVEM	C, (B)		;OFFSET TO NEXT TO LAST ENTRY
	MOVEM	A, 1(B)		;SIZE TO LAST ENTRY
	MOVE	2,SAV2		;RESTORE AC 2
	GOODBY	(2)	;RETURN

OFFSET:	BLOCK	1
ACFLD:	BLOCK	1	;HOLD 0 IF DOUBLE PRECISION OR COMPLEX
SAV2:	BLOCK	1	;TEMP STORAGE FOR AC 2

	PRGEND
	TITLE	PROAR.	%4.(250) ARRAY BOUNDS CHECKING ROUTINE
	SUBTTL	SARA MURPHY/HPW		30-JAN-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1977 BY DIGITAL EQUIPMENT CORPORATION

VERNO==3	;MAJOR VERSION NUMBER
VEDIT==21	;MAJOR EDIT NUMBER
VWHO==0		;EDITOR
VMINOR==0	;MINOR VERSION NUMBER

PROAV==BYTE(3)VWHO(9)VERNO(6)VMINOR(18)VEDIT

PURGE	VWHO,VERNO,VMINOR,VEDIT

	SEARCH	FORPRM		;DEFINE GLOBAL SYMBOLS

;ROUTINE TO PERFORM FORTRAN ARRAY BOUNDS CHECKING AT RUN TIME
;CALLED WITH AN ARGUMENT BLOCK OF THE FORM:
;	-------------------------------------------------
;	!			! PTR TO SEQ NUMB OF ST	!
;	-------------------------------------------------
;	!			! PTR TO DIMENSION INF	!
;	-------------------------------------------------
;	!			! PTR TO 1ST SUBSCRIPT	!
;	-------------------------------------------------
;	!			! PTR TO 2ND SUBSCRIPT	!
;
;			     ETC
; WHERE DIMENSION INFORMATION IS REPRESENTED BY A BLOCK OF THE FORM:
;	-------------------------------------------------
;	!  		ARRAY NAME (IN SIXBIT)		!
;	-------------------------------------------------
;	! DIM CT    !     !I!	! BASE ADDRESS		!
;	-------------------------------------------------
;	!A!F!			! PTR TO OFFSET		!
;	-------------------------------------------------
;	!			! PTR TO 1ST LOWER BND	!
;	-------------------------------------------------
;	!			! PTR TO 1ST UPPER BND	!
;	-------------------------------------------------
;	!			! PTR TO 1ST FACTOR	!
;	-------------------------------------------------
;	!			! PTR TO 2ND UPPER BND	!
;
;			     ETC
;   WHERE A IS A FLAG FOR "ADJUSTABLY DIMENSIONED ARRAY"
;	F IS A FLAG FOR "FORMAL ARRAY"
;
;COMPUTES THE ADDRESS OF THE SPECIFIED ARRAY ELEMENT AND
; RETURNS THAT ADDRESS IN AC 0. IF ANY OF THE BOUNDS ARE
; EXCEEDED, AN ERROR MESSAGE IS GIVEN BEFORE PROCEEDING
;THE ADDRESS OF THE ARRAY ELEMENT IS COMPUTED BY THE
; FORMULA:
;	BASE ADDR + OFFSET + (1ST SS)*(1ST FACTOR) +
;		(2ND SS)*(2ND FACTOR) + .....
;IF AN ARRAY IS NOT A FORMAL, THE BASE ADDR+OFFSET WILL BE ADDED
; IN TO THE RESULT OF THIS ROUTINE BY THE FORTRAN PROGRAM CALLING
; THIS ROUTINE - THEREFORE THESE 2 TERMS ARE NOT INCLUDED IN THE RESULT 
; UNLESS THE ARRAY IS FORMAL.
;IF AN ARRAY IS ADJUSTABLY DIMENSIONED, THE "OFFSET" CALCULATED UPON
; ENTRY TO THE SUBROUTINE IN WHICH THE ARRAY IS DECLARED ALREADY
; INCLUDES THE BASE ADDRESS - THEREFORE FOR ADJUSTABLY DIMENSIONED
; ARRAYS NEED NOT HAVE THE BASE ADDRESS ADDED IN SEPARATELY.
;

	VREG=0		;REG IN WHICH THE RESULT IS RETURNED

	DP=15		;PTR INTO THE BLOCK OF DIMENSION INFORMATION. POINTS
			; TO THE SUB-BLOCK OF INFORMATION FOR A GIVEN DIMENSION
	SSP=14		;AOBJN POINTER INTO THE LIST OF SUBSCRIPTS - LEFT
			; HALF IS CT OF SUBSCRIPTS, RH IS PTR TO THE ENTRY
			; FOR A GIVEN SUBSCRIPT
	SS=13		;THE SUBSCRIPT BEING PROCESSED
	SUM=12		;COMPUTED SUM OF SUBSCRIPTS WITH FACTORS USED TO
			; COMPUTE THE ADDRESS

;DEFINE FIELDS IN THE ARG-BLOCK FOR THIS ROUTINE

	ISNWD=0		;WD 0 CONTAINS THE SEQ NUMBER OF THE STMNT
			; CONTAINING THIS ARRAY REF
	DBLKP=1		;WD 1 CONTAINS PTR TO THE DIMENSION BLOCK
			; FOR THIS ARRAY
	ARNAMP=1	;SINCE 1ST WD OF DIMENSION BLOCK IS THE ARRAY
			; NAME, WD 1 OF ARG BLOCK PTS TO THE ARRAY NAME
	SS1WD=2		;WD 2 CONTAINS PTR TO THE 1ST SS

;DEFINE FIELDS IN THE DIMENSION BLOCK

	DCTSIZ=9	;NUMBER OF BITS IN THE DIMENSION CT FIELD IN
			; THE DIMENSION DESCRIPTOR BLOCK
	DCTPOS=8	;LAST BIT IN THE DIMENSION CT FIELD IS BIT 8
	DCTWD=1		;DIMENSION CT FIELD IS IN WD 1 OF THE BLOCK

	DFLGWD=2	;DIMENSION BLOCK FLAGS ARE IN WD 2 OF DIM BLO
	DFLSIZ=2	;DIMENSION BLOCK FLAGS ARE 2 BITS
	DFLPOS=1	; BITS 0-1

	DNAMWD=0	;ARRAY NAME IS IN WD 0 OF THE DIMENS BLOCK
	DBASWD=1	;BASE ADDR IS IN WD 1 OF THE BLOCK
	DOFFWD=2	;OFFSET IS IN WD 2 OF THE BLOCK
	D1WD=3		;SUB-BLOCK FOR THE 1ST DIMENSION STARTS
			; IN WD 3

;DEFINE FIELDS IN THE SUB-BLOCKS FOR EACH DIMENSION

	DLBWD=0		;PTR TO LOWER BOUND IS IN WD 0 OF A SUB-BLOCK
			; FOR A GIVEN DIMENSION
	DUBWD=1		;PTR TO UPPER BOUND IS IN WD 1 OF A SUB-BLOCK
	DFACWD=2	;PTR TO FACTOR IS IN WD 2 OF A SUB-BLOCK
	DSBSIZ=3	;NUMBER OF WDS IN THE SUB-BLOCK FOR EACH DIMEN

	ENTRY	PROAR.		;DEFINE ENTRY FOR LOADER
	SIXBIT	/PROAR./	;DEFINE ROUTINE NAME FOR TRACE%

PROAR.:	PUSH	P,DP		;SAVE AC'S
	PUSH	P,SSP
	PUSH	P,SS
	PUSH	P,SUM

	MOVE	DP,DBLKP(L)	;PTR TO START OF DIMENSION BLOCK

	HRRI	SSP,SS1WD(L)	;SET UP AOBJN PTR TO THE SS LIST
				;LOAD DIMENSION COUNT
	LDB	T1,[POINT DCTSIZ,DCTWD(DP),DCTPOS]
	MOVN	T1,T1		; NEGATED GOES IN
	HRL	SSP,T1		; LEFT HALF

	LDB	T1,[POINT DFLSIZ,DFLGWD(DP),DFLPOS]	;FLAGS FOR
				; ADJ-DIM AND FOR FORMAL
	XCT	[			;INIT ADDR COMPUTED TO:
			MOVEI	SUM,0		; 0 FOR A NON-FORMAL
			MOVEI	SUM,@DBASWD(DP)	; THE ARRAY BASE FOR A FORMAL NOT
						; ADJUSTABLY DIMENSIONED
			PUSHJ	P,ERR1		; (ADJ BUT NOT FORMAL SHOULD 
						; NEVER OCCUR)
			MOVE	SUM,@DOFFWD(DP)	; THE COMPUTED OFFSET FOR AN 
						; ADJUSTABLY DIMENSIONED ARRAY
			](T1)

	MOVEI	DP,D1WD(DP)	;PTR TO INFO ON 1ST DIMENSION

LP:	MOVE	SS,@0(SSP)	;1ST SUBSCRIPT
	CAML	SS,@DLBWD(DP)	;IF LESS THAN LOWER BOUND
	CAMLE	SS,@DUBWD(DP)	; OR GTR THAN UPPER BOUND
	PUSHJ	P,ERR		; GIVE A MESSAGE
	IMUL	SS,@DFACWD(DP)	;MULTIPLY BY FACTOR
	ADD	SUM,SS		;ADD INTO THE ADDRESS BEING COMPUTED
	ADDI	DP,DSBSIZ	;GO ON TO NEXT DIMENSION
	AOBJN	SSP,LP		;GO ON TO NEXT SS AND LOOP


	MOVE	VREG,SUM	;RESULT
	POP	P,SUM		;RESTORE ACS
	POP	P,SS
	POP	P,SSP
	POP	P,DP
	POPJ	P,		;RETURN





;ROUTINE CALLED WHEN A BOUNDS VIOLATION HAS BEEN DETECTED

ERR:	PUSH	P,T2		;USE T1,T2,T3 FOR PASSING ARGS TO FORER
	PUSH	P,T3		; MUST PRESERVE T2,T3 BECAUSE THE FORTRAN
	PUSH	P,T4		; PROGRAM CALLING "PROAR." ASSUMES REGS
				; 2-15 ARE PRESERVED

	MOVEI	T3,-SS1WD+1(SSP) ;SET T3 TO THE DIMENSION BEING PROCESSED
	SUB	T3,L

	MOVE	T1,@ARNAMP(L)	;ARRAY NAME IN SIXBIT
	MOVE	T2,@ISNWD(L)	;ISN OF STMNT CONTAINING THIS ARRAY REF
	MOVE	T4,SS		;VALUE OF ILLEGAL SUBSCRIPT

	ERROR	(SRE,0,0,.+1)	;CALL FORER TO GIVE THE ERROR MESSAGE

	POP	P,T4
	POP	P,T3
	POP	P,T2
	POPJ	P,


;ADJUSTABLY DIMENSIONED FORMAL ARRAY ERROR DETETCTED

ERR1:	ERROR(SYS,0,0)		;IF DIMENSION BLOCK SPECIFIED AN
				; ADJUSTABLY DIMENSIONED ARRAY THAT WAS
				; NOT FORMAL - HAVE AN INTERNAL BUG - ABORT

	PRGEND
TITLE	ILL 	%4.(120) ;FROM LIB40 VERSION V.032(323)      ZERO INPUT WORD ON ILLEG. CHARACTERS
SUBTTL	D. TODD /DRT 15-FEB-1973	/DMN/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;WHEN THE FLAG ILLEG. IS SET (BY CALLING ILL), 
;FLOATING POINT INPUT WORDS WILL BE CLEARED IF
;ANY ILLEGAL CHARACTERS ARE SCANNED FOR THAT WORD.
;THE ILLEG. FLAG IS CLEARED BY FORSE. AT THE END
;OF EACH FORMAT STATEMENT.

;THE CALLING SEQUENCE IS JSA Q,ILL

;THE ROUTINE 'LEGAL' ALLOWS ONE TO CLEAR THE
;ILLEG. FLAG SO THAT ILLEGAL CHARACTERS WILL
;RESULT IN THE NORMAL ILLEGAL CHARACTER RETURN.

;THE CALLING SEQUENCE IS JSA Q,LEGAL

ENTRY ILL,LEGAL
SEARCH FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(ILL)
	HRRZ	T1,.JBOPS	;GET THE LOW SEG POINTER
	SETOM ILLEG.(T1)	;SET ILL CH FLAG
	GOODBY

	HELLO	(LEGAL)
	HRRZ	T1,.JBOPS
	SETZM ILLEG.(T1)	;CLEAR ILL CH FLAG
	GOODBY

	PRGEND
TITLE	ABS 	%4.(235) SINGLE PRECISION ABSOLUTE VALUE FUNCTION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	ABS
EXTERN	ABS.
ABS=ABS.
PRGEND
TITLE	IABS 	%4.(235) SINGLE PRECISION ABSOLUTE VALUE FUNCTION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	IABS
EXTERN	IABS.
IABS=IABS.
PRGEND
TITLE	ABS. 	%4.(235) SINGLE PRECISION ABSOLUTE VALUE FUNCTION
SUBTTL	D. TODD /DRT 15-FEB-1973	ED YOURDON/KK/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;FROM	LIB40	V.32(323)

;SINGLE PRECISION ABSOLUTE VALUE FUNCTION
;ABS AND IABS RETURN THE ABSOLUTE VALUE OF A SINGLE PRECISION
;ARGUMENT.

;THE CALLING SEQUENCE FOR THE ROUTINES IS
;	JSA	Q, ABS
;	EXP	ARG
;THE ANSWER IS RETURNED IN ACCUMULATOR A

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17


	HELLO	(ABS,.)		;[235] ENTRY TO ABS ROUTINE
	MOVM	A,@(Q)		;GET /ARG/.
	GOODBY	(1)	;RETURN

	HELLO	(IABS,.)	;[235] ENTRY TO IABS ROUTINE.
	MOVM	A,@(Q)		;GET /ARG/.
	JFCL	1,[HRLOI A,377777 ;/-INFIN/ IS SET TO +INFIN,
		GOODBY (1)]	;AND AN ERROR MESSAGE IS RETURNED.
	GOODBY	(1)	;RETURN

	PRGEND
TITLE	RESET	%4.(410) ;FROM LIB40 VERSION V.032(323)	RESETS ALL I/O DEVICES
SUBTTL	D. TODD /DRT/MD	01-NOV-74	DICK GRUEN/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;410	14339	RESET ROUTINE FAILS

	SEARCH	FORPRM

				;**;[410],RESET,MD,11/01/74
	HELLO	(RESET)
	PUSH	P,P4		;[410] SAVE REGISTERS
	PUSH	P,P3		;[410]
	PUSH	P,L		;[410] 
	PUSH	P,T1		;[410] 
	PUSH	P,T2		;[410] 
	HRRZ	P4,.JBOPS	;[410] GET DATA BASE ADDRESS
	MOVSI	T1,-17		;[410] CHECK 15. CHANNELS
	HRRI	T1,CHN.TB+1(P4)	;[410] ENTRIES IN CHN.TB TABLE
RES.1:	SKIPE	P3,(T1)		;[410] CHANNEL NOT ASSIGNED
	CAMN	P3,[-1]		;[410] OR BY USER
	JRST	RES.3		;[410] DONT RESET
	LDB	T2,[POINT 4,DD.UNT(P3),12] ;[410] GET CHAN NUMBER
	RESDV.	T2,		;[410] CALL MONITOR TO RESET CHAN
	  JRST	RES.ER		;[410] ERROR
RES.2:	HRRZS	P3		;[410] GET ADDRESS OF DDB
	MOVEI	L,RESARG	;[410] AND ARGUMENT BLOCK
	PUSHJ	P,DECOR.##	;[410] GO DEALLOCATE CORE
				;[410] DDB AND BUFFERS
	SETZM	(T1)		;[410] INDICATE CHAN AVAILABLE
RES.3:	AOBJN	T1,RES.1	;[410] CONTINUE FOR ALL CHANNELS
	SETZM	RER.SV(P4)	;[410] CLEAR REREAD INFO
RES.4:	POP	P,T2		;[410] RESTORE REGISTERS 
	POP	P,T1		;[410] 
	POP	P,L		;[410] 
	POP	P,P3		;[410] 
	POP	P,P4		;[410] 
	GOODBY	()		;[410] 
RES.ER:	SKIPGE	T2		;[410] RESDV. UUO IMPLEMENTED
	JRST	RES.2		;[410] YES - IGNORE ERROR RETURN
	OUTSTR	[ASCIZ /
%FRSRES	NO RESDV. UUO - RESET LIBRARY ROUTINE ABORTED
/]				;[410] GIVE MESSAGE TO USER
	JRST	RES.4		;[410] AND LEAVE
	-1,,0			;[410] COUNTER
RESARG:	0,,P3			;[410] 
	PRGEND
TITLE	DIM 	%4.(235) SINGLE PRECISION POSITIVE DIFFERENCE FUNCTION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	DIM
EXTERN	DIM.
DIM=DIM.
PRGEND
TITLE	DIM. 	%4.(235) SINGLE PRECISION DIFFERENCE FUNCTION
SUBTTL	D. TODD /DRT 15-FEB-1973	ED YOURDON/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;FROM	LIB40	V.32(323)

;SINGLE PRECISION DIM FUNCTION
;DIM(A,B) IS CALLED IN THE FOLLOWING MANNER:
;	JSA	Q, DIM
;	EXP	A
;	EXP	B
;DIM RETURNS THE POSITIVE DIFFERENCE OF A AND B:
;IF (A-B)>0, THEN DIM(A,B) = A-B
;IF (A-B) .LE. 0, THEN DIM(A,B) = 0

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17


	HELLO	(DIM,.)		;[235] ENTRY TO DIM ROUTINE
	MOVE	A, @(Q)		;PICK UP FIRST ARGUMENT
	CAMG	A,@1(Q)		;IF A > B, GO TO SUBTRACT.
	TDZA	A,A		;O'E, ZERO A AND GO TO EXIT.
	FSBR	A,@1(Q)		;CALC A - B.
	GOODBY	(2)	;RETURN

	PRGEND
TITLE	IDIM 	%4.(235) INTEGER POSITIVE DIFFERENCE FUNCTION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	IDIM
EXTERN	IDIM.
IDIM=IDIM.
PRGEND
TITLE	IDIM. 	%4.(235) INTEGER POSITIVE DIFFERENCE FUNCTION
SUBTTL	D. TODD /DRT 15-FEB-1973	ED YOURDON/KK/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;FROM	LIB40	V.32(323)

;SINGLE PRECISION INTEGER DIM FUNCTION
;IDIM(A,B) IS CALLED IN THE FOLLOWING MANNER:
;	JSA	Q, IDIM
;	EXP	A
;	EXP	B
;IDIM RETURNS THE POSITIVE DIFFERENCE OF A AND B:
;IF (A-B) .LE. 0, THEN DIM(A,B)=0
;IF(A-B) .G. 0 , THEN DIM(A,B)=(A-B)

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(IDIM,.)	;[235] ENTRY TO IDIM ROUTINE
	MOVE	A, @(Q)		;PICK UP FIRST ARGUMENT
	CAMG	A,@1(Q)		;IF A <= B,
	MOVE	A,@1(Q)		;ANS WILL = 0.
	SUB	A,@1(Q)		;IF A > B,
	JFCL	1,[HRLOI A,377777 ;ANS = A - B,
		GOODBY (2)]	;+ OVERFLOW MAY OCCUR.
	GOODBY	(2)	;RETURN

	PRGEND
TITLE	SIGN 	%4.(235) SINGLE PREICISION XFER OF SIGN FUNCTION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	SIGN
EXTERN	SIGN.
SIGN=SIGN.
PRGEND
TITLE	ISIGN 	%4.(235) SINGLE PREICISION XFER OF SIGN FUNCTION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	ISIGN
EXTERN	ISIGN.
ISIGN=ISIGN.
PRGEND
TITLE	SIGN. 	%4.(235) SINGLE PRECISION AND INTEGER XFER OF SIGN FUNCTION
SUBTTL	D. TODD /DRT 15-FEB-1973	ED YOURDON/KK/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;FROM	LIB40	V.32(323)

;SIGN(A,B) AND ISIGN(A,B) ARE CALLED IN THE FOLLOWING MANNER:
;	JSA	Q, SIGN
;	EXP	A
;	EXP	B
;IF B .GE. 0, THEN ABSF(A) IS RETURNED IN ACCUMULATOR A
;IF B .L. 0, THEN -ABSF(A) IS RETURNED IN ACCUMULATOR A

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(SIGN,.)	;[235] ENTRY TO SIGN
	MOVM	A, @(Q)		;GET MAGNITUDE OF FIRST ARGUMENT
	SKIPGE	@1(Q)		;IS SECOND ARGUMENT POSITIVE?
	MOVNS	A		;NO, NEGATE RESULT
	GOODBY	(2)	;RETURN

	HELLO	(ISIGN,.)	;[235] ENTRY TO ISIGN
	MOVE	A,@(Q)		;FIRST ARG TO A.
	XOR	A,@1(Q)		;IF FIRST AND SECOND HAVE
	JUMPL	A,.+3		;DIFFERENT SIGNS, GO TO .+3.
	MOVE	A,@(Q)		;O'E, THE ANSWER = FIRST ARG.
	GOODBY	(2)	;RETURN
	MOVN	A,@(Q)		;ANSWER=-FIRST ARG.
	JFCL	1,.+2		;IF OVERFLOW, GO TO .+2.
	GOODBY	(2)	;RETURN
	HRLOI	A,377777	;ANSWER IS SET TO +INFINITY.
	GOODBY	(2)	;RETURN

	PRGEND
TITLE	AINT	%4.(235) FLOATING POINT TRUNCATION FUNCTION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	AINT
EXTERN	AINT.
AINT=AINT.
PRGEND
TITLE	AINT.	%4.(235) FLOATING POINT TRUNCATION FUNCTION
SUBTTL	D. TODD /DRT 15-FEB-1973	ED YOURDON /KK/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;FROM 	LIB40	V.32(323)

;FLOATING POINT TRUNCATION FUNCTION.
;TRUNCATES FRACTIONAL PART OF FLOATING POINT NUMBER
;AND RETURNS ANSWER AS A FLOATING POINT NUMBER.
;THE ROUTINE IS CALLED IN THE FOLLOWING MANNER:
;	JSA	Q,AINT
;	EXP	ARG

;THE ANSWER IS RETURNED IN AC 0.

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(AINT,.)	;[235] ENTRY TO AINT ROUTINE.
	MOVE	B,@(Q)		;ARG. TO AC 1.
	MOVM	A,B		;/ARG./ TO AC 0.
	CAML	A,MOD1		;IS /ARG/<2**26?
	JRST	AINT1		;NO, NO FRACTION BITS, EXIT.
	FAD	A,MOD1		;YES, REMOVE
	FSB	A,MOD1		;THE FRACTION BITS.
AINT1:	SKIPGE	B		;SET THE
	MOVNS	A		;CORRECT SIGN AND
	GOODBY	(1)	;RETURN

MOD1:	233400000000		;2**26

	PRGEND
TITLE	AMOD	%4.(235) SINGLE PRECISION MOD FUNCTION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	AMOD
EXTERN	AMOD.
AMOD=AMOD.
PRGEND
TITLE	AMOD.	%4.(235) SINGLE PRECISION MOD FUNCTION
SUBTTL	D. TODD /DRT 15-FEB-1973	ED YOURDON/KK/DMN/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;FROM	LIB40	V.32(323)

;FLOATING POINT SINGLE PRECISION MOD FUNCTION
;MODF(A,B) = A-[A/B]*B, WHERE [A/B] IS THE GREATEST INTEGER
;IN THE MAGNITUDE OF A/B.  THE TERM A/B MUST BE LESS THAN 
;2**26 IN MAGNITUDE.

;THE ROUTINE IS CALLED IN THE FOLLOWING MANNER:
;	JSA	Q,AMOD
;	EXP	A
;	EXP	B

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(AMOD,.)	;[235] ENTRY TO AMOD ROUTINE.
	MOVEM	C,SAVEC		;SAVE AC 2.
	MOVE	A,@(Q)		;PICK UP FIRST ARG.
	MOVE	B,@1(Q)		;PICK UP SECOND ARG.
	MOVM	C,B		;GET ABSF(B) IN C.
	FDVM	A,B		;CALCULATE A/B.
	JFCL	DETRMN		;IF OVER/UNDER FLOW, GO TO DETRMN VIA OVTRAP.
	MOVMS	B		;CALC. ABSF(A/B).
	CAML	B,MOD1		;IF A/B GE 2**26, 
	JRST	TOOLRG		;GO TO ERROR RETURN.
	FAD	B,MOD1		;OTHERWISE, TRUNCATE TO
	FSB	B,MOD1		;INTEGER.
	FMP	C,B		;C=B**ABSF([A/B])
	SKIPGE	A		;RESTORE
	MOVNS	C		;THE SIGN.
	FSB	A,C		;CALC. A-[A/B]*B.
OUT:	MOVE	C,SAVEC		;RESTORE AC 2.
	GOODBY	(2)	;RETURN
DETRMN:	MOVE	B,.JBTPC	;PICK UP FLAGS.
	TLNE	B,000100	;IF OVERFLOW, GO TO TOOLRG.
	JRST	OUT		;UNDERFLOW, A IS RESULT.
TOOLRG:	ERROR	(APR,5,1,.+1)	;TYPE AN OVERFLOW MESSAGE
	SETZ	A,		;ZERO A.
	JRST	OUT		;GO TO EXIT.
SAVEC:	0
MOD1:	233400000000		;2**26.

	PRGEND
TITLE	MOD	%4.(235) INTEGER MOD FUNCTION
SUBTTL	H. P. WEISS/HPW		11-DEC-73



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH	FORPRM
ENTRY	MOD
EXTERN	MOD.
MOD=MOD.
PRGEND
TITLE	MOD.	%4.(235) INTEGER MOD FUNCTION
SUBTTL	D. TODD /DRT 15-FEB-1973	ED YOURDON/KK



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;FROM	LIB40	V.32(323)

;INTEGER MOD FUNCTION
;MOD(A,B) = A-[A/B]*B, WHERE [A/B] IS THE GREATEST (IN
;MAGNITUDE) INTEGER IN A/B.  THAT IS, THE MOD FUNCTION 
;RETURNS THE REMAINDER OF THE QUOTIENT OF A AND B.  HENCE,
;9 MOD 2 IS 1, AND SO FORTH.

;THE CALLING SEQUENCE FOR THE ROUTINE IS:
;	JSA	Q,MOD
;	ARG	0,A
;	ARG	0,B
;WHERE ARG MAY BE ANY OPCODE, THE 0 IS THE AC FIELD AND USUALLY
;DESIGNATES THE TYPE OF ARGUMENT.  A AND B ARE THE ADDRESSES
;OF THE TWO ARGUMENTS TO THE PROGRAM.

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(MOD,.)		;[235] ENTRY TO MOD ROUTINE
	MOVE	A,@(Q)		;FIRST ARG TO AC 0.
	IDIV	A,@1(Q)		;DIVIDE, REMAINDER IN AC 1.
	MOVE	A,A+1		;PUT THE ANSWER IN AC 0.
	GOODBY	(2)	;RETURN

	PRGEND
TITLE	DATE	%4.(120) ;FROM LIB40 VERSION V.32(433)	TODAY'S DATE	FORTRAN IV
SUBTTL	D. TODD /DRT 15-FEB-1973	/KK/DMN



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION


;THIS SUBROUTINE PUTS TODAY'S DATE INTO A
;DIMENSIONED TWO-WORD ARRAY.

;THE DATE WILL BE IN THE FORM:
;	17-Aug-66

;THE ROUTINE IS CALLED IN THE FOLLOWING MANNER:
;	JSA	16,DATE
;	ARG	A

;"DATE" OBTAINS THE DATE FROM THE MONITOR IN THE FORM:
;	( (YEAR-1964)*12 + (MONTH-1) )*31 + (DAY-1)

	SEARCH	FORPRM

	HELLO	(DATE)			;ENTRY TO DATE ROUTINE.
	MOVEI	1,@(16)		;GET ADDRESS OF 2 WORD ARRAY
	MOVEM	2,0(1)		;SAVE THE CONTENTS OF AC 2.
	MOVEM	3,1(1)		;SAVE THE CONTENTS OF AC 3.
	CALLI	1,14		;GET THE DATE FROM THE MONITOR.
	IDIVI	1,^D31		;DIV. BY 31 TO OBTAIN THE DAY-1.
	ADDI	2,1		;TO OBTAIN THE DAY.
	IDIVI	2,^D10		;CONVERT INTO TWO DEC. DIGITS.
	SKIPN	2		;IS THE DAY < 10?
	MOVNI	2,20		;YES, OUTPUT BLANK.
	MOVEI	0,"0"(2)	;GET FIRST DIGIT
	LSH	0,7		;MAKE SPACE
	ADDI	0,"0"(3)	;ADD IN 2ND DIGIT
	IDIVI	1,^D12		;TO OBTAIN THE MONTH
	EXCH	1,2		;SAVE YEAR IN 2
	MOVE	1,TABLE(1)	;GET MONTH IN 1
	LSHC	0,3*7		;LEFT JUSTIFY 0 & 1
	LSH	0,1		;0 = ASCII /DD-MO/
				;1 = ASCII /N-/
	MOVEI	2,^D64(2)	;GET THE YEAR
	IDIVI	2,^D10		;CONVERT INTO TWO DEC. DIGITS
	ADDI	2,"0"		;MAKE ASCII
	ADDI	3,"0"
	LSH	2,2*7+1		;SHIFT TO CHAR 3
	LSH	3,7+1		;SHIFT TO CHAR 4
	ADD	3,2		;ADD IN TO 3
	ADD	3,1		;SO LOW WORD IS IN 3
	MOVE	2,0		;PUT HIGH ORDER RESULT IN 2
	MOVEI	1,@(16)		;USER ADDRESS
	EXCH	2,0(1)		;RESTORE 2
	EXCH	3,1(1)		;AND 3 WHILE STORING RESULT
	GOODBY	(1)	;RETURN

;SUB1 CONVERTS THE DAY AND THE YEAR INTO ASCII CHARS, AND
;DEPOSITS THEM IN THE TWO WORD ARRAY.

SUB1:	ADDI	2,60		;CONVERT FIRST DIGIT TO ASCII
	IDPB	2,0		;DEPOSIT FIRST DIGIT
	ADDI	3,60		;CONVERT SECOND DIGIT TO ASCII
TABLE:	ASCII	/-Jan-/
	ASCII	/-Feb-/
	ASCII	/-Mar-/
	ASCII	/-Apr-/
	ASCII	/-May-/
	ASCII	/-Jun-/
	ASCII	/-Jul-/
	ASCII	/-Aug-/
	ASCII	/-Sep-/
	ASCII	/-Oct-/
	ASCII	/-Nov-/
	ASCII	/-Dec-/

	PRGEND
	TITLE	TIM2GO	%4.(264) RETURN TIME LIMIT IN SECONDS
	SUBTTL	H. P. WEISS/HPW		11-FEB-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1977 BY DIGITAL EQUIPMENT CORPORATION

	SEARCH	FORPRM

	HELLO	(TIM2GO)	;[264] DEFINE ENTRY POINT
	PUSH	P,T1		;[264] GRAB A REGISTER
	MOVE	T1,[44,,11]	;[264] DETERMINE JIFFIES PER SECOND
	GETTAB	T1,		;[264] VIA GETTAB
	JRST	NEVER		;[264] UNIMPLEMENTED
	FSC	T1,233		;[264] CONVERT TO FLOATING POINT
	MOVE	T0,[-1,,40]	;[264] DETERMINE TIME LIMIT
	GETTAB	T0,		;[264] VIA GETTAB
	JRST	NEVER		;[264] UNIMPLEMENTED
	TLZ	T0,777700	;[264] CLEAR EXTRA BITS
	JUMPE	T0,NEVER	;[264] RETURN INFINITY IF 0
	FSC	T0,233		;[264] CONVERT TO FLOATING POINT
	FDVR	T0,T1		;[264] COMPUTE SECONDS TILL EXPIRATION
DONE:	POP	P,T1		;[264] RESTORE REGISTER USED
	GOODBY	(0)		;[264] RETURN

NEVER:	HRLOI	T0,377777	;[264] SET LIMIT TO INFINITY
	JRST	DONE

	PRGEND			;[264] END OF TIM2GO
	TITLE	TIME	%4.(203) TIME OF DAY FOR F40 AND FORTRAN-10
	SUBTTL	D. TODD /DRT/KK/HPW		22-AUG-73




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;FROM	%2.(120)
;FROM LIB40 VERSION V.017.5
;THIS SUBROUTINE PUTS THE TIME OF DAY INTO TWO WORDS.
;
;THE WORDS CONTAIN THE HOUR, THE MINUTE, THE SECOND, AND THE
;TENTH OF A SECOND.

;THE FIRST WORD IS OF THE FORM:
;	02:15 (FOR A.M. TIME)
;	14:15 (FOR P.M. TIME)

;THE SECOND WORD IS OF THE FORM:
;	37.4
;
;THE ROUTINE IS CALLED IN THE FOLLOWING MANNER:
;	JSA	16,TIME
;	ARG	A
;	ARG	B
;SINCE THE OLD VERSION OF TIME HAD ONLY ONE ARGUMENT,
;TIME CHECKS TO BE SURE A SECOND ARGUMENT IS EXPECTED
;BEFORE RETURNING IT.  THE OPCODE OF THE SECOND ARGUMENT
;MUST BE 320.

;TIME OBTAINS THE TIME FROM THE MONITOR IN THE FORM:
;	TIME=THE NUMBER OF MILLISECONDS SINCE MIDNIGHT.

	SEARCH	FORPRM

	HELLO	(TIME)		;ENTRY TO ROUTINE TIME
	MOVEM	2,SAVE2		;SAVE AC 2
	MOVEM	3,SAVE3		;SAVE AC 3
	CALLI	1,23		;GET TIME IN MILLISECS FROM THE MONITOR.
	IDIVI	1,^D60000	;TOTAL MINS. IN 1, LEFTOVER MSECS. IN 2.
	MOVEM	2,TEMP1		;SAVE THE LEFTOVER MSECONDS.
	IDIVI	1,^D60		;HOURS IN 1, MINUTES IN 2.
	MOVEM	2,TEMP2		;SAVE THE MINUTES.
	HRLZI	0,440736	;SET UP POINTER
	JSP	3,SUB1		;GO TO SUBR. TO SET UP HR. IN ASCII.
	MOVEI	1,":"		;SET UP ":".
	IDPB	1,0		;DEPOSIT ":" IN THE WORD.
	MOVE	1,TEMP2		;PICK UP THE MINUTES.
	JSP	3,SUB1		;GO TO SUBR. TO SET UP MIN. IN ASCII.
	HLRZ	3,0(16)		;%203% F40 OR FORTRAN-10 CALLING?
	LSH	3,-^D9		;%203% F40 OR FORTRAN-10 CALLING?
	JUMPN	3,TIME01	;%203% F40 CALLING
	HLRZ	3,-1(16)	;%203% FORTRAN-10 - GET ARGUMENT COUNT
	CAIE	3,-2		;%203% TWO ARGUMENTS?
	JRST	OUT1		;%203% NO - RETURN NOW
	JRST	TIME02		;%203% CONTINUE DEPOSITING BYTES
TIME01:	MOVE	3,1(16)		;%203% CHECK TO SEE
	TLC	3,320000	;IF A SECOND
	TLNE	3,777000	;ARG. IS EXPECTED.
	JRST	OUT1		;IF NOT, GO TO OUT1.
TIME02:	MOVEI	1," "		;PUT IN A BLANK AS THE FIRST
	IDPB	1,0		;CHARACTER IN THE 2ND WORD.
	MOVE	1,TEMP1		;PICK UP THE MSECONDS.
	IDIVI	1,^D1000	;SECONDS IN 1, LEFTOVER MSECS. IN 2.
	MOVEM	2,TEMP1		;SAVE THE MSECS.
	JSP	3,SUB1		;GO TO SUBR. TO SET UP THE SECS. IN ASCII.
	MOVEI	1,"."		;SET UP "."
	IDPB	1,0		;IN THE WORD.
	MOVE	2,TEMP1		;PICK UP THE MSECS.
	IDIVI	2,^D100		;GET THE TENTH OF A SECOND.
	MOVEI	2,"0"(2)	;%203% MAKE IT ASCII
	IDPB	2,0		;PUT IT IN THE SECOND WORD.
	MOVE	2,SAVE2		;RESTORE AC 2.
	MOVE	3,SAVE3		;RESTORE AC 3.
	GOODBY	(2)		;RETURN
OUT1:	MOVE	2,SAVE2		;RESTORE AC 2.
	MOVE	3,SAVE3		;RESTORE AC 3.
	GOODBY	(1)		;RETURN
SUB1:	IDIVI	1,^D10		;SUBROUTINE ENTRY POINT.
	MOVEI	1,"0"(1)	;%203% MAKE IT ASCII
	IDPB	1,0		;DEPOSIT IT IN THE WORD.
	MOVEI	2,"0"(2)	;%203% MAKE IT ASCII
	IDPB	2,0		;DEPOSIT IT IN THE WORD.
	JRST	(3)		;RETURN TO MAIN SEQUENCE.
SAVE2:	0
SAVE3:	0
TEMP1:	0
TEMP2:	0
	PRGEND
TITLE	SLITE 	%4.(120) ;FROM LIB40 VERSION V.032(323)	SENSE LITE SETTING AND TESTING FUNCTION
SUBTTL	D. TODD /DRT 15-FEB-1973	/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;SENSE LIGHT SETTING AND TESTING PROGRAM
;THIS PROGRAM CAN BE ENTERED AT TWO PLACES. THE SENSE LIGHT
;TESTING PROGRAM IS CALLED IN THE FOLLOWING MANNER:
;	JSA	Q, SLITET
;	EXP	I
;	EXP	J
;I IS THE ADDRESS OF AN INTEGER ARGUMENT, AND J IS THE ADDRESS
;OF THE ANSWER. IF SENSE LIGHT I IS ON, THE ANSWER IS ONE, AND
;IF IT IS OFF, THE ANSWER IS 2.

;THE SENSE LIGHT SETTING PROGRAM IS CALLED IN THE FOLLOWING
;MANNER:
;	JSA	Q, SLITE
;	EXP	I
;I IS THE ADDRESS OF AN INTEGER ARGUMENT WHOSE VALUE IS
;BETWEEN 0 AND 36. IF I=0, ALL SENSE LIGHTS ARE TURNED OFF.
;OTHERWISE, SENSE LIGHT I IS TURNED ON.

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17


	HELLO	(SLITE)			;ENTRY TO SLITE PROGRAM
	MOVN	B, @(Q)		;GET ARGUMENT
	JUMPE	B, SLITE2	;IS IT ZERO?
	MOVSI	A, 400000	;NO, PUT A ONE IN BIT 0
	ROT	A, 1(B)		;ROTATE IT INTO POSITION
	MOVE	B, LITES	;GET THE SENSE LIGHTS
	TDO	B, A		;TURN ON PROPER LIGHT
SLITE2:	MOVEM	B, LITES	;SAVE NEW SENSE LIGHTS
	GOODBY	(1)	;RETURN

	HELLO	(SLITET)			;ENTRY TO SENSE TESTING PROGRAM
	MOVN	B, @(Q)		;PICK UP ARGUMENT
	MOVSI	A, 400000	;PUT A ONE IN BIT 0
	ROT	A, 1(B)		;ROTATE IT INTO POSITION
	MOVEI	B, 1		;SET ANSWER TO ONE FOR NOW
	MOVEM	B, @1(Q)	;...
	MOVE	B, LITES	;PICK UP SENSE LIGHTS
	TDZN	B,A		;IS THE PROPER LIGHT ON?
	AOS	@1(Q)		;NO, CHANGE ANSWER TO 2
	MOVEM	B,LITES		;RESTORE WITH TESTED LIGHT OFF
	GOODBY	(2)	;RETURN

LITES:	0

	PRGEND
TITLE	SSWTCH 	%4.(120) ;FROM LIB40 VERSION V.032(323)	DATA SWITCH TESTING FUNCTION
SUBTTL	D. TODD /DRT 15-FEB-1973	/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

; DATA SWITCH TESTING PROGRAM
;THIS PROGRAM IS CALLED IN THE FOLLOWING MANNER:
;	JSA	Q, SSWTCH
;	EXP	I
;	EXP	J
;I IS THE ADDRESS OF AN INTEGER ARGUMENT AND J IS THE ADDRESS
; OF THE ANSWER . IF DATA SWITCH I IS UP,THE ANSWER IS 2 , AND
; IF IT IS DOWN, THE ANSWER IS 1.

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(SSWTCH)			;ENTRY TO SSWTCH PROGRAM
	MOVN	B, @(Q)		;PICK UP ARGUMENT
	MOVSI	A, 400000	;PUT A ONE IN BIT 0
	ROT	A,(B)		; ROTATE BIT INTO POSITION
	MOVEI	B,2		; SET ANSWER TO 2 FOR NOW
	MOVEM	B, @1(Q)	;...
	SWITCH	B,		;GET DATA SWITCHES FROM MONITOR
	TDNN	B, A		;IS PROPER SWITCH ON?
	SOS	@1(Q)		; NO, CHANGE ANSWER TO ONE
	GOODBY	(2)	;RETURN

	PRGEND
TITLE	RAN	%5A.(637) ;FROM LIB40 VERSION V.032(323)	GENERATE RANDOM NUMBER FUNCTION
SUBTTL  18-JAN-1977     BRUNO G. DUERR/KK/TWE/SWG



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;PSEUDO RANDOM NUMBER GENERATOR AND INITIALIZING ROUTINE
;METHOD SUGGESTED BY D. H. LEHMER


;CALLING SEQUENCE FOR FUNCTION RAN:

;JSA Q,RAN
;EXP   ARG     (DUMMY ARGUMENT)
;ANSWER IS RETURNED IN ACCUMULATOR A AS A SINGLE
;PRECISION FLOATING POINT NUMBER IN THE RANGE
;0<X<1


;CALLING SEQUENCE FOR INITIALIZING SUBROUTINE SETRAN:

;JSA Q,SETRAN
;EXP   ARG (ARG IS THE ADDRESS OF A POSITIVE INTEGER <2**31)
;NOTE: IF ARG CONTAINS 0 A STANDARD STARTING VALUE IS TAKEN INSTEAD


;CALLING SEQUENCE FOR SAVRAN
SUBTTL	D. TODD /DRT 15-FEB-1973	



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
;JSA Q,SAVRAN
;EXP ARG   (WHERE ARG IS THE ADDRESS FOR THE LAST RANDOM
;           NUMBER TO BE STORED IN INTEGER MODE)


	SEARCH FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(RAN)
	MOVE A,K	;GET K [14**29(MOD2**31 -1)]
	MUL A,XN	;MULTIPLY WITH LAST RANDOM NUMBER
	ASHC A,4	;SEPARATE RESULT IN TWO 31 BIT WORDS
	LSH B,-4
	ADD A,B		;ADD THEM TOGETHER
	TLZE A,760000	;SKIP IF RESULT < 31 BITS
	ADDI A,1
	MOVEM A,XN	;STORE NEW RN IN INTEGER MODE
	HLRZ B,A	;CONVERT TO FP IN TWO STEPS IN
	FSC B,216	;ORDER TO LOOSE NO LOW ORDER
;**;	[637] CHANGE AT K-4	SWG	18-JAN-77
	HRLI A,0	;[637] BITS
	FSC A,174
	FAD A,B
	GOODBY (1)	;RETURN TO CALLING PROGRAM
K:	^D630360016	;14**29(MOD 2**31 -1)
XN:	^D524287	;STARTING VALUE



	HELLO	(SETRAN)
	MOVE A,@0(Q)	;GET ARGUMENT FROM CALLING PROGRAM
	TLZ A,760000	;MASK 5 BITS FOR SAFETY
	CAIN A,0	;SKIP IF ARGUMENT NONZERO
	MOVE A,X0	;GET STANDARD STARTING VALUE
	MOVEM A,XN
	GOODBY	(1)	;RETURN
X0:	^D524287	;STANDARD STARTING VALUE FOR RAN


	HELLO	(SAVRAN)
	MOVE A,XN	;LAST RANDOM NUMBER TO AC0
	MOVEM A,@0(Q)	;STORE IN INTEGER MODE
	GOODBY	(1)	;RETURN

	PRGEND
TITLE	ERRSET	%4.(120) ;FROM LIB40 VERSION V.032(323)	SET MAXIMUM ERROR COUNT
SUBTTL	D. TODD /DRT 15-FEB-1973	T EGGERS/DMN/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

	SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	HELLO	(ERRSET)
	HRRZ	T1,.JBOPS	;GET THE LOW SEG POINTER
	MOVE	A,@(Q)		;GET MAXIMUM ERROR NUMBER
	MOVEM	A,ERRMX.(T1)	; AND STORE AWAY
	GOODBY	(1)	;RETURN

	PRGEND
TITLE	OVERFL	%4.(120) ;FROM LIB40 VERSION V.032(323)	ARITHMETIC OVEFLOW TESTING PROGRAM
SUBTTL	D. TODD /DRT 15-FEB-1973	T. EGGERS/DMN/TWE



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION

;THIS ROUTINE IS CALLED IN THE FOLLOWING MANNER:
;	JSA	Q,OVERFL
;	EXP	J
;IF OVERFLOWS HAVE OCCURRED, THE ANSWER IS SET TO 1, AND THE
;COUNTER IS CLEARED. IF THE OVERFLOW COUNTER IS 0, THE ANSWER
;IS SET TO 2.

SEARCH	FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17
ENTRY	OVERFL

	HELLO	(OVERFL)
	HRRZ	T1,.JBOPS	;GET THE LOW SEG POINTER
	SETZM	@(Q)		;CLEAR OUT ANSWER WORD
	AOS	@(Q)		;SET ANSWER TO 1
	SKIPN	OVCNT.(T1)		;ANY OVERFLOWS?
	AOS	@(Q)		;NO, SET ANSWER TO 2
	SETZM	OVCNT.(T1)		;RESET OVERFLOW COUNTER
	GOODBY	(1)	;RETURN

	PRGEND
TITLE	TRACE  DUMMY ROUTINE TO DEFINE THE TRACE ENTRY IN FOROTS (FORERR)
SUBTTL	D. TODD	/DRT		05-APR-1973



;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1973,1977 BY DIGITAL EQUIPMENT CORPORATION

	SEARCH	FORPRM
	ENTRY	TRACE		;HELLO MACRO CAN NOT BE USED
				;SIXBIT NAME DEFINED IN TRACE (FORERR)
TRACE=TRACE.##			;DEFINE THE EXTERNAL TRACE NAME
				;TRACE.=TRACE% IN (FORINI)
	PRGEND
TITLE	INIOVL %4.(311)- SUBROUTINE TO SET PRINCIPAL OVERLAY FILE
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1977 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	INIOVL

INIOVL=INIOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
TITLE	GETOVL %4.(311)- SUBROUTINE TO GET LINKS INTO CORE
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1977 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	GETOVL

GETOVL=GETOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
TITLE	REMOVL %4.(311)- SUBROUTINE TO REMOVE LINKS FROM CORE
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1977 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	REMOVL

REMOVL=REMOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
TITLE	RUNOVL %4.(311)- SUBROUTINE TO JUMP TO START ADDRESS OF LINK
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1977 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	RUNOVL

RUNOVL=RUNOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
TITLE	LOGOVL %4.(311)- SUBROUTINE TO SET LOG OVERLAY FILE
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1977 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	LOGOVL

LOGOVL=LOGOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
TITLE	TMPOVL %4.(311)- SUBROUTINE TO SET WRITABLE OVERLAY FILE
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1977 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	TMPOVL

TMPOVL=TMPOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
TITLE	SAVOVL %4.(311)- SUBROUTINE TO MARK LINK AS WRITABLE
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1977 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	SAVOVL

SAVOVL=SAVOV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND
TITLE	CLROVL %4.(311)- SUBROUTINE TO MARK LINK AS NOT WRITABLE
SUBTTL	D. M. NIXON	10-MAY-74




;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

;COPYRIGHT (C) 1974,1977 BY DIGITAL EQUIPMENT CORPORATION

VERWHO==0	;EDITOR
VERVER==1	;MAJOR VERSION NUMBER
VERUPD==0	;MINOR VERSION NUMBER
VEREDT==1	;EDIT NUMBER


ENTRY	CLROVL

CLROVL=CLROV.##			;REAL SUBROUTINE IS IN OVRLAY

PRGEND				;[364]
TITLE	FDDT.	%4.(364) - DUMMY FORDDT
SUBTTL	D. M. NIXON	SEP-4-74

ENTRY	FDDT.
	P=17

FDDT.:	PUSHJ	P,.+1		;FIRST TIME IN
	OUTSTR	[ASCIZ	/%FORDDT not loaded
/]
	PUSH	P,[CAI]		;REPLACE WITH NO-OP
	POP	P,FDDT.		;SO WE ONLY SEE MESSAGE ONCE
	POPJ	P,		;RETURN
	PRGEND			;[365],FDDT.+5,MD,9/04/74
TITLE FORX40	%4.(365)  OPEN & CLOSE INTERPRETER FOR F40 OPEN/CLOSE ARG BLOCKS

SUBTTL I.L.GOVERMAN	19-AUG-74

;
; THIS ROUTINE DESCENDS FROM THE ROUTINE 'XLA40.MAC' USED
; WITH EDIT 27M OF THE F40 COMPILER TO IMPLEMENT OPEN AND CLOSE
; STATEMENTS. IT ALLOWS VERSION 27 OF THE F40 COMPILER AND
; LATER VERSIONS TO USE FOROTS OPEN AND CLOSE
;



;	THIS ROUTINE IS CALLED FROM F40 WHEN AN OPEN OR CLOSE
; STATEMENT IS ENCOUNTERED.  THE JSA IS TO OPN40. FOR AN OPEN
; AND TO CLS40. FOR A CLOSE. THE ARGUMENT BLOCK
; THAT FOLLOWS THE JSA CONSISTS OF PAIRS OF ARGUMENTS OF THE FORM
;	ARG	0,G-VALUE
;	ARG	T,ADDR
;
; WHERE:
;	G-VALUE IS THE G-FIELD VALUE OF THE NEXT ARGUMENT,
; THE G-FIELD BEING AS DEFINED FOR THE FOROTS ARGUMENT BLOCK.
; IF THIS VALUE IS ZERO, (UNUSED BY FOROTS) THE NEXT ARGUMENT IS
; THE FORTRAN LOGICAL UNIT NUMBER.
;	T IS THE F40 VARIABLE TYPE CODE, THIS IS TRANSLATED TO F10
; CODE BY THIS ROUTINE.
;	ADDR IS THE ADDRESS OF THE PASSED ACTUAL ARGUMENT.
;

; USE STANDARD REGISTER DEFINITIONS
	SEARCH	FORPRM



	ARG==320	;F40'S SUBROUTINE ARG MARKER

;  EXTERNAL DECLARATIONS
	EXTERNAL OPEN., CLOSE.
PAGE
SUBTTL	SET FLAGS ON ENTRY AND PROCEED TO CONVERT ARGUMENTS


IFN	F40LIB<				;ONLY USED BY F40
	HELLO	(OPN40.)		;ENTRY POINT FOR F40 OPEN
	SETOM	OPNIP			;MARK OPEN IN PROGRESS
	JRST	SAC			;CONTINUE
	HELLO	(CLS40.)		;ENTRY POINT FOR CLOSE
	SETZM	OPNIP			;NOT AN OPEN IF ITS A CLOSE
SAC:	MOVEM	T0,S0			;SAVE THE AC S
	MOVE	T0,[XWD 1,S0+1]		;1-16
	BLT	T0,S0+16		;ZAP!
	MOVEI	T5,(L)			;COPY 16 TO PROLOG POINTER
	MOVEI	G1,1(T5)		;AND PLUS 1 TO ARG PTR
	SETZB	G2,RETADD		;ZERO SOME THINGS

; THIS IS THE MAIN PROCESSING LOOP FOR CONVERSION OF THE ARGUMENTS

LOOP:	PUSHJ	P,NEXTA			;IS NEXT ARG PAIR THERE?
	JRST	ALLDUN			;NO, GO CALL OTS
	AOJ	G2,			;INCREASE COUNT
	PUSHJ	P,GETARG		;GET AND CONVERT ARG PAIR
	JUMPN	G4,NOTUNI		;IF G-F NOT ZERO, THIS IS NOT UNIT
	MOVE	T1,(P1)			;FETCH ACTUAL UNIT VALUE
	HRRM	T1,UNIT			;AND STORE IT
	SOJA	G2,FINL			;RESET COUNTER AND FINISH LOOP
NOTUNI:	DPB	G3,[POINT 4,PB-1(G2),12]	;STASH VARIABLE TYPE
	DPB	G4,[POINT 9,PB-1(G2),8]		;AND ARGUMENT TYPE
	HRRM	P1,PB-1(G2)		;AND VARIABLE ADDRESS
FINL:	MOVEI	T5,2(T5)		;UPDATE POINTERS
	MOVEI	G1,2(G1)
	JRST	LOOP			;AND GO FOR NEXT PAIR



PAGE
SUBTTL	FINISH UP AND CALL THE APPROPRIATE FOROTS ROUTINE

ALLDUN:	MOVEI	G2,3(G2)		;UPDATE ARG BLOCK COUNTER
	MOVNI	T1,(G2)			;AND STORE IT FOR FOROTS
	HRLZM	T1,NUMARG		;DONE
	MOVEI	L,UNIT			;ARG BLOCK POINTER FOR OPEN/CLOSE
	SKIPE	OPNIP			;OPEN IN PROGRESS?
	JRST	DOOPN			;YES, DO OPEN
DOCLS:	PUSHJ	P,CLOSE.		;DO THE CLOSE
	SKIPA				;AND GO BACK
DOOPN:	PUSHJ	P,OPEN.			;HERE WE DO AN OPEN
	MOVE	T0,[ XWD S0+1,1]	;RESTORE AC S
	BLT	T0,L			;AND ITS DONE
	MOVE	T0,S0			;DONT FORGET AC0
	MOVE	T1,RETADD		;UPDATE RETURN
	GOODBYE	((T1))			;AND RETURN

SUBTTL UTILITY ROUTINES CALLED IN MAIN LOOP

; NEXTA SEES IF NEXT ARG PAIR IS PRESENT, SKIP RETURN IF THERE

NEXTA:	LDB	T1,[POINT 9,0(T5),8]	;PROLOG PTR
	LDB	T2,[POINT 9,0(G1),8]	;ARGUMENT POINTER
	CAIN	T1,ARG			;F40 NO-OP ?
	CAIE	T2,ARG			;FOR BOTH ?
	POPJ	P,			;NO, SO WE ARE DONE
	AOS	(P)			;UPDATE FOR SKIP RETURN
	AOS	RETADD			;SAME FOR RETURN ADDR UPDATE
	AOS	RETADD
	POPJ	P,			;BACK TO MAIN LOOP

; GETARG TAKES AN ARG PAIR AND LOADS REGISTERS G4,G3, AND P1
; WITH WITH FOROTS G-FIELD, VARIABLE CODE, AND ADDRESS OF ARGUMENT

GETARG:	HRRZ	G4,(T5)			;GET GFIELD AS IMMEDIATE VALUE
	LDB	G3,[POINT 4,(G1),12]	;F40 VARIABLE TYPE CODE
	MOVE	G3,F10TAB(G3)		;CONVERT TO F10 CODES
	HRRZ	P1,0(G1)		;AND VARIABLE ADDRESS
	POPJ	P,			;THATS ALL



PAGE
SUBTTL  DATA AND STORAGE AREA FOR THE TRANSLATOR


;F40 TO F10 VARIABLE TYPE CODE CONVERSION TABLE
; INDEX IS BY F40 CODE
F10TAB:	EXP	2		;INTEGER
	EXP	0		;NOT USED IN F40
	EXP	4		;1 WORD REAL
	EXP	1		;LOGICAL ARGUMENT
	EXP	6		;OCTAL
	EXP	17		;ASCII TEXT
	EXP	10		; DP INTEGER (DP IN F40)
	EXP	10		;DP INTEGER (COMPLEX IN F40)


; ACTUAL PARAMETER BLOCK SET UP FOR OPEN AND CLOSE

NUMARG:	BLOCK	1		;GET -NUMBER OF ARGS
UNIT:	BLOCK	1		;GETS LOGICAL UNIT NUMBER
	Z			;TWO ZERO WORDS
	Z
PB:	BLOCK	25		;REST OF THE PARAMETERS


; BLOCK FOR SAVING THE ACS
S0:	BLOCK	17

; RANDOM LOCATIONS
RETADD:	BLOCK	1			;ADDITIVE FOR RETURN TO MAIN PRG.
OPNIP:	BLOCK	1			;FLAG WORD, NON-ZERO FOR OPEN CALL
>	;END OF CONDITIONAL

	PRGEND


	TITLE ERRSNS  %5(1)  RETURN ERROR INDICATORS TO USERS

	SUBTTL  STAN WHITLOCK  19-JUL-76

;	STANDARD FORTRAN CALLING SEQUENCE, IE,
;		MOVE 	16,M
;		PUSHJ	17,ERRSNS
;
;		WHERE
;			M-1:	-ARG CNT,,0
;			M:	ARG1 ADR
;				ARG2 ADR

;	IF NO ARGS
;	  THEN RETURN
;	ARG1 := ERR.V1 FOR THIS USER
;	IF THERE IS AN ARG2
;	  THEN ARG2 := ERR.V2 FOR THIS USER

;	USES STANDARD DECLARATIONS FROM FORPRM

;	SAVES/USES/RESTORES REGS T0, T1, P4

	SEARCH	FORPRM

	ENTRY	ERRSNS

	SIXBIT	/ERRSNS/		; ROUTINE NAME FOR TRACE%

ERRSNS:	PUSH	P,T0			; SAVE REGS
	PUSH	P,T1
	PUSH	P,P4
	MOVE	P4,.JBOPS		; LOAD SAVE AREA POINTER
	HLRE	T0,-1(16)		; GET -ARG COUNT
	MOVNS	T0			; MAKE ARG COUNT POSITIVE
	CAIG	T0,0			; ANY ARGS ?
	JRST	DONE			; NO !
	MOVE	T1,ERR.V1(P4)		; GET FORTRAN STANDARDIZED
	MOVEM	T1,@0(16)		;   NUMBER AS FIRST ARG
	CAIG	T0,1			; SECOND ARG ?
	JRST	DONE			; NO
	MOVE	T1,ERR.V2(P4)		; GET PROCESSOR DEPENDENT
	MOVEM	T1,@1(16)		;   NUMBER AS SECOND ARG

DONE:	POP	P,P4			; RESTORS REGS
	POP	P,T1
	POP	P,T0
	POPJ	P,			; RETURN

	END