Google
 

Trailing-Edge - PDP-10 Archives - BB-D480F-SB_FORTRAN10_V10 - formsc.mac
There are 19 other files named formsc.mac in the archive. Click here to see a list.

	SEARCH	MTHPRM,FORPRM
	TV	FORMSC	Miscellaneous routines ,10(4207)
	SUBTTL	Sue Godsell/SRM/EDS/EGM/CDM/AHM/RVM/PLB/MRB	29-Mar-85


;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1977, 1985
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR ANY  OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF THE  SOFTWARE  IS  HEREBY
;TRANSFERRED.
;
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT  NOTICE
;AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY  OF  ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

COMMENT	\

***** Begin Revision History *****

***** Begin Version 6 *****

1100	SWG	15-Aug-75
	CLEANUP FOR V6 - REMOVE ALL F40, KA THINGS. JSYSIZE
	THOSE ROUTINES WHICH DO MONITOR CALLS: TIME,TIM2G0,DATE
	SSWTCH
	REMOVE .MXFOR AND FORX40;TAKE KA CONDITIONALS OUT OF UNIVERSAL;
	REMOVE UNNECESSARY AC DEFS FROM FLOAT. AND IFIX.
	Add OUTSTR macro for TOPS-20 IN FDDT.

1175	JLC	12-Dec-80
	Fixed LSNGET routine, did not like nulls in line number
	and did not clear digit AC, always returned error (-1).

1256	DAW	5-FEB-81
	Use new calling sequence for FOROP.

1260	DAW	6-Feb-81
	LSNGET smashed ACs 2 and 3.

1266	DAW	11-Feb-81
	Changes to support extended addressing in DUMP & PDUMP, TIME,
	and DATE routines.

1300	DAW	24-Feb-81
	Get FIN. calls and IOLISTS correct again in DUMP and PDUMP.

1302	JLC	24-Feb-81
	Changed LSNGET to have channel # as arg.

1335	EDS	12-Mar-81	Q10-05759
	Use symbols when testing output of ODCNV% jsys in TIME.
	Make TIME return the arguments correctly.

1342	EDS	13-Mar-81	Q10-05075
	Make routines TRACEable change everything to HELLO macros.
	Fix TWOSEG and RELOC problems.  Clean up TITLEs.

1351	EDS	16-Mar-81	Q10-04786
	Fix TWOSEG and RELOC problems.

1372	EGM	30-Mar-81	________
	Make OVERFL compatible with 5A, and eliminate TIME JSYS conflict.

1425	BL	14-Apr-81	Q10-05076
	Make OVERFL functionality include 'logical function'.
	Returns T0=0 if OVERFLOW=NO, T0=-1 if OVERLFOW=YES.
	Original functionality unchanged.

1464	DAW	12-May-81
	Error messages.

1500	DAW	27-May-81
	Edit 1464 made it get "E" error.

1517	BL	18-Jun-81	Q10-05075
	Use HELLO macro at CLRDIV (FORMSC).

1532	DAW	14-Jul-81
	OPEN rewrite: Base level 1

1560	DAW	28-Jul-81
	OPEN rewrite: Base level 2

1615	DAW	19-Aug-81
	Get rid of 2-word BP option.

1656	DAW	2-Sep-81
	Get rid of magic numbers.

1720	JLC	16-Sep-81
	Added test in DIVERT to make sure unit is open for FORMATTED I/O.

1747	DAW	28-Sep-81
	Got rid of FORPRM dependency in DIVERT.

1767	DAW	8-Oct-81
	Explain "magic" numbers in OVERFL.

2020	DAW	21-Oct-81
	Change DATE to return SPACE as last character instead of NULL,
	so it will match a literal generated by the compiler.

***** Begin Version 6A *****

2077	RJD	31-Aug-82
	In OVERFL, index OLDCT for a correct comparison between the tables
	containing the current APR counts and the old counts.

2103	MRB	13-Sep-82	20-18016
	Time function will return incorrect results for european time 
	zones. Use the TOPS-20 JSYS ODTIM to get correct time.

***** Begin Version 7 *****

3000	CDM	19-Oct-81
	Added character routines ADJC1., ADJCG.

3001	AHM	2-Oct-81
	Make ADJ1.  and  ADJG.  work under  extended addressing.   Also,
	redefine array dimension field from 777B8 to 177B8 so that array
	bounds checking blocks  in section  0 will  hopefully look  more
	like the final version to be redefined for extended  addressing.
	Finally, create a PROTA. entry point which is the same as PROAR.
	for now to match the symbol that FORTRA 7(1250) requests.

3025	AHM	18-Nov-81
	Fix a bug in the trailing space edit to DATE (2020) that I  introduced
	when merging it into the V7 sources, and change two MOVEIs to  XMOVEIs
	for extended addressing support for good measure.

3052	AHM	1-Mar-82
	Make PROAR. work for extended addressing by widening the  flag
	field in  the dimension  block to  the upper  4 bits.   Delete
	PROTA. entry  point  since  it  is  not  needed  for  extended
	addressing after all.

3066	RVM	27-Mar-82
	Fix ADJ1., ADJG., ADJC1., and ADJCG. to not calculate the size
	of assumed-size arrays.

3073	JLC	31-Mar-82
	Remove RELEAS routine; it was for F40.

3122	JLC	28-May-82
	Segment FORMSC. Changed LERRs to $FCALLs, and move error msgs
	to a separate module FORMSL in FORMSC.

3124	AHM	6-Jun-82
	Added a SEGMENT  macro to  FDDT so that  everything goes  into
	.CODE. and .DATA.  under FTXLIB.  Also, preserve T1 around the
	PSOUT for "%FORDDT not loaded" under Tops-20.

3125	JLC	3-Jun-82
	Moved the error character to the beginning of the error macro
	calls.

3131	JLC	11-Jun-82
	Allow character string argument for ERRSNS error string return.

3132	CKS	11-Jun-82
	Add PROSB. to do substring bounds checking.

3140	JLC	2-Jul-82
	Fix ERRSET so that -1 for error number gets the entire table
	instead of just the V6-defined traps.

3141	JLC	2-Jul-82
	Install FFUNIT.

3142	AHM	3-Jul-82
	Install PRGEND in FFUNIT.

3161	JLC	16-Aug-82
	Fixed ERRSNS for extended addressing multi-sections.

3165	JLC	28-Aug-82
	Separate bounds check errors from others.

3205	AHM	18-Nov-82
	Insert error message texts for  TMA, CGP, CRP, NSS, CFS,  CGS.
	Change VDM and ICF to "Should not happen" errors.  Reword AQS.

3206	CDM	5-Nov-82/17-Jan-83
	Allow character arguments for DATE and TIME.

3257	AHM	14-Jan-83
	Fix DUMP  and PDUMP  -  FUNCT macro  made OTSZERWRD  I/O  list
	elements non-zero, FIN word was in wrong half of an I/O  list,
	change positional OUT. argument lists to keyword form, correct
	change in carriage control semantics between V6 and V7.

***** End V7 Development *****

3311	AHM	21-Apr-83
	The dummy FDDT module that resolves XCT FDDT.## requests  from
	/DEBUG:TRACE when FORDDT isn't loaded was in the hiseg instead
	of the lowseg.   Unfortunately, FDDT. contains  self-modifying
	code, and write-locking the high segment made it die.

3322	TGS	6-Jun-83	SPR:20-19252
	Calling ERRSET with a subroutine argument not declared EXTERNAL
	in the calling program unit jumps into an empty variable when 
	the user subroutine is called. Test for this case and ABORT if so.

3362	TGS	28-Oct-83	SPR:20-19293
	New TOPMEM and SRTINI calls to set ENDP/STARTP to force memory
	allocation from a user-supplied page number downward and, for
	SRTINI, preallocate pages 600:677 for SORT.  Insert new error
	messages for IPN (Illegal page number) and CPP (Can't preallocate
	pages) errors.

3405	TGS	24-Jan-84	SPR:20-19857
	TIME subroutine will round minutes early (09:13 59.6 to 09:14 59.9
	if called in a loop, for example.)  Do not use ODTIM% to return
	hours and minutes, since this JSYS uses a totally different algorithm
	for rounding on minute boundaries.

3407	TGS	31-Jan-84	SPR:20-19929
	QUIETX should suppress library routine error summaries as well as
	CPU summaries. (FORMSC comment change only).


***** Begin Version 10 *****

4007	RJD	24-Mar-83
	Eliminate extra PUSH and POP in OVLP.

4012	PLB	1-Jun-83
	Fix ERRSET to work with user code and OTS in different sections.

4023	JLC	23-Jun-83
	Search MTHPRM also.

4030	PLB	6-Jul-83
	Fix OVERFL to remove AOBJN & BLT.

4044	JLC	19-Sep-83
	Changed F.MED so it uses $N for the subroutine name, and
	thus can be called by any subroutine.

4060	JLC	1-Nov-83
	Removed EXTEND error messages, mistakenly placed (by me)
	in FORMSL.

4065	JLC	6-Dec-83
	Add subroutine PA1050 to allow PA1050 in core for V10
	programs running on TOPS-20.

4074	RVM	28-Jan-84
	Add the Mil. Spec/VAX FORTRAN bit manipulation functions.

4100	MRB	9-Feb-84
	Added code to do compatibility flagging in FORLIB. Outputs
	a warning message for usage of non compatible language features
	like CALLing an external function.

4101	CDM	16-Feb-84
	Create and expand the  character stack differently when  running
	in extended addressing.   Give the stack  its own section(s)  so
	that it has plenty of room.  Also add user subroutine ALCCHR.

4110	CDM	8-Mar-84
	Reworked DUMP  and  PDUMP  to work  under  extended  addressing.
	Changed how the  AC's are stored  to be dumped  out (used to  be
	stored  on  the  stack,  with  AC's  being  PUSH-ed  and  POP-ed
	everywhere, even though this is a subroutine and doesn't need to
	preserve any AC's).  Corrected I/O calls  to the ots to work  in
	non-zero sections.  For  now, not  giving both  upper and  lower
	bounds for  dumping  will  give  a  warning  message.   Lots  of
	comments added.  Grouped  together argument lists  to make  them
	look coherent.  Changed  "-" to  "///" in  format statements  to
	make then standard conforming (/FLAG will flag this).

4121	AHM	30-Apr-84
	Made QUIETX use HELLO macro, since it is now user callable,
	and supported.
	Module:	FORMSC

4130	MRB	6-Jun-84
	Add check for compatibility flagger to routine FFUNIT.

4155	JLC	2-Oct-84
	Moved %SVCNV, a routine to manipulate symbol table pointers,
	to here so it can be accessed by FORDDT with OTS:SHARE, the
	LINKing of sharable FOROTS, and OTS:NONSHARE.
	Separate system-dependent code in %SVCNV.

4162	RVM	2-Nov-84
	Define VAX FORTRAN INTEGER*2 and INTEGER*4 INTRINSIC function names.

4163	RVM	2-Nov-84
	Define the undotted names of the bit functions.

4165	MRB	15-Nov-84
	Change the equates for the undotted names to the dotted names
	to equate 30 bit addresses instead of just 18 bit addresses.

4170	JLC	19-Nov-84
	Fix FORSYM: put in a SEGMENT CODE so the code isn't obliterated
	on TOPS-10.

4171	JLC	29-Nov-84
	Fix some documentation in ERRSET.

4172	MRB	4-Dec-84
	Fix-up some flagger stuff for the routines DATE, TIME, ERRSET, 
	ERRSNS. 

4174	JLC	9-Jan-85
	Fix %SVCNV for symbol tables up to 511 pages as IOWDs.

4206	CDM	29-Mar-85	QAR 853072
	Fix ISHFTC to work correctly when rotate index is negative.

4207	CDM	29-Mar-85	QAR 853038
	Add SECNDS function for VMS compatability.

***** End V10 Development *****

***** End Revision History *****
\


	PRGEND
	TITLE	ADJ1.	



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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.

	SEARCH	MTHPRM,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 PARAMETERS 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).

	SEGMENT	CODE

	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)
	ADD	TEMOFF,T2	;[3001] Keep (30 bit) sum of offset factors
	ADDI	TABREG,2	;ADVANCE POINTER
	JRST	LOOP1		;GO AROUND AGAIN

LUPDUN:	MOVN	TEMOFF,TEMOFF	;NEGATE OFFSET
	XMOVEI	T2,@2(ARG)	;[3001] Get 30 bit array base address
	ADD	TEMOFF,T2	;[3001] Add it in
	MOVEM	TEMOFF,@3(ARG)	;STORE VALUE OF OFFSET
	MOVE	T2,@5(TABREG)	;FETCH U(I) FOR LAST ARRAYSIZE MULTIPLY
	CAME	T2,[1B0-1]	;[3066] Don't multiply for assumed-size array
	 IMULM	T2,@1(ARG)	;MULTIPLY TO MEM IT IN

	POP	P,TABREG	;RESTORE REGISTERS
	POP	P,T2
	GOODBY
	PRGEND
	TITLE	ADJG.	



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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.

	SEARCH	MTHPRM,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 PARAMETERS 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)

	SEGMENT	CODE

	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)
	ADD	TEMOFF,T2	;[3001] Add (30 bits) 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
	XMOVEI	T2,@2(ARG)	;[3001] Get 30 bit array base address
	ADD	TEMOFF,T2	;[3001] Add it in
	MOVEM	TEMOFF,@3(ARG)	;STORE OFFSET
	MOVE	T2,@5(TABREG)	;GET U(I) FOR LAST ARRAYSIZ MULT
	CAMN	T2,[1B0-1]	;[3066] Assumed-size array case?
	 JRST	BYE		;[3066] Yes, don't calculate size
	SUB	T2,@6(TABREG)	;-L(I)
	ADDI	T2,1		;ADD ONE OF COURSE
	IMULM	T2,@1(ARG)	;MULT AND STACH IN ARRAY SIZE

BYE:	POP	P,TABREG	;RESTORE REGISTERS USED
	POP	P,T2
	GOODBY

	PRGEND
	TITLE	ADJC1.	 Adjustable dimension with start of 1

	SEARCH	MTHPRM,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. Modeled from ADJ1.
; MULT(I) are multipliers.

; U(I) are upper bounds (equivalent to range).

;	MULT(1)=<size of array from descriptor>
;	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

; The parameters passed are (inorder):
;	Pointer to number of dimensions
;	Pointer to temp for ARRAYSIZ
;	Descriptor of array
;	Pointer to temp for OFFSET
;	MULT(1)
;	U(1)
;	MULT(2)
;	U(2)
;		.
;		.
;		.
;	MULT(N)
;	U(N)

; **Note that MULT1(1) is assigned from the descriptor's size
;   unlike for numeric arrays (ADJ1) which has a constant passed.

	SEGMENT	CODE

	HELLO	(ADJC1.)
	PUSH	P,T2		;Save registers used
	PUSH	P,TABREG	;

	DMOVE	T1,@2(ARG)	;Get array descriptor, t2=size of array
	MOVEM	T2,@4(ARG)	;Assign MULT(1)
	MOVEM	T2,@1(ARG)	;Initialize ARRAYSIZ
	MOVE	TEMOFF,T2	;Get offset with MULT(1)
	MOVE	T1,@0(ARG)	;Fetch dimensionality 
	MOVE	TABREG,ARG	;Copy arg register
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)
	ADD	TEMOFF,T2	;Keep sum of OFFSET factors
	ADDI	TABREG,2	;Advance pointer
	JRST	LOOP1		;Go around again

LUPDUN:	MOVNM	TEMOFF,@3(ARG)	;Negate OFFSET and store it
	MOVE	T2,@5(TABREG)	;Fetch U(I) for last arraysize multiply
	CAME	T2,[1B0-1]	;[3066] Don't multiply for assumed-size array
	 IMULM	T2,@1(ARG)	;Multiply to mem it in

	POP	P,TABREG	;Restore registers
	POP	P,T2
	GOODBY
	PRGEND
	TITLE	ADJCG.   General adjustable dimension array

	SEARCH	MTHPRM,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.  It is modeled after ADJG.

; 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

;	MULT(1)=<size from descriptor passed>
;	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
;	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
;	Descriptor for array
;	Pointer to temp containing offset
;	MULT(1)
;	U(1)
;	L(1)
;	MULT(2)
;	U(2)
;	L(2)
;		.
;		.
;		.
;	MULT(N)

	SEGMENT	CODE

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

	DMOVE	T1,@2(ARG)	;Descriptor, T2 is size of array
	MOVEM	T2,@4(ARG)	;Assign MULT(1)
	MOVEM	T2,@1(ARG)	;INITIALIZE ARRAYSIZ
	MOVE	T1,@0(ARG)	;FETCH DIMENSIONALITY
	MOVE	TABREG,ARG	;COPY ARG REGISTER
	SETZ	TEMOFF,		;CLEAR OFFSET
LOOP1:	IMUL	T2,@6(TABREG)	;MULT(1)*L(1)
	ADD	TEMOFF,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:	MOVNM	TEMOFF,@3(ARG)	;NEGATE OFFSET and store it
	MOVE	T2,@5(TABREG)	;GET U(I) FOR LAST ARRAYSIZ MULT
	CAMN	T2,[1B0-1]	;[3066] Assumed-size array case?
	 JRST	BYE		;[3066] Yes, don't calculate size
	SUB	T2,@6(TABREG)	;-L(I)
	ADDI	T2,1		;ADD ONE OF COURSE
	IMULM	T2,@1(ARG)	;MULT AND STACH IN ARRAY SIZE

BYE:	POP	P,TABREG	;RESTORE REGISTERS USED
	POP	P,T2
	GOODBY

	PRGEND
	TITLE	ADJ.	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) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.

;FROM LIB40 VERSION V.032(323)
;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	MTHPRM,FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17

	SEGMENT	CODE

	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 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

	SEGMENT	DATA

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

	PRGEND
	TITLE	PROAR.	ARRAY BOUNDS CHECKING ROUTINE
	SUBTTL	SARA MURPHY/AHM	1-Mar-81

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.

	SEARCH	MTHPRM,FORPRM		;DEFINE GLOBAL SYMBOLS
	FSRCH			;[3052] Search MACTEN or MACSYM

; Routine to perform FORTRAN array bounds checking at run time.

; Called with an argument block of the form:
;	-------------------------------------------------
;	!1!0!			! PTR TO SEQ NUMB OF ST	!
;	-------------------------------------------------
;	!1!0!			! PTR TO DIMENSION INF	!
;	-------------------------------------------------
;	!1!0!			! PTR TO 1ST SUBSCRIPT	!
;	-------------------------------------------------
;	!1!0!			! PTR TO 2ND SUBSCRIPT	!
;			     Etc.
;
; Where dimension information is represented by a block of the form:
;	-------------------------------------------------
;	!  		ARRAY NAME (IN SIXBIT)		!
;	-------------------------------------------------
;	!1!0! DIM CT !     !I!	! BASE ADDRESS		!
;	-------------------------------------------------
; V6	!A!F!0!0!		! PTR TO OFFSET		!
; V7	!1!0!A!F!		! PTR TO OFFSET		!
;	-------------------------------------------------
;	!1!0!			! PTR TO 1ST LOWER BND	!
;	-------------------------------------------------
;	!1!0!			! PTR TO 1ST UPPER BND	!
;	-------------------------------------------------
;	!1!0!			! PTR TO 1ST FACTOR	!
;	-------------------------------------------------
;	!1!0!			! PTR TO 2ND UPPER BND	!
;
;			     ETC
;   WHERE A IS A FLAG FOR "ADJUSTABLY DIMENSIONED ARRAY"
;	F IS A FLAG FOR "FORMAL ARRAY"
;
; Note that  the argument  list  is created  in the  compiler  routine
; PROARRXPN in the file ARRXPN.BLI and the dimension block is  created
; and written in CGDIMBLK in DEBUG.BLI.
;
;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.

; Note that there are two formats for the adjustably dimensioned array
; and formal array flags.  The old format used for V6 and before  used
; the two high  order bits  of the flag  word.  The  pattern "10"  was
; illegal for  V6 because  it means  "adjustably dimensioned  but  not
; formal" -  a  non-sequitur for  Fortran.   Which is  just  as  well,
; because the two high order bits of the flag word had to be forced to
; "10" for V7  in order to  make the  flag word an  IFIW for  extended
; addressing.  The definitions of the bits were just shifted over by 2
; places for extended addressing.

	DP=P4		;PTR INTO THE BLOCK OF DIMENSION INFORMATION. POINTS
			; TO THE SUB-BLOCK OF INFORMATION FOR A GIVEN DIMENSION
	SSP=P1		;[3052] Pointer to the arg block entry for a subscript
	SS=P2		;Value of the subscript being processed
	COUNT=P3	;[3052] The number of subscripts left to go
	SUM=0		;[3052] Computed sum of subscripts with factors
			;[3052]  (Used to compute the element 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

	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

	DCTSIZ=7	;[3001] Number of bits in the dimension count
			;[3001]  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

	TYPWRD==1	;[3052] Dim block word that contains the array type
	TYPMSK==<Z 17,0>	;[3052] Type field is the AC field

	DFLGWD=2	;DIMENSION BLOCK FLAGS ARE IN WD 2 OF DIM BLO
	DFLSIZ=4	;[3052] Dimension block flags are 4 bits
	DFLPOS=3	;[3052] Bits 0-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

	SEGMENT	CODE
	EXTERN	ABORT.		;[3205] FOROTS fatal error entry point

	HELLO	(PROAR.)
	PUSH	P,DP		;SAVE ACs
	PUSH	P,SSP
	PUSH	P,SS
	PUSH	P,COUNT		;[3052] Save the count AC


	XMOVEI	DP,@DBLKP(L) 	;[3052] Pointer to dimension block

	XMOVEI	SSP,SS1WD(L)	;[3052] Set up pointer to the SS list
	LDB	COUNT,[POINT DCTSIZ,DCTWD(DP),DCTPOS] ;Load dimension count

; Get flags to see how to compute the base address of the array.

	LDB	T1,[POINT DFLSIZ,DFLGWD(DP),DFLPOS] ; Adj-dim and formal flags

	LDB	SUM,[POINTR (TYPWRD(DP),TYPMSK)] ;[3052] Get the array type
	CAIN	SUM,TP%CHR 	;[3052] Is it a character variable ?
	 MOVEI	T1,^B1011	;[3052] Yes, they act like an adjustable formal
				;[3052]  (The main program "adds in" the array
				;[3052]  base with an ADJBP, but we are
				;[3052]  responsible for starting off with the
				;[3052]  offset pointed to by DOFFWD(DP))


	XCT	PXCTAB(T1)	;Execute table entry (indexed by T1)
	XMOVEI	DP,D1WD(DP)	;[3052] Pointer 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,PERR		; 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
	ADDI	SSP,1		;[3052] Go on to next SS
	SOJG	COUNT,LP	;[3052] Loop back for more

	POP	P,COUNT		;[3052] Restore ACs
	POP	P,SS
	POP	P,SSP
	POP	P,DP
	POPJ	P,		;RETURN


;EXECUTE TABLE
; There are presently 4 bits - this implies a 16 word table.

PXCTAB:	MOVEI	SUM,0		;[3052] |0000| V6 Non-formal
	$FCALL	SNH,ABORT.	;[3052] |0001| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |0010| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |0011| Flags for V7 set by V6
	XMOVEI SUM,@DBASWD(DP)	;[3052] |0100| V6 Non-adj formal
	$FCALL	SNH,ABORT.	;[3052] |0101| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |0110| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |0111| Flags for V7 set by V6
	MOVEI	SUM,0		;[3052] |1000| V7 Non-formal
	XMOVEI SUM,@DBASWD(DP)	;[3052] |1001| V7 Non-adj formal
	$FCALL	SNH,ABORT.	;[3052] |1010| V7 Adj but not formal
				;[3052]           should never occur
	MOVE	SUM,@DOFFWD(DP)	;[3052] |1011| V7 Computed offset for
				;[3052]           an adjustable array
	MOVE	SUM,@DOFFWD(DP)	;[3052] |1100| V6 Computed offset for
				;[3052]           an adjustable array
	$FCALL	SNH,ABORT.	;[3052] |1101| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |1110| Flags for V7 set by V6
	$FCALL	SNH,ABORT.	;[3052] |1111| Flags for V7 set by V6

;END OF EXECUTE TABLE

;ROUTINE CALLED WHEN A BOUNDS VIOLATION HAS BEEN DETECTED

PERR:	XMOVEI	T1,1-SS1WD(SSP) ;[3052] Set T1 to the dimension
	SUB	T1,L		;[3052] being processed
	PUSH	P,T2		;SAVE T2,T3
	PUSH	P,T3
	MOVE	T2,@ARNAMP(L)	;GET THE ARRAY NAME
	MOVE	T3,@ISNWD(L)	;GET THE ISN

;(SRE,21,101,%,<Subscript range error - subscript $D of array $S = $D
;	on line $D>,<T1,T2,P2,T3>)

	$FCALL	SRE		;ISSUE MESSAGE, CONTINUE

	POP	P,T3		;RESTORE T2,T3
	POP	P,T2
	POPJ	P,

;@ISNWD(L)[T3]/	ISN of statement containing this array ref
;T1/			Dimension number being processed
;@ARNAMP(L)[T2]/	Array name in SIXBIT
;SS[P2]/		Value of illegal subscript


	PRGEND
	TITLE	FORDMP - DUMP and PDUMP Dump memory routines
	SUBTTL	/DMN/SWG/DAW/AHM

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.

;FROM	1 MAY 1966 ED YOURDON, 2/12/68 NSR

;++
; FUNCTIONAL DESCRIPTION:
;
;	Both DUMP and PDUMP  output core to a  line printer between  the
;	optional locations passed by the user.  DUMP calls "EXIT."  when
;	done, while PDUMP  returns to  the users program.   The code  is
;	shared, ENTFLG is used  to determine whether  DUMP or PDUMP  was
;	entered.
;
;	First to be dumped are following PC flags and then the  contents
;	of the accumulators.
;
;		AR OV FLAG
;		AR CRY0 FLAG
;		AR CRY1 FLAG
;		PC CHANGE FLAG - FLOATING OVERFLOW
;		BIS FLAG
;
;	Following this are any memory locations the user has specified.
;
;	If a group of memory locations have the same contents, DUMP  and
;	PDUMP will finish printing the  current line, then indicate  the
;	repeated locations by:
;
;		Locations xx through yy contain zz
;
; CALLING SEQUENCE:
;
;	CALL DUMP(A(1),B(1),F(1), ... ,A(n),B(n),F(n))
;	CALL PDUMP(A(1),B(1),F(1), ... ,A(n),B(n),F(n))
;
; INPUT PARAMETERS:
;
;	Arguments are in triplets, each triplet taken separately.
;
;	A(n)	First element to be dumped.
;
;	B(n)	Last element to be dumped.
;
;		If the last two arguments, B(n) and F(n), are missing an
;		octal dump is made from A(n) to the end of user area.
;
;	F(n)	Mode to dump the elements in.
;	
;			0	octal		(O12 format)
;			1	floating point	(G12.5 format)
;			2	integer		(I12 format)
;			3	ascii		(A12 format)
;			4	double precision (G25.16)
;
;		An illegal or missing mode assignment causes the dump to
;		be made in octal.
;
;	where A, B, and F are optional sets of triplet arguments.
;
;	If no arguments  are given, the  entire user area  is dumped  in
;	octal.  Under extended  addressing, both A(n)  and B(n) must  be
;	given.
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	None
;
; SIDE EFFECTS:
;
;	Used as Fortran subroutine, does NOT save AC values.
;
;--




	;Accumulator assignments and parameter assignments

		B==3		;SCRATCH
		C==4		;...
		S==5		;ADDRESS OF LOCATION CURRENTLY DUMPED
		F==6		;ADDRESS OF HIGH LOCATION TO BE DUMPED
		I==7		;ARGUMENT INDICATOR
		LL==10		;LOOP COUNTER
		FRMT==11	;HOLDS FORMAT FOR REPEATED LINES
		ARC==12		;-Number of args left
		PP==15		;BLT AC, ALSO HOLDS A FORMAT ADDRESS
		P==17		;PUSHDOWN POINTER

		N==12		;SIZE OF AC BLOCK TO BE SAVED ON PD LIST
		DEVICE==-3	;DEVICE ASSIGNMENT FOR PRINT
		NLIST==5	;NO. OF DIFFERENT FORMAT DUMPS AVAILABLE
	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(DUMP)		;Beginning of DUMP routine

	SETOM	ENTFLG		;FLAG DUMP ENTRY = -1
	JRST	DUMPA		;HOP DOWN TO COMMON CODE

	HELLO	(PDUMP)		;Beginning of PDUMP routine
	SETZM	ENTFLG		;FLAG PDUMP ENTRY = 0

;Common code to  DUMP and PDUMP.  Dump the  PC flags and  save away  the
;AC's.

DUMPA:	DMOVEM	T0,ACSAVE	;[4110] Save AC0, AC1
	MOVEM	T2,ACSAVE+2	;[4110] Save AC2
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

IF20,<

	XMOVEI	T1,.		;What section are we running in?
	TLNN	T1,-1		;[4110] Is section non-zero?
	 JRST	DPNZER		;[4110] No, in section 0

	;Running  in   non-zero  section.    Get  and   Save  PC   flags
	;differently.

	XSFM	FLGLOC		;Save PC flags the extended way.

	;Save AC3 through AC17

	MOVEI	T0,20-3		;[4110] Number of AC's to move.
	XMOVEI	T1,T3		;[4110] AC3 is start of what to move
	XMOVEI	T2,ACSAVE+3	;[4110] Where to put the saved AC's

	EXTEND	T0,[XBLT]	;[4110] Save AC 3 thru AC 17

	JRST	DPPRFL		;[4110] Ready to dump flags

>; End IF20


	;Get PC flags and save AC's away.

DPNZER:	POP	P,FLGLOC	;[4110] Get PC flags out.  The  PUSHJ  to
				; call us loaded them  in the left  half
				; of the  return address  pushed on  the
				; stack.
	PUSH	P,FLGLOC	;Restore to top of stack

	;Save AC3 through AC17

	HRLI	T1,T3		;[4110] [Source=AC3,,0]
	HRRI	T1,ACSAVE+3	;[4110] [source,,Destination]
	BLT	T1,ACSAVE+20-1	;[4110] Save AC's
				;[4110] Destination + n -1

	;Print headers for PC flags

DPPRFL:	XMOVEI	L,ARG3		;[4110]
	PUSHJ	P,OUT.##	;[3257] Set up for output

	;Put out the actual PC flags, "ON"/"OFF"

	MOVE	C,BYTEP		;GET BYTE POINTER FOR FLAGS
	MOVEI	F,5		;LOOP FOR FIVE FLAGS

FLAGS:	ILDB	B,C		;GET FLAG BIT STORED BY JSR
	MOVE	S,OFFON(B)	;GET EITHER "OFF" OR "ON"
	XMOVEI	L,ARG4		;[4110]
	PUSHJ	P,IOLST.##	;[3257] Do the output
	SOJG	F,FLAGS		;LOOP BACK FOR MORE FLAGS

	FUNCT	FIN.##		;Finish outputting

;Output the values in the AC's.

	;Setup the format for printing "ACnn" headers and the AC values

	XMOVEI	L,ARG5		;[4110] Output S
	PUSHJ	P,OUT.##	;[3257] Set up for more output
	CLEARB	S,I		;AC0-AC7, SET INDICATOR TO ZERO

	;Output "AC 00 ... AC 07"

D1:	XMOVEI	L,ARG4		;[4110] Output S
	PUSHJ	P,IOLST.##
	CAIGE	S,7		;For registers 0 thru 7
	 AOJA	S,D1		;Loop back until done

	;Output the contents of AC0 through AC7

	XMOVEI	L,ARG6		;[4110] ACSAVE through ACSAVE+7
	PUSHJ	P,IOLST.##

	;Output "AC 10 ... AC 17"

	MOVEI	S,10		;Start with AC 10

D3:	XMOVEI	L,ARG4		;[4110] Output S
	PUSHJ	P,IOLST.##
	CAIGE	S,17		;Done AC17 yet?
	  AOJA	S,D3		;No, Loop again

	;Output contents of AC10 through AC17

	XMOVEI	L,ARG7		;[4110] ACSAVE+10 through ACSAVE+17
	PUSHJ	P,IOLST.##

;Argument processor.  See how many arguments we have.

	MOVE	L,ACSAVE+L	;[4110] Restore argument pointer
	HLRE	ARC,-1(L)	;Get -arg count
	JUMPE	ARC,ENDCHK	;No arguments: Dump all of core

;Come here to process a set of 3 args.  We have at least one.  If less
;than three, then we must set up defaults.
;
;	L	points to arg list
;	ARC	is -number of args left

SGET:	SETZ	I,		;Set to 1 if whole group of 3 args present

	XMOVEI	L,ARG8		;[4110]
	PUSHJ	P,OUT.##	;[3257] Go set up for output and do it
	FUNCT	FIN.##		;[3257] All done!

	AOJG	ARC,SDOUT	;If no more args, quit
	MOVE	L,ACSAVE+L	;[4110] Restore argument pointer

	XMOVEI	S,@0(L)		;Yes, pick up the address of beginning
	AOJG	ARC,ENDCK2	;End of arg list

	XMOVEI	F,@1(L)		;No, F:= end address
	AOJG	ARC,ENDCK3	;Jump if end of arg list

	MOVE	C,@2(L)		;No, C:= format type code
	AOJ	I,		;INDICATE THAT ALL 3 ARGUMENTS HAVE BEEN SEEN
	CAIL	C,NLIST		;IS THIS A LEGAL ARGUMENT?
	 JRST	ENDCK3		;No, DUMP IN OCTAL MODE

;Now we dump some memory out.  Check the arguments

;Come here with:
;	C = type of dump (0= Octal, 1= floating, etc.)
;	S = Lowest location to be dumped
;	F = Highest location to be dumped
;	I = 0 if we defaulted any args because they were missing,
;	  = 1 if all three args were present.

SCHEK:	CAML	S,F		;ARE ARGUMENTS IN ORDER?
	 EXCH	S,F		;NO, SWITCH THEM

	MOVE	PP,C		;COPY ARG TO PP FOR USE IN ARG BLOCKS
	MOVE	B,TABLE(C)	;Get ots code for the mode specified
	DPB	B,[POINT 4,IOLSTC,12]	;Put mode in the format for IO call
	DPB	B,[POINT 4,IOLSTS,12]	;""
;Main dump processor

DPROC:	MOVE	B,S		;[4110] GET CURRENT ADDRESS IN B
	MOVE	LL,S		;POINTER IN REPETITION CHECK

;Look for repeating words in the dump.  If we can find multiple  line(s)
;(8 or more words) that repeat,  then output them in groups rather  than
;every word separately.

;	C	is the location to compare against.
;	LL	is incremented every time through the loop to be the
;		next memory location to look at.

	MOVE	C,@S		;Word to check against for repetition

LOOK:	CAMN	C,@LL		;Do words match?
	 CAMGE	F,LL		;Yes, Finished this section of code?
	  JRST	DIFF		;Go compute repeated lines

	XMOVEI	T1,@S		;Where to begin dumping
	ADDI	T1,7		;Above + 7 = "end of a line"
	CAML	LL,T1		;Finished checking a line?
	 ADDI	S,10		;Yes, increment S to next line
				; Unless incremented, we don't have any matches
	CAMG	S,F		;Beyond the end of what to dump?
	 AOJA	LL,LOOK		;No, increment pointer, check more

	;End of checking for repetition.  Either have reached the end of
	;memory to dump or have found a non-identical line.

DIFF:	CAMN	B,S		;WERE ANY LINES REPEATED?
	 JRST	OLOOP0		;NO, DUMP THIS LINE INDIVIDUALLY

	;Found identical line(s).  "Locations n thru m contain "

	MOVE	T1,S		;[4110] Last loc
	SUBI	T1,1		;[4110] Off by one
	XMOVEI	L,ARG9		;[4110]
	PUSHJ	P,OUT.##	;[3257] Set up for output

	XMOVEI	L,ARG10		;[4110] Output B, T1
	PUSHJ	P,IOLST.##	;END OF REPETITION MESSAGE

	;Output the common word that is repeated.

	XMOVEI	L,ARG1		;GET FORMAT FOR MESSAGE
	PUSHJ	P,OUT.##

	XMOVEI	L,IOLSTC	;OUTPUT REPEATED WORD -> C
	PUSHJ	P,IOLST.##

	;Loop for  outputting words.   Start outputting  a regular  line
	;here.  8 words per line.

OLOOP0:	MOVE	C,LIST2(PP)	;PICK UP FORMAT TYPE
OLOOP1:	CAMLE	S,F		;ALL DONE DUMPING?
	 JRST	NEXT1		;YES, CHECK  for more ARGUMENTS

	XMOVEI	L,ARG2		;NO, OUTPUT FOR 8 WORDS/LINE
	PUSHJ	P,OUT.##	

	XMOVEI	L,ARG4		;[4110] Output S
	PUSHJ	P,IOLST.##

	;Each time through loop output one location.

	MOVEI	B,^D8		;LOOP COUNTER - Output 8 memory locations

OLOOP2:	XMOVEI	L,IOLSTS	;ADDRESS FOR THIS LINE
	PUSHJ	P,IOLST.##	;MEMORY WORD
	CAML	S,F		;ALL DONE DUMPING
	 JRST	NEXT		;YES, CHECK for more ARGUMENTS

	CAIE	PP,DFMNM	;Double precision?
	 AOJA	S,OLOOP3	;NO, MOVE POINTER TO NEXT WORD
	ADDI	S,2		;YES, ADVANCE POINTER ONE WORD
	SOJ	B,		;OUTPUTS ONLY 4 WORDS

OLOOP3:	SOJG	B,OLOOP2	;DONE WITH THIS LINE?

	PUSHJ	P,FIN.##	;YES, FINISH OFF FORMAT STATEMENT
	JRST	DPROC		;[4110] SCAN NEXT LINE

;One or more arguments missing.  Set defaults, then dump the memory.

	;No arguments given.

ENDCHK:	HRRZI	S,20		;DUMP FROM 20 (after registers)

	;Ending and mode not given

ENDCK2:	HRRZ	F,.JBFF		;TO END OF USER AREA
	SUBI	F,1		;DO NOT DUMP FIRST FREE

IF20,<

	;If running in  non-zero section, user  must give beginning  and
	;ending arguments to dump memory.  Extended adressing means  too
	;much memory to dump everything on an innocent line printer.

	XMOVEI	T1,T0		;[4110] Section that AC 0 is in
	JUMPE	T1,ENDCK3	;[4110] If section zero, then ok

	$FCALL	DMA		;[4110] Warning - Give me some arguments!!
	JRST	SDOUT		;[4110] Exit, don't do anything.

> ;End IF20

	;Mode not given

ENDCK3:	SETZ	C,		;Set OCTAL mode
	JRST	SCHEK		;FIX EXIT, CHECK CORE LIMITS


;Dump is finished.  Process next triplet of arguments (if there is any).

NEXT:	PUSHJ	P,FIN.##	;FINISH FORMAT
NEXT1:	JUMPE	I,SDOUT		;MORE ARGUMENTS TO COME?
	MOVEI	T0,3		;[4110]
	ADDM	T0,ACSAVE+L	;[4110] Yes, saw 3 args last time, Bump arg ptr.
	JRST	SGET		;GO GET SOME MORE ARGUMENTS


;Here when done dumping all arguments.  Get ready to return to caller or
;jump to EXIT. .

SDOUT:	SKIPE	ENTFLG		;[4110] IS IT THE PDUMP ENTRY?
	 JRST	SDOUT1		;NO - DUMP
	GOODBY			;PDUMP - RETURN TO USER

SDOUT1:	FUNCT	(EXIT.)		;DUMP - Exit and stop the program

;Format statements for output

	EXP	MESS1L		;[3257] FMTSIZ=
MESS1:	ASCII	"(1H148X9HCORE DUMP/1H 7HOv flag17X9HCry0"
	ASCII	" flag15X9HCry1 flag15x12HFlt ov flag 13X"
	ASCII	"8HFPD flag/1H 5(A9,15X))"
	MESS1L==.-MESS1		;[3257] Compute size of FORMAT statement

	EXP	MESS2L					;[3257] FMTSIZ=
MESS2:	ASCII	"(2(/// 8(9X 3HAC O2) /7X8O14/))"	;[4110] "AC nn"
	MESS2L==.-MESS2		;[3257] Compute size of FORMAT statement

	EXP	MESS3L		;[3257] FMTSIZ=
MESS3:	ASCII	"(///)"		;[4110] Skip three lines
	MESS3L==.-MESS3		;[3257] Compute size of FORMAT statement

	EXP	MESS4L		;[3257] FMTSIZ=
MESS4:	ASCII	"(///' Locations 'O10,9H through O10,9H contain /1H )"	;[4110]
	MESS4L==.-MESS4		;[3257] Compute size of FORMAT statement

;Argument blocks for OUT./IOLST. calls 

	XWD	-2,0
ARG1:	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE]	;[4110] UNIT=
	BYTE (2)^B10 (7)2 (4)TP%LBL (5)35 (18)LIST1	;[4110] @LIST1(PP)

	XWD	-2,0
ARG2:	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE]	;[4110] UNIT=
	BYTE (2)^B10 (7)2 (4)TP%LBL (5)35 (18)LIST2	;[4110] @LIST2(PP)

	XWD -2,0					;[3257] Arg count
ARG3:	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE]	;[4110] UNIT=
	BYTE (2)^B10 (7)2 (4)TP%LBL (5)0 (18)MESS1	;[4110] FMT=

	XWD -2,0				;[3257] Arg count
ARG4:	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)S	;[4110] S
	0					;[4110] End of list

	XWD -2,0					;[3257] Arg count
ARG5:	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE]	;[4110] UNIT=
	BYTE (2)^B10 (7)2 (4)TP%LBL (5)0 (18)MESS2	;[4110] FMT=

	XWD -4,0					;[4110] 4 args
ARG6:	BYTE (2)^B10 (7)2 (4)TP%INT (5)0 (18)[10]	;[4110] 10 words
	BYTE (2)^B10 (7)0 (4)TP%INT (5)0 (18)[1]	;[4110] Incr by 1
	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)ACSAVE	;[4110] Start here
	0						;[4110] EOL

	XWD -4,0					;[4110] 4 args
ARG7:	BYTE (2)^B10 (7)2 (4)TP%INT (5)0 (18)[10]	;[4110] 10 words
	BYTE (2)^B10 (7)0 (4)TP%INT (5)0 (18)[1]	;[4110] Incr by 1
	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)ACSAVE+10	;[4110] Start here
	BYTE (2)^B10 (7)4 (27)0				;[4110] Fin

	XWD -2,0					;[3257] Arg count
ARG8:	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE]	;[4110] UNIT=
	BYTE (2)^B10 (7)2 (4)TP%LBL (5)0 (18)MESS3	;[4110] FMT=

	XWD -2,0					;[3257] Arg count
ARG9:	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE]	;[4110] UNIT=
	BYTE (2)^B10 (7)2 (4)TP%LBL (5)0 (18)MESS4	;[4110] FMT=

	XWD -3,0				;3 args
ARG10:	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)B	;[4110] Addresses
	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)T1	;[4110] First location rep'ed
	BYTE (2)^B10 (7)4 (27)0			;[4110] Last


;More format statements and some constants, too

	EXP	4		;[3257] Size of FORMAT
OFRMT:	ASCII	"(1H0,O10,8O14)"
	EXP	4		;[3257]
EFRMT:	ASCII	"(1H0,O10,8G14.5)"
	EXP	4		;[3257]
IFRMT:	ASCII	"(1H0,O10,8I14)"
	EXP	4		;[3257]
AFRMT:	ASCII	"(1H0,O10,8A14)"
	EXP	4		;[3257]
DFRMT:	ASCII	"(1H0,O10,4G25.16)"

	EXP	4		;[3257]
OFRMT2:	ASCII   "(1H0,40X,O14)"
	EXP	4		;[3257]
EFRMT2:	ASCII	"(1H0,40X,G14.5)"
	EXP	4		;[3257]
IFRMT2:	ASCII	"(1H0,40X,I14)"
	EXP	4		;[3257]
AFRMT2:	ASCII	"(1H0,40X,A14)"
	EXP	4		;[3257]
DFRMT2:	ASCII	"(1H0,40X,G25.16)"

LIST1:	IFIW	OFRMT2
	IFIW	EFRMT2
	IFIW	IFRMT2
	IFIW	AFRMT2
	IFIW	DFRMT2
LIST2:	IFIW	OFRMT
	IFIW	EFRMT
	IFIW	IFRMT
	IFIW	AFRMT
	IFIW	DFRMT
DFMNM==.-LIST2-1		;D format index

OFFON:	ASCII	"OFF  "		;Flag is off
	ASCII	"ON   "		;Flag is on

TABLE:	EXP	TP%SPO,TP%SPR,TP%INT,TP%LIT,TP%DPR
BYTEP:		POINT 1,FLGLOC	;Byte pointer for PC flags

	SEGMENT	DATA

;** IOLSTC and IOLSTS have their dump "mode" (specified by user) written
;** into them, so they must be writable.

	XWD	-2,0
IOLSTC:	BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)C		;[4110] C
	BYTE (2)^B10 (7)4 (29)0				;[4110] Fin

	XWD	-2,0
IOLSTS:	BYTE (2)^B10 (7)1 (4)TP%INT (1)1 (4)0 (18)S	;[4110] Indirect bit on
	0						;End of list

FLGLOC:	BLOCK	1		;TO STORE PC WORD flags
ENTFLG:	BLOCK 	1		;Flag for which entry WAS taken
				; 0 = DUMP
				; 1 = PDUMP

ACSAVE:	BLOCK	20		;[4110] Save the AC's

	PRGEND
	TITLE	ILL	ZERO INPUT WORD ON ILLEG. CHARACTERS 
SUBTTL	D. TODD /DRT/DMN/TWE/SWG	20-Aug-79



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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.

;FROM LIB40 VERSION V.032(323)
;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 FOROTS. AT THE END
;OF EACH FORMAT STATEMENT.

;THE CALLING SEQUENCE IS PUSHJ P,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 PUSHJ P,LEGAL

	SEARCH	MTHPRM,FORPRM
	EXTERNAL FOROP.
	SEGMENT	CODE

	HELLO	(ILL)
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

	MOVEI	T0,FO$ILL		;Function code in T0
	XMOVEI	T1,ILLEG		;FOROP. returns addr. here
	PUSHJ	P,FOROP.		;FOROP RETURNS ADDRESS
	SETOM	@ILLEG			;SET ILL CH FLAG
	GOODBY

	HELLO	(LEGAL)
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

	MOVEI	T0,FO$ILL		;T0:= function code
	XMOVEI	T1,ILLEG		;T1:= Address to return adr in
	PUSHJ	P,FOROP.		;GET ADDRESS OF ILLEGAL FLAG
	SETZM	@ILLEG			;CLEAR ILL CH FLAG
	GOODBY

	SEGMENT	DATA

ILLEG:	BLOCK	1

	PRGEND
	TITLE	SAVFMT	

;CODE TO ENCODE THE FORMAT IN AN ARRAY
;CALLS FOROP TO CALL %FMTSV IN FOROTS


	SEARCH	MTHPRM,FORPRM
	EXTERN	FOROP.
	SEGMENT	CODE

	HELLO	(SAVFMT)
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

	MOVEI	T0,FO$FSV	;Function code
				;No arg used
	PUSHJ	P,FOROP.
	GOODBY

	PRGEND
	TITLE	CLRFMT	

;CODE TO THROW AWAY THE ENCODING OF A FORMAT IN AN ARRAY
;CALLS FOROP TO CALL %FMTCL IN FOROTS


	SEARCH	MTHPRM,FORPRM
	EXTERN	FOROP.
	SEGMENT	CODE

	HELLO	(CLRFMT)
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

	MOVEI	T0,FO$FCL	;SETUP FOR FOROP
				;No arg used
	PUSHJ	P,FOROP.
	GOODBY

	PRGEND
	TITLE	LSNGET	

;FUNCTION WHICH RETURNS THE INTEGER VALUE OF THE LINE SEQUENCE NUMBER
;OF THE CURRENT LINE FOR MODE=LINED

	SEARCH	MTHPRM,FORPRM
	EXTERN	FOROP.
	SEGMENT	CODE

	HELLO	(LSNGET)
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

	MOVEI	T0,FO$GLN	;Return current line number
	MOVE	T1,@(L)		;GET CHANNEL #
	PUSHJ	P,FOROP.	;Returns line number in T0
	DMOVEM	T2,SAVE2	;SAVE 2 AC'S
	MOVEI	T3,5		;5 CHARS IN LSN
	SETZB	T1,T2		;CLEAR THE NUMBER
LSNLP:	ROTC	T0,7		;GET A CHAR
	JUMPE	T1,LSNENL	;SKIP NULLS
	CAIN	T1," "		;CONVERT SPACE TO "0"
	 MOVEI	T1,"0"
	CAIG	T1,"9"		;MAKE SURE IT'S LEGAL
	 CAIGE	T1,"0"
	  JRST	LSNILL		;NOT LEGAL
	IMULI	T2,^D10		;MUL PREVIOUS BY 10
	ADDI	T2,-"0"(T1)	;ACCUMULATE NUMBER
	SETZ	T1,		;AND CLEAR FOR NEW DIGIT
LSNENL:	SOJG	T3,LSNLP
	MOVE	T0,T2		;RETURN THE INTEGER
	DMOVE	T2,SAVE2	;Restore acs
	GOODBY

LSNILL:	MOVNI	T0,1		;-1=ILLEGAL CHAR IN LSN
	DMOVE	T2,SAVE2	;Restore acs
	GOODBY

	SEGMENT	DATA

SAVE2:	BLOCK	2		;FOR THE AC'S

	PRGEND
	TITLE	DATE	TODAY'S DATE 
SUBTTL	D. TODD /DRT/KK/DMN/SWG/AHM/CDM		5-Nov-82



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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.

;FROM LIB40 VERSION V.32(433)

;This subroutine puts today's date  into a numeric dimensioned  two-word
;array or a character variable.

;The date will be in the form:
;	"17-Aug-66 "

;The routine is called in the following manner:
;	MOVEI	L,ARGBLK
;	PUSHJ	P,DATE


	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(DATE)		;ENTRY TO DATE ROUTINE.
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4172]Is compatbility flagging on?
	 $FCALL	CFX		;[4172]Yes; display the compatibility message

	PUSH	P,T2		;[3206] Save ac's
	PUSH	P,T3		;[3206]

	; Put time into SVDT

IF10,<
	XMOVEI	T1,@0(L)	;[3025] Get address of 2 word array
	CALLI	T1,14		;Get the date from the monitor.
	IDIVI	T1,^D31		;Div. by 31 to obtain the day-1.
	ADDI	T2,1		;To obtain the day.
	IDIVI	T2,^D10		;Convert into two dec. digits.
	SKIPN	T2		;Is the day .LT. 10?
	MOVNI	T2,20		;Yes, output blank.
	MOVEI	T0,"0"(T2)	;Get first digit
	LSH	T0,7		;Make space
	ADDI	T0,"0"(T3)	;Add in 2nd digit
	IDIVI	T1,^D12		;To obtain the month
	EXCH	T1,T2		;Save year in T2
	MOVE	T1,TABLE(T1)	;Get month in T1
	LSHC	T0,3*7		;Left justify 0 & 1
	LSH	T0,1		;0 = ASCII /DD-MO/
				;1 = ASCII /N-/
	MOVEI	T2,^D64(T2)	;Get the year
	IDIVI	T2,^D10		;Convert into two dec. digits
	ADDI	T2,"0"		;Make ASCII
	ADDI	T3,"0"
	LSH	T2,2*7+1	;Shift to CHAR 3
	LSH	T3,7+1		;Shift to CHAR 4
	ADD	T3,T2		;Add in to T3
	ADD	T1,T3		;[3206] So low word is in T1
	ADDI	T1," "_1	;[3206] Make space for last character instead
				;[2020]  of NULL; this allows compare of
				;[2020]  literal to work, since FORTRAN pads
				;[2020]  the word with spaces.
	DMOVEM	T0,SVDT		;[3206] Store away date to return

>				;END IF10

IF20,<				;BEGIN -20 ONLY CODE

	HRROI	T1,SVDT		;Point to address for result
	SETO	T2,		;Ask for today's date
	MOVX	T3,OT%NTM	;Do not want time
	ODTIM%			;Do the JSYS
	MOVEI	T1," "_1	;[3206] Change NULL to SPACE
				;[2020]  This allows compare of literal to
				;[2020]  work, since FORTRAN pads the word
				;[2020]  with spaces.
	IORM	T1,SVDT+1	;[3206] Store away date to return

>				;END IF20

	; Return date to caller

	LDB	T0,[POINTR (0(L),ARGTYP)] ;[3206] Type of argument
	CAIE	T0,TP%CHR	;[3206] Is it character?
	 JRST	NOTCHR		;[3206] No

	; Argument is character.  Rather than worrying how to handle the
	; length of  the  character  descriptor, and  how  to  pad  with
	; blanks, let the move sludge handle this.

	MOVEI	T0,^D10		;[3206] Move 2 words of source
	MOVE	T1,[POINT 7,SVDT] ;[3206] Make a byte pointer for source
	DMOVE	T3,@0(L)	;[3206] Arg's BP and length
	EXCH	T3,T4		;[3206] Reverse order
	EXTEND	T0,[MOVSLJ
			" "]	;[3206] Put the date in the argument
	 JFCL			;[3206] NOP

	JRST	EXDATE		;[3206] Return

NOTCHR:	; Argument is numeric

	DMOVE	T0,SVDT		;[3206] Get date
	DMOVEM	T0,@0(L)	;[3206] Return date calculated above

EXDATE:	POP	P,T3		;[3206] Return ac's
	POP	P,T2		;[3206]
	POPJ	P,		;[3206] Return to caller

IF10,<
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-/
>

	SEGMENT	DATA

SVDT:	BLOCK	2		;Place to store results from monitor call

	PRGEND
	TITLE	TIM2GO	RETURN TIME LIMIT IN SECONDS 
	SUBTTL	H. P. WEISS/SWG		20-AUG-79




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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.

	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

IF10,<				;BEGIN TOPS-10 CODE
	HELLO	(TIM2GO)	;DEFINE ENTRY POINT
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

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

NEVER:	HRLOI	T0,377777	;SET LIMIT TO INFINITY
	JRST	DONE
>				;END IF10

IF20,<				;TOPS-20 CODE
	ENTRY TIM2GO
TIM2GO:
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

	PUSH	P,T1		;SAVE ACS
	PUSH	P,T2
	PUSH	P,T3
	SETO	T1,		;SET T1 TO -1 TO GET THIS JOB'S TIME
	MOVE	T2,[-3,,TBLK]	;SET UP POINTER TO BLOCK FOR RETURN VALS
	MOVX	T3,.JIRT	;START AT RUNTIME FIELD IN STRUCTURE
	GETJI%			;DO THE JSYS
	  JRST	NEVER
	SKIPN	T1,TBLK+2	;PICK UP TIME LIMIT
	  JRST	NEVER		;LIMIT IS 0 THEREFORE INFINITY
	MOVE	T2,TBLK		;PICK UP RUNTIME
	SUB	T1,T2		;GET DIFFERENCE BETWEEN RUNTIME AND TIME LIMIT
	FLTR	T0,T1		;AND FLOAT IT
	FDVRI	T0,(1000.0)	;CONVERT MILLISECONDS TO SECONDS
DONE:	POP	P,T3		;RESTORE ACS
	POP	P,T2
	POP	P,T1
	POPJ	P,

NEVER:	HRLOI	T0,377777
	JRST	DONE

	SEGMENT	DATA

TBLK:	BLOCK	3
>				;END IF20

	PRGEND			;END OF TIM2GO
	TITLE	TIME	TIME OF DAY
	SUBTTL	/KK/SWG/EDS/EGM/CDM

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.

;FROM LIB40 %2.(120)

;This subroutine returns the time of day in two single word arguments or
;a character variable.
;
;The first argument gets  the hour and minute,  and the optional  second
;argument gets the second and tenth of a second.

;The first argument is given in military time:
;	02:15	(for a.m. time)
;	14:15	(for p.m. time)
;
;The optional second argument is of the form:
;	37.4

;The routine is called in the following manner:
;	XMOVEI	L,ARGBLK
;	PUSHJ	P,TIME

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

;ON THE  -20,  TIME OBTAINS  THE  INTERNAL  TIME FROM  THE  MONITOR  AND
;	CONVERTS IT  INTO MILLISECONDS  SINCE  MIDNIGHT, DOES  THE  SAME
;	CONVERSION FROM THERE AS ON THE -10, BUT ALSO HAS TO CORRECT FOR
;	GREENWICH MEAN TIME WHICH IS THE  TIME THE -20 INTERNAL TIME  IS
;	STORED IN.


	SEARCH	MTHPRM,FORPRM

	SEGMENT	CODE

	SALL			;FOR HELLO MACRO - SEE BELOW
	HELLO	(TIME)
	FSRCH			;MUST FOLLOW HELLO MACRO TO AVOID OLD TIME JSYS
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4172]Is compatbility flagging on?
	 $FCALL	CFX		;[4172]Yes; display the compatibility message

	PUSH	P,T2		;[3206] Save ac's
	PUSH	P,T3		;[3206]
	PUSH	P,T4		;[3405]

	;Process the first argument.  Put it into TTIME.

IF10,<				;TOPS10-only code
	MSTIME	T1,		;Get time in millisecs from the monitor.
> ;[3405] End IF10

IF20,<				;[3405] TOP20-only code
	GTAD%			;[3405] Get internal GMT 
	HRLZ	T1,T1		;[3405] Put in left half
	LSH	T1,-1		;[3405] Divide by 2
	MUL	T1,[^D86400000]	;[3405] Compute ms since midnight in T1
> ;[3405] End IF20

	IDIVI	T1,^D60000	;[2103]Total mins. in 1, leftover msecs. in 2.
	MOVEM	T2,TEMP1	;Save the leftover ms
	IDIVI	T1,^D60		;Hours in 1, minutes in 2.
	MOVEM	T2,TEMP2	;[3405] Save minutes

;[3405] For TOPS20, which is based on Greenwich Mean Time, determine and
;[3405] adjust for local time zone correction factor and adjust if necessary for
;[3405] Daylight Savings.

;The general algorithm is similar to that in SECNDS.  If this must be
;changed, them SECNDS probably ought to be changed also.

IF20,<				;[3405] TOPS20-only code
	SETO	T2,		;[3405] -1 for current time
	SETZ	T4,		;[3405] 0 for local time
	ODCNV%			;[3405] Return T4/flags+zone,,secs since 00:00
	HLR	T3,T4		;[3405] Pick up left half 
	HRROI	T2,<^-<(IC%TMZ)>> ;[3405] Mask -1,,777700 to isolate zone
	TDZ	T3,T2		;[3405] Get zone bits (12-17) only
	TRNE	T3,40		;[3405] Time zone negative(-12 to +12)?
	 TDO	T3,T2		;[3405] Yes, propogate its sign bit
	TXNE	T4,IC%ADS	;[3405] Was Daylight Savings in effect?
	 SUBI	T3,1		;[3405] Yes, subtract one hour
	SUB	T1,T3		;[3405] Adjust hours by time zone factor
	SKIPGE	T1		;[3405] Did hours go negative?
	 ADDI	T1,^D24		;[3405] Yes, get it mod 24 hours
> ;[3405] End IF20

	MOVE	T0,[POINT 7,TTIME] ;[3206] Build a BP for answer
	MOVEM	T0,HLDBP	;Save it away
	JSP	T3,SUB1		;[3405] Go to subr. to set up hr.in T1 in ASCII
	MOVEI	T1,":"		;Set up ":".
	IDPB	T1,HLDBP	;Deposit ":" in the word.
	MOVE	T1,TEMP2	;Pick up the minutes.
	JSP	T3,SUB1		;Go to subr. to set up min. in ASCII.
				;[3405]

	; Return time in 1st argument

	LDB	T0,[POINTR (0(L),ARGTYP)] ;[3206] Get type of 1st argument
	CAIE	T0,TP%CHR	;[3206] Is it character?
	 JRST	NTCHR1		;[3206] no

	; Character argument.   Use move  string, so  we don't  have  to
	; worry about the length the user specified and how to pad  with
	; spaces.

	MOVEI	T0,5		;[3206] Length of 1 numeric word
	MOVE	T1,[POINT 7,TTIME] ;[3206] Address of source (time to return)
	DMOVE	T3,@0(L)	;[3206] Arg BP and length
	EXCH	T3,T4		;[3206] Exchange positions
	EXTEND	T0,[MOVSLJ
			" "]	;[3206] Put the time in the argument
	 JFCL			;[3206] NOP
	JRST	NEXT1		;[3206]

NTCHR1:	; Numeric argument

	MOVE	T0,TTIME	;[3206] Return time in
	MOVEM	T0,@0(L)	;[3206]  the first argument

NEXT1:	HLRZ	T3,-1(L)	;[3206] Number of arguments
	CAIE	T3,-2		;[3206] Are there two?
	 JRST	EXTIME		;[3206] Exit from here

				;[3405]

	; Process 2nd argument to return seconds

TIME02:
	MOVE	T0,[POINT 7,TTIME] ;[3206] Build BP for second argument
	MOVEM	T0,HLDBP	;Save it away
	MOVEI	T1," "		;PUT IN A BLANK AS THE FIRST
	IDPB	T1,HLDBP	;CHARACTER IN THE 2ND WORD.
	MOVE	T1,TEMP1	;PICK UP THE MSECONDS.
	IDIVI	T1,^D1000	;SECONDS IN 1, LEFTOVER MSECS. IN 2.
	MOVEM	T2,TEMP1	;SAVE THE MSECS.
	JSP	T3,SUB1		;GO TO SUBR. TO SET UP THE SECS. IN ASCII.
	MOVEI	T1,"."		;SET UP "."
	IDPB	T1,HLDBP	;IN THE WORD.
	MOVE	T2,TEMP1	;PICK UP THE MSECS.
	IDIVI	T2,^D100	;GET THE TENTH OF A SECOND.
	MOVEI	T2,"0"(2)	;MAKE IT ASCII
	IDPB	T2,HLDBP	;PUT IT IN THE SECOND WORD.

	LDB	T0,[POINTR (1(L),ARGTYP)] ;[3206] Type of 2nd argument
	CAIE	T0,TP%CHR	;[3206] Is it character?
	 JRST	NTCHR2		;[3206] No

	; 2nd argument is character.

	MOVEI	T0,5		;[3206] Length of source in characters
	MOVE	T1,[POINT 7,TTIME] ;[3206] Make a BP for
	DMOVE	T3,@1(L)	;[3206] 2nd arg's BP and length
	EXCH	T3,T4		;[3206] Exchange them
	EXTEND	T0,[MOVSLJ
			" "]	;[3206] Put the time in the argument
	 JFCL			;[3206] NOP
	JRST	EXTIME		;[3206] Exit from here

NTCHR2:	; 2nd argument is numeric.

	MOVE	T0,TTIME	;[3206] Return the seconds as the 2nd arg
	MOVEM	T0,@1(L)	;[3206]

EXTIME:	POP	P,T4		;[3405]
	POP	P,T3		;[3206] Restore ac's
	POP	P,T2		;[3206]
	POPJ	P,		;[3206] Return

SUB1:	IDIVI	T1,^D10		;SUBROUTINE ENTRY POINT.
	MOVEI	T1,"0"(T1)	;MAKE IT ASCII
	IDPB	T1,HLDBP	;DEPOSIT IT IN THE WORD.
	MOVEI	T2,"0"(T2)	;MAKE IT ASCII
	IDPB	T2,HLDBP	;DEPOSIT IT IN THE WORD.
	JRST	(T3)		;RETURN TO MAIN SEQUENCE.

	SEGMENT	DATA

TTIME:	BLOCK	1		;[3206] Temporary storage for Time
TEMP1:	BLOCK	1		;[3206]
TEMP2:	BLOCK	1		;[3206]
HLDBP:	BLOCK	1		;Saved byte ptr

	PRGEND
	TITLE	SLITE	SENSE LITE SETTING AND TESTING FUNCTION 
SUBTTL	D. TODD /DRT/TWE/SWG	 20-AUG-1979



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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.

;FROM LIB40 VERSION V.032(323)
;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:
;	MOVEI	L,ARGBLK
;	PUSHJ	P,SLITET
;IT TAKES TWO ARGUMENTS I AND 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:
;	MOVEI	L,ARGBLK
;	PUSHJ	P,SLITE
;SLITE TAKES ONE ARGUMENT 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	MTHPRM,FORPRM
	SEGMENT	CODE

	HELLO	(SLITE)			;ENTRY TO SLITE PROGRAM
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

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

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

	SEGMENT	DATA

LITES:	0

	PRGEND
	TITLE	SSWTCH	DATA SWITCH TESTING FUNCTION
SUBTTL	D. TODD /DRT/TWE/SWG/EDS	16-Mar-81



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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.

;FROM LIB40 VERSION V.032(323)
; DATA SWITCH TESTING PROGRAM
;THIS PROGRAM IS CALLED IN THE FOLLOWING MANNER:
;	MOVEI	L, ARGBLK
;	PUSHJ	P,SSWTCH
;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.
;ON TOPS-20, THE SWITCHES ARE NOT AVAILABLE, THEREFORE SSWTCH WILL
; ALWAYS RETURN AN ANSWER OF 1.  WE ARE KEEPING THE ROUTINE AROUND
;FOR COMPATIBILITY

	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(SSWTCH)	;ENTRY TO SSWTCH PROGRAM
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

IF10,<				;ONLY MAKES SENSE ON A -10
	MOVN	T1, @(L)	;PICK UP ARGUMENT
	MOVSI	T0, 400000	;PUT A ONE IN BIT 0
	ROT	T0,(T1)		; ROTATE BIT INTO POSITION
	MOVEI	T1,2		; SET ANSWER TO 2 FOR NOW
	MOVEM	T1, @1(L)	;...
	SWITCH	T1,		;GET DATA SWITCHES FROM MONITOR
	MOVEI	T1,2		; SET ANSWER TO 2 FOR NOW
	SOS	@1(L)		; NO, CHANGE ANSWER TO ONE
>				;END IF10

IF20,<
	MOVEI	T1,1		;ALWAYS SAY NO
	MOVEM	T1,@1(L)	;STORE IN USER'S VARIABLE
>				;END IF20
	GOODBY	(2)	;RETURN

	PRGEND
	TITLE	ERRSET	SET APR TRAP PARAMETERS 
	SUBTTL	CHRIS SMITH/CKS/PLB

;Call:
;	CALL ERRSET (N)
;or	CALL ERRSET (N, I)
;or 	CALL ERRSET (N, I, SUBR)
;
;where	N = max number of error messages to type
;
;	I = which error this call applies to.  One of:
;	       -1 any of the following
;		0 integer overflow
;		1 integer divide check
;		2 input integer overflow
;		3 input floating overflow
;		4 floating overflow
;		5 floating divide check
;		6 floating underflow
;		7 input floating underflow
;	        8 library routine error	
;		9 output field width too small
;		21 FORLIB warnings
;		22 non-standard usage warnings
;
;	    If I is not specified, -1 is assumed
;
;	SUBR = routine to call on the trap
;
;	       The effect is as if
;		   CALL SUBR (I, IPC, N2, ITYPE, UNFIXED, FIXED)
;	       were placed in the program just after the instruction causing
;	       the trap.
;			I = error number of trap, same as above
;			IPC = PC of trap instruction
;			  (or if error number= 9, IPC = PC of FOROTS call)
;			N2 = 2nd error number (reserved for DEC)
;			ITYPE = data type of value
;			UNFIXED = value returned by the processor
;			FIXED =  value after fixup by MTHTRP
;	       If SUBR is not specified, no routine is called on the APR trap.
	SEARCH	MTHPRM,FORPRM
	EXTERN	MTHOP.
	EXTERN	ABORT.		;[3322]
	SEGMENT	CODE

	HELLO	(ERRSET)
;
; [4172] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4172]Is any compatbility flagging on?
	 $FCALL	CFX		;[4172]Yes; display the compatibility message

	MOVEI	T0,ML$APR	;T0:= function code
	XMOVEI	T1,APRCT	;Read apr table addresses to here
	PUSHJ	P,MTHOP.	;READ THEM
	MOVEM	T0,ERRSZ	;SAVE SIZE OF TABLE

	XMOVEI	T1,.		;[4012] GET LOCAL SECTION
	TLNE	T1,-1		;[4012] IS SECTION NUMBER ZERO?
	 SKIPA	T1,[<T2>B5]	;[4012] NO, USE "EFIW T2,"
	  MOVSI	T1,(IFIW (T2))	;[4012] ELSE, MAKE IFIW INDEXED BY T2
	IORM	T1,APRCT	;[4012] POINTING TO ERROR COUNT TABLE
	IORM	T1,APRLM	;[4012] AND ERROR MESSAGE LIMIT TABLE
	IORM	T1,APRSB	;[4012] AND SUBROUTINE ADDRESS TABLE

	HLLZ	T4,-1(L)	;[4012] GET ARG COUNT
	SETO	T2,		;DEFAULT IS ALL APR ERRORS
	SETZ	T3,		;DEFAULT SUBROUTINE IS NONE

	MOVE	T1,@(L)		;GET ERR MESSAGE LIMIT
	AOBJP	T4,ERSET1	;[4012] IF OUT OF ARGS, GO STORE THEM
	MOVE	T2,@1(L)	;[4012] GET ERROR NUMBER
	AOBJP	T4,ERSET1	;[4012] IF OUT OF ARGS, GO STORE THEM
	XMOVEI	T3,@2(L)	;[4012] GET ROUTINE TO CALL
	SKIPN	(T3)		;[3322] VALID ROUTINE CALL?
	 $FCALL	MXD,ABORT.	;[3322] MISSING EXTERNAL DECLARATION. ABORT

ERSET1:	CAML	T2,ERRSZ	;REASONABLE ERROR NUMBER?
	 $FCALL	NOR,EPOPJ	;NUMBER OUT OF RANGE

	MOVEI	T0,1		;[4012] DEFAULT IS DO JUST ONE ITEM
	JUMPGE	T2,ERSETL	;IF INDIVIDUAL ERROR, GO SET IT
	MOVE	T0,ERRSZ	;[4012] IF ALL ERRORS, LOOP MAXIMUM TIMES
	SETZ	T2,		;[4012] STARTING AT ITEM ZERO
ERSETL:	MOVE	T4,T1		;GET ERR MESSAGE LIMIT
	ADD	T4,@APRCT	;ADD TO NUMBER THAT ALREADY HAPPENED
	MOVEM	T4,@APRLM	;STORE ERR MESSAGE LIMIT
	MOVEM	T3,@APRSB	;STORE SUBROUTINE ADDRESS OR 0
	AOJ	T2,		;[4012] BUMP INDEX AC
	SOJG	T0,ERSETL	;[4012] SET ALL ERRORS IF THAT'S WHAT HE WANTS

EPOPJ:	POPJ	P,		;DONE

	SEGMENT	DATA

APRCT:	BLOCK	1		;ADDRESS OF APR ERROR COUNTS
APRLM:	BLOCK	1		;ADDRESS OF APR ERROR LIMITS
APRSB:	BLOCK	1		;ADDRESS OF APR ERROR SUBROUTINES
ERRSZ:	BLOCK	1		;SIZE OF TABLES

	PRGEND
	TITLE	MTHOP.
	SEARCH	MTHPRM,FORPRM
	ENTRY	MTHOP.
	EXTERN	FOROP.

MTHOP.==<FOROP.+0>

	PRGEND
	TITLE	ERRSNS	READ LAST IO ERROR 
	SUBTTL	CHRIS SMITH/CKS

;Call:
;	CALL ERRSNS (I,J)
;or	CALL ERRSNS (I,J,MSG)
;
;I and J are returned with the First number and the Second number
;for the last error
;
;MSG, if present, is a 16-word array returned holding the text
;of the message for the last error

	SEARCH	MTHPRM,FORPRM
	FSRCH
	EXTERN	FOROP.
	SEGMENT	CODE

	HELLO	(ERRSNS)
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4172]Is compatbility flagging on?
	 $FCALL	CFX		;[4172]Yes; display the compatibility message

	MOVEI	T0,FO$ERR	;Read error numbers
	XMOVEI	T1,ERRNUM	;To block beginning here
	PUSHJ	P,FOROP.	;READ THEM

	HLRE	T1,-1(L)	;GET ARG COUNT
	MOVN	T1,T1		;MAKE POSITIVE
	MOVE	T2,ERRNUM	;STORE ERR NUMBERS
	CAIL	T1,1
	  HLRZM	T2,@0(L)
	CAIL	T1,2
	 JRST	[HRRZ T2,T2	;Get RH only
		CAIN T2,-1	;-1?
		  SETO T2,	;Yes, make full word
		MOVEM T2,@1(L)	;Store 2nd ERR number
		JRST .+1]

	CAIGE	T1,3		;STRING SPECIFIED?
	  POPJ	P,		;NO, DONE

	MOVE	T1,ERRMSA	;GET MSG POINTER
	LDB	T2,[POINTR (2(L),ARGTYP)] ;GET ARG TYPE
	CAIE	T2,TP%CHR	;CHARACTER?
	 JRST	ERRNC		;NO
	DMOVE	T2,@2(L)	;YES. GET PNTR/COUNT
	JRST	ERRLP		;AND JOIN COMMON CODE
ERRNC:	XMOVEI	T2,@2(L)	;GET STRING ADDRESS
	$BLDBP	T2		;BUILD A BYTE POINTER TO IT
	MOVEI	T3,^D80		;COUNT 80 CHARS
ERRLP:	ILDB	T4,T1		;GET CHAR
	JUMPE	T4,ERREND	;NULL IS END
	IDPB	T4,T2		;STORE CHAR
	SOJG	T3,ERRLP

ERREND:	JUMPLE	T3,ERRRET	;IF 80 CHARS, DONE
	MOVEI	T1," "		;PAD WITH TRAILING SPACES
	IDPB	T1,T2
	SOJG	T3,.-1

ERRRET:	POPJ	P,		;DONE

	SEGMENT	DATA

ERRNUM:	BLOCK	1		;ERR NUMBERS
ERRMSA:	BLOCK	1		;ERR MSG ADDRESS

	PRGEND
	TITLE	DIVERT	DIVERT ERROR MESSAGE OUTPUT 
	SUBTTL	CHRIS SMITH/CKS

;Call:
;
;	CALL DIVERT (U)
;where U is the unit number of an open unit, sends error messages
;to U instead of to the TTY.  If U is -1, the diversion is ended.
;
;	CALL CHKDIV (U)
;sets U to the unit number where errors are diverted, or -1 if none

	SEARCH	MTHPRM,FORPRM
	EXTERN	FOROP.
	SEGMENT	CODE

	HELLO	(CLRDIV)
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

	SETO	T1,		;Same as saying "UNIT=-1"
	JRST	DIV01		; (Should always return status 0)

	HELLO	(DIVERT)
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

	MOVE	T1,@(L)		;Get unit number
DIV01:	MOVEI	T0,FO$DIV	;Do diversion
	PUSHJ	P,FOROP.

;Status is returned in T1.
;T1:	= 0 means ok.
;	= 1 means ?Illegal unit number.
;	= 2 means ?unit not open
;	= 3 means ?Not open for FORMATTED IO
;	= 4 means ?Can't write to unit.

	XMOVEI	T0,DIVRT(T1)	;GET ADDR TO GO
	MOVE	T1,@(L)		;GET UNIT NUMBER
	PJRST	@T0		;GO THERE

;Indexed by status value

DIVRT:	JRST	DIVRET		;(0) OK, return
	$FCALL	IDU,DIVRET	;(1) Illegal unit
	$FCALL	UNO,DIVRET	;(2) Unit not open
	$FCALL	NOF,DIVRET	;(3) Not open for FORMATTED IO
	$FCALL	CWU,DIVRET	;(4) Can't write to unit


DIVRET:	POPJ	P,		;DONE

	HELLO	(CHKDIV)
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

	MOVEI	T0,FO$GDV	;Get divert unit
	PUSHJ	P,FOROP.
	MOVEM	T1,@(L)		;Return unit number
	POPJ	P,		;Done

	PRGEND
	TITLE	OVERFL	RETURN OVERFLOW INFO
	SUBTTL	CHRIS SMITH/CKS/EGM

;Call:
;
;	CALL OVERFL (IANS)
;
;If any overflow, underflow, or divide check has occurred since the last
;call to OVERFL, IANS is set to 1 and T0 is set to -1; if not, IANS is
;set to 2 and T0 is set to 0.
;
; Note to maintainers: The "magic" number 8 that appears in this routine
;is because APR counts 0 thru 7 are various arithmetic traps.
;The entry number is determined by 3 PC flag bits in combination.

	SEARCH	MTHPRM,FORPRM
	EXTERN	FOROP.
	SEGMENT	CODE

	HELLO	(OVERFL)
;
; [4100] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4100]Is any compatbility flagging on?
	 $FCALL	CFX		;[4100]Yes; display the compatibility message

	PUSH	P,T2		;SAVE
	PUSH	P,T3		; REGS
	MOVEI	T0,FO$APR	;Read APR table addresses
	XMOVEI	T1,APRCT	;Into here
	PUSHJ	P,FOROP.	;READ THEM
	XMOVEI	T1,.		;[4030] GET LOCAL SECTION
	TLNE	T1,-1		;[4030] IS SECTION NUMBER ZERO?
	 SKIPA	T1,[<T1>B5]	;[4030] NO, USE "EFIW T1,"
	  MOVSI	T1,(IFIW (T1))	;MAKE INDIRECT WORD INDEXED BY T1
	IORM	T1,APRCT	;[4030] POINTING TO COUNT TABLE
	MOVEI	T1,8-1		;[4030] MAKE TABLE SOJG COUNTR
	MOVEI	T2,2		;INIT ANSWER TO 2 (NO OVERFLOWS)
OVLP:	MOVE	T3,@APRCT	;GET CURRENT COUNT
	CAMLE	T3,OLDCT(T1)	;[2077][4007] GREATER THAN OLD COUNT?
	  MOVEI	T2,1		;YES, SET ANSWER TO 1 (OVERFLOW OCCURRED)
	MOVEM	T3,OLDCT(T1)	;[4030] STORE NEW COUNT
	SOJG	T1,OVLP		;[4030] LOOK THROUGH WHOLE TABLE
	MOVEM	T2,@0(L)	;STORE ANSWER FOR CALLER

	SETZM	T0		;ASSUME NO OVERFLOW, T0=FALSE
	CAIN	T2,1		;WAS THERE?
	SETOM	T0		; YES, SET T0=TRUE
	POP	P,T3		;RESTORE
	POP	P,T2		; REGS
	POPJ	P,		;DONE

	SEGMENT	DATA

OLDCT:	BLOCK	8		;PREVIOUS APR COUNTS
APRCT:	BLOCK	1		;ADDRESS OF CURRENT APR COUNTS
APRLM:	BLOCK	1		;ADDRESS OF LIMITS
APRSB:	BLOCK	1		;ADDRESS OF SUBROUTINES

	PRGEND
	TITLE	TRACE	DUMMY ROUTINE DEFINES 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) DIGITAL EQUIPMENT CORPORATION 1973, 1985
;ALL RIGHTS RESERVED.

	SEARCH	MTHPRM,FORPRM
	NOSYM
	ENTRY	TRACE		;HELLO MACRO CAN NOT BE USED
				;SIXBIT NAME DEFINED IN TRACE (FORERR)
	HELLO	(TRACE)
;
; [4100] Check for compatibility flagging.
;
	 SKIPE	[FLGON.##]	;Is any compatbility flagging on ?
	 $FCALL	CFX 		;Yes; display the compatibility message
	PJRST	TRACE.##	;Call the correct (dotted) name

	PRGEND
	TITLE	INIOVL	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) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.

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	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) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.

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	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) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.

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	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) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.

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	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) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.

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	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) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.

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	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) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.

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	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) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.

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
	TITLE	FDDT	- DUMMY FORDDT 
	SUBTTL	D. M. NIXON/DMN/CKS/AHM	21-Apr-83


	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	DATA		;[3311] Put this in the lowseg because
				;[3124]  FDDT. is impure

IF20,<
  DEFINE OUTSTR (X) <
	PUSH	P,T1		;[3124] Save T1
	HRROI	T1,X
	PSOUT%
	POP	P,T1		;[3124] Restore T1
  >
>

	HELLO	(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
	TITLE	EXIT	
	SEARCH	MTHPRM,FORPRM


	ENTRY EXIT
	EXTERN	EXIT.
	HELLO (EXIT)
;
; [4100] Check for compatibility flagging
;
	SKIPE	[FLG77.##]	;Is ANSI compatbility flagging on ?
	 $FCALL	CFR 		;Yes; display the compatibility message
	PJRST	EXIT.##		;Call the correct (dotted) name

	PRGEND
	TITLE	EXIT1

;ENTRY POINT TO JUST CLOSE FILES

	ENTRY	EXIT1
	EXTERN	EXIT1.

EXIT1==<EXIT1.+0>

	PRGEND
	TITLE	QUIETX
	SEARCH	MTHPRM,FORPRM

;[3407] DOES A QUIET EXIT FROM FOROTS (NO CPU TIME MESSAGE, NO ERROR
;[3407] SUMMARIES, IF ANY)

	EXTERN	FOROP.

	SEGMENT	CODE

	HELLO	(QUIETX)	;[4121] User callable subroutine
	MOVEI	T0,FO$QIT	;QUIET EXIT FUNCTION
	PJRST	FOROP.

	PRGEND
	TITLE	PROSB.	Substring bounds checking routine
	SUBTTL	CHRIS SMITH/CKS		8-Jun-82
				;[3132] New 

;Routine to perform substring bounds checking.

;The compiler transforms the substring reference
;
;	VAR(LB:UB)
;
;into
;
;	VAR(LB: PROSB.(VAR,LB-1,UB,ISN,'VAR') )
;
;where PROSB. checks the validity of LB and UB, then returns UB.  If the bounds
;are invalid, a warning message is typed.  (LB-1 is used instead of LB because
;LB-1 is conveniently available in the compiler's internal representation of
;substrings.)

;The conditions for valid substring bounds are
;
;	LB .LE. UB
;	LB .GE. 1
;	UB .LE. LEN(VAR)
;
;If a bound is found to be out of range, a warning message is typed.  No
;attempt at correction is made - the program will get the same results as if
;/DEBUG:BOUNDS were not specified, except for the message.

	SEARCH	MTHPRM,FORPRM
	SEGMENT	CODE
	SALL


;Argument block offsets

VAR==0				;Variable we're taking substring of
LB==1				;Lower bound - 1
UB==2				;Upper bound
ISN==3				;Statement number of substring reference
VARNAME==4			;Sixbit variable name for error message
	HELLO	(PROSB.)

	PUSH	P,T2		;SAVE ACS
	PUSH	P,T3

	XMOVEI	T1,@VAR(L)	;GET POINTER TO DESCRIPTOR
	MOVE	T1,1(T1)	;GET CHARACTER VARIABLE LENGTH

	MOVE	T2,@LB(L)	;GET LOWER BOUND - 1
	MOVE	T3,@UB(L)	;GET UPPER BOUND

	JUMPL	T2,SERR		;CHECK LB .GE. 1 (LB-1 .GE. 0)
	CAML	T2,T3		;MUST HAVE LB .LE. UB (LB-1 .LT. UB)
	  JRST	SERR		;NO, ERROR
	CAMLE	T3,T1		;CHECK UB .LE. LENGTH
	  JRST	SERR		;NO, ERROR

;Return	UB.

RET:	MOVE	T0,@UB(L)	;RETURN UB FOR SUBSTRING CALCULATION

	POP	P,T3		;RESTORE ACS
	POP	P,T2
	POPJ	P,		;RETURN


;Here on error, type message and return normally.

SERR:	PUSH	P,T4		;SAVE SOME MORE REGISTERS FOR ERR MESSAGE
	PUSH	P,T5

	MOVE	T4,@ISN(L)	;GET ISN
	MOVE	T5,@VARNAME(L)	;GET VARIABLE NAME
	ADDI	T2,1		;CONVERT LB-1 TO LB

	$FCALL	SSE		;"%Substring range error VAR(LB:UB)
				;  on line ISN at LABEL+OFFSET"

	POP	P,T5		;RESTORE REGISTERS
	POP	P,T4
	JRST	RET		;GO RETURN UB

	PRGEND

	TITLE	PA1050
	SEARCH	MTHPRM,FORPRM

	EXTERN	FOROP.

	SEGMENT	CODE

	HELLO	(PA1050)
	MOVEI	T0,FO$PAT	;ALLOW AND GET PA1050
	PJRST	FOROP.

	PRGEND

	TITLE	FFUNIT
	SEARCH	MTHPRM,FORPRM

	EXTERN	FOROP.

	SEGMENT	CODE

	HELLO	(FFUNIT)
;
; [4130] Check for compatibility flagging.
;
	SKIPE	[FLGON.##]	;[4130]Is any compatbility flagging on?
	 $FCALL	CFX		;[4130]Yes; display the compatibility message

	MOVEI	T0,FO$GFU	;GET # OF FIRST FREE UNIT
	PUSHJ	P,FOROP.
	MOVEM	T0,@(L)		;SAVE IN USER'S VARIABLE
	POPJ	P,

	PRGEND			;[3142] End of the routine

	TITLE	TOPMEM	ALLOCATE MEMORY FROM TOP DOWN
	SUBTTL	TGS	20-Oct-83
	SEARCH	MTHPRM,FORPRM		;[3362]

	EXTERN	FOROP.,ABORT.	;[3362]
	SEGMENT	CODE		;[3362]

;[3362] SET ENDP AND STARTP TO DESIRED PAGE NUMBER TO FORCE MEMORY
;[3362] ALLOCATION FROM THE TOP DOWN. NO PREALLOCATION FOR SORT'S PAGES
;[3362] IS DONE.
;[3362] USER CALL:	
;[3362]		CALL TOPMEM (<top page number>)

	HELLO	(TOPMEM)	;[3362]
	MOVE	T1,@0(L)	;[3362] GET PAGE NUMBER ARGUMENT
	CAIG	T1,777		;[3362] WITHIN RANGE?
	CAIG	T1,0		;[3362] 1-777?
	 $FCALL	IPN,ABORT.	;[3362] NO, DIE.
	MOVEI	T0,FO$NOS	;[3362] FOROP FUNCTION TO SET ENDP/STARTP
	PUSHJ	P,FOROP.	;[3362] DO IT.
	GOODBY			;[3362] RETURN

	PRGEND			;[3362]

	TITLE	SRTINI	ALLOCATE MEMORY TOPDOWN AND PREALLOCATE SORT
	SUBTTLE	TGS 20-Oct-83
	SEARCH	MTHPRM,FORPRM		;[3362]

	EXTERN	FOROP.,ABORT.,%PASRT	;[3362]
	SEGMENT	CODE		;[3362]

;[3362] SET ENDP AND STARTP TO DESIRED PAGE NUMBER TO FORCE MEMORY
;[3362] ALLOCATION FROM THE TOP DOWN. ALSO PREALLOCATE PAGES FOR SORT.
;[3362] FOROP. CALL FO$SRT SETS A FLAG SO FORSRT WON'T ALSO TRY TO PREALLOCATE.
;[3362] CALLING THIS ROUTINE SHOULD BE UNNECESSARY ON EXTENDED MACHINES SINCE
;[3362] SORT WILL BE IN ITS OWN SECTION.
;[3362] USER CALL:
;[3362]		CALL SRTINI (<top page number>)

	HELLO	(SRTINI)	;[3362]
	MOVE	T1,@0(L)	;[3362] GET PAGE NUMBER ARGUMENT
	CAIG	T1,777		;[3362] WITHIN RANGE?
	CAIG	T1,0		;[3362] 1-777?
	 $FCALL	IPN,ABORT.	;[3362] NO, DIE.
	MOVEI	T0,FO$SRT	;[3362] FOROP. FUNCTION CODE TO SET ENDP/STARTP
	PUSHJ	P,FOROP.	;[3362] AND PREALLOCATE SORT PAGES.
	SETOM	%PASRT		;[3362] ASSUME SUCCESS.
	CAME	T0,[-1]		;[3362] DID WE PREALLOCATE?
	 POPJ	P,		;[3362] YES, RETURN.
	SETZM	%PASRT		;[3362] NO. CLEAR FLAG,
	$FCALL	CPP		;[3362] WARN AND RETURN.	
	POPJ	P,		;[3362] RETURN

	PRGEND			;[3362]

	TITLE	FORMSL - Fortran Library error message macros
	SUBTTL	Jon Campbell/JLC	28-May-82

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1982, 1985
;ALL RIGHTS RESERVED.

;++
; FUNCTIONAL DESCRIPTION:
;
;	Defines the text of error messages in the fortran library (FORLIB).
;	Uses the Macro $FERR to generate error messages in propper format.
;
;	Arguments to $FERR:
;	$FERR(	1st - Warning/error character (? or %),
;		2nd - Unique three character pnuemonic for error
;			message.  A F.<3 character> symbol is created,
;		3rd - Error class number.  (21 for Forlib error messages.)
;		4th - Unique error number for message. (Not currently used.)  
;		5th - Message to appear
;
;	For more information the error message macros see FORPRM & MTHPRM.
;
; CALLING SEQUENCE:
;
;	Called from FORLIB code with a $FCALL macro (which generates):
;
;		JRST	F.nnn	;Where nnn is the 3 letter error code.
;
;	For more information on the $FERR macro see FORPRM.
;
; INPUT PARAMETERS:
;
;	None
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; SIDE EFFECTS:
;
;	None
;
;--
	SEARCH	MTHPRM, FORPRM
	SEGMENT	CODE
	RADIX	10
	SALL

	$FERR (%,CFF,33,322,$I Intrinsic routine $N invoked incompatibly,<[VAXIDX]>);[4100]
IF20,<	$FERR (%,CFR,33,323,$I FORTRAN-20 supplied routine $N invoked,<[ANSIDX]>)
	$FERR (%,CFX,33,323,$I FORTRAN-20 supplied routine $N invoked,<[ANSIDX+VAXIDX]>) >;END IF20
IF10,<	$FERR (%,CFR,33,323,$I FORTRAN-10 supplied routine $N invoked,<[ANSIDX]>)
	$FERR (%,CFX,33,323,$I FORTRAN-10 supplied routine $N invoked,<[ANSIDX+VAXIDX]>) >;END IF10
	$FERR (%,CFO,33,326,$I Overlap of character assignments,<[VAXIDX]>)
	$FERR (?,IOE,98,0,$J) ;General-purpose I/O error
	$FERR (%,NOR,-1,0,ERRSET: error number out of range - ignored)
;[3205] 21,102 was VDM
;[3205] 21,103 was ICF
	$FERR (?,IDU,21,104,DIVERT: illegal to divert to unit $D,<T1>)
	$FERR (?,UNO,21,105,DIVERT: unit $D is not open,<T1>)
	$FERR (?,NOF,21,106,DIVERT: unit $D is not open for FORMATTED I/O,<T1>)
	$FERR (?,CWU,21,107,DIVERT: Can't write to unit $D,<T1>)
	$FERR (?,CLE,21,108,<Concatenation result larger than expected>)
	$FERR (?,ICE,21,109,<Illegal length character expression>)
	$FERR (?,NCS,21,110,No character stack allocated - compiler error)
;[4101] 21,111 was NCA
	$FERR (?,AQS,21,112,<First argument to SORT must be a quoted string>) ;[3205]
	$FERR (%,SSE,23,113,<Substring range error $S($D:$D)
	on line $D>,<T5,T2,T3,T4>)
	$FERR (%,SRE,23,114,<Subscript range error - subscript $D of array $S = $D
	on line $D>,<T1,T2,P2,T3>)

	$FERR (?,TMA,21,115,<Too many arguments in call to SORT>) ;[3205]
	$FERR (?,CGP,21,116,<Can't get pages 600:677 for SORT>)	;[3205]
	$FERR (?,MXD,-1,0,<Missing EXTERNAL declaration in CALL to $N>);[3322]
	$FERR (%,WNA,21,0,<Wrong number of arguments in call to $N>)	;[4207]
	$FERR (%,NFL,21,0,<Argument to SECNDS not floating point>)	;[4207]

IF10,<
	$FERR (?,CRP,21,117,<Can't return pages 600:677 after call to SORT>)
> ; End of IF10

IF20,<
	$FERR (?,NSS,21,118,<No free section available for SORT>) ;[3205]
	$FERR (?,CFS,21,119,<Can't find SYS:SORT.EXE - $J>) ;[3205]
	$FERR (?,CGS,21,120,<Can't get SYS:SORT.EXE - $J>) ;[3205]
> ; End of IF20

	$FERR (%,CPP,21,121,<Can't preallocate pages 600:677 for SORT>)	;[3362]
	$FERR (?,IPN,21,122,Illegal page number $O,<T1>) ;[3362]
	$FERR (?,SNH,-1,0,<Internal FOROTS error>)	;[3205]
IF20,<							;[3205]
	$FERR (?,IJE,-1,0,<Internal FOROTS JSYS error - $J>) ;[3205]

	$FERR (%,DMA,21,126,<$N: Must give lower and upper bounds to dump in non-zero section>)	;[4110]
> ; End of IF20						;[3205]

	$FERR (?,CCS,21,123,<Not enough memory for creating character stack>)	;[4101]
	$FERR (?,ECS,21,124,<Not enough memory for expanding character stack>)	;[4101]
	$FERR (?,ALZ,21,125,<$N: Argument less than or equal to zero>)	;[4101]

	PRGEND
	TITLE	IIABS -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IIABS
EXTERN	IABS.
IIABS=<IABS.+0>
PRGEND
	TITLE	JIABS -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JIABS
EXTERN	IABS.
JIABS=<IABS.+0>
PRGEND
	TITLE	IINT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IINT
EXTERN	INT.
IINT=<INT.+0>
PRGEND
	TITLE	JINT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JINT
EXTERN	INT.
JINT=<INT.+0>
PRGEND
	TITLE	IIDINT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IIDINT
EXTERN	IDINT.
IIDINT=<IDINT.+0>
PRGEND
	TITLE	JIDINT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JIDINT
EXTERN	IDINT.
JIDINT=<IDINT.+0>
PRGEND
	TITLE	ININT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	ININT
EXTERN	NINT.
ININT=<NINT.+0>
PRGEND
	TITLE	JNINT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JNINT
EXTERN	NINT.
JNINT=<NINT.+0>
PRGEND
	TITLE	IIDNNT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IIDNNT
EXTERN	IDNIN.
IIDNNT=<IDNIN.+0>
PRGEND
	TITLE	JIDNNT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JIDNNT
EXTERN	IDNIN.
JIDNNT=<IDNIN.+0>
PRGEND
	TITLE	FLOATI -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	FLOATI
EXTERN	FLOAT.
FLOATI=<FLOAT.+0>
PRGEND
	TITLE	FLOATJ -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	FLOATJ
EXTERN	FLOAT.
FLOATJ=<FLOAT.+0>
PRGEND
	TITLE	IIFIX -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IIFIX
EXTERN	IFIX.
IIFIX=<IFIX.+0>
PRGEND
	TITLE	JIFIX -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JIFIX
EXTERN	IFIX.
JIFIX=<IFIX.+0>
PRGEND
	TITLE	DFLOTI -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	DFLOTI
EXTERN	DFLOT.
DFLOTI=<DFLOT.+0>
PRGEND
	TITLE	DFLOTJ -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	DFLOTJ
EXTERN	DFLOT.
DFLOTJ=<DFLOT.+0>
PRGEND
	TITLE	IMAX0 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IMAX0
EXTERN	MAX0.
IMAX0=<MAX0.+0>
PRGEND
	TITLE	JMAX0 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JMAX0
EXTERN	MAX0.
JMAX0=<MAX0.+0>
PRGEND
	TITLE	IMAX1 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IMAX1
EXTERN	MAX1.
IMAX1=<MAX1.+0>
PRGEND
	TITLE	JMAX1 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JMAX1
EXTERN	MAX1.
JMAX1=<MAX1.+0>
PRGEND
	TITLE	AIMAX0 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	AIMAX0
EXTERN	AMAX0.
AIMAX0=<AMAX0.+0>
PRGEND
	TITLE	AJMAX0 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	AJMAX0
EXTERN	AMAX0.
AJMAX0=<AMAX0.+0>
PRGEND
	TITLE	IMIN0 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IMIN0
EXTERN	MIN0.
IMIN0=<MIN0.+0>
PRGEND
	TITLE	JMIN0 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JMIN0
EXTERN	MIN0.
JMIN0=<MIN0.+0>
PRGEND
	TITLE	IMIN1 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IMIN1
EXTERN	MIN1.
IMIN1=<MIN1.+0>
PRGEND
	TITLE	JMIN1 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JMIN1
EXTERN	MIN1.
JMIN1=<MIN1.+0>
PRGEND
	TITLE	AIMIN0 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	AIMIN0
EXTERN	AMIN0.
AIMIN0=<AMIN0.+0>
PRGEND
	TITLE	AJMIN0 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	AJMIN0
EXTERN	AMIN0.
AJMIN0=<AMIN0.+0>
PRGEND
	TITLE	IIDIM -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IIDIM
EXTERN	IDIM.
IIDIM=<IDIM.+0>
PRGEND
	TITLE	JIDIM -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JIDIM
EXTERN	IDIM.
JIDIM=<IDIM.+0>
PRGEND
	TITLE	IMOD -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IMOD
EXTERN	MOD.
IMOD=<MOD.+0>
PRGEND
	TITLE	JMOD -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JMOD
EXTERN	MOD.
JMOD=<MOD.+0>
PRGEND
	TITLE	IISIGN -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IISIGN
EXTERN	ISIGN.
IISIGN=<ISIGN.+0>
PRGEND
	TITLE	JISIGN -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JISIGN
EXTERN	ISIGN.
JISIGN=<ISIGN.+0>
PRGEND
	TITLE	BITEST -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	BITEST
EXTERN	BTEST.
BITEST=<BTEST.+0>
PRGEND
	TITLE	BJTEST -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	BJTEST
EXTERN	BTEST.
BJTEST=<BTEST.+0>
PRGEND
	TITLE	IIAND -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IIAND
EXTERN	IAND.
IIAND=<IAND.+0>
PRGEND
	TITLE	JIAND -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JIAND
EXTERN	IAND.
JIAND=<IAND.+0>
PRGEND
	TITLE	IIBCLR -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IIBCLR
EXTERN	IBCLR.
IIBCLR=<IBCLR.+0>
PRGEND
	TITLE	JIBCLR -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JIBCLR
EXTERN	IBCLR.
JIBCLR=<IBCLR.+0>
PRGEND
	TITLE	IIBITS -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IIBITS
EXTERN	IBITS.
IIBITS=<IBITS.+0>
PRGEND
	TITLE	JIBITS -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JIBITS
EXTERN	IBITS.
JIBITS=<IBITS.+0>
PRGEND
	TITLE	IIBSET -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IIBSET
EXTERN	IBSET.
IIBSET=<IBSET.+0>
PRGEND
	TITLE	JIBSET -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JIBSET
EXTERN	IBSET.
JIBSET=<IBSET.+0>
PRGEND
	TITLE	IIEOR -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IIEOR
EXTERN	IEOR.
IIEOR=<IEOR.+0>
PRGEND
	TITLE	JIEOR -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JIEOR
EXTERN	IEOR.
JIEOR=<IEOR.+0>
PRGEND
	TITLE	IIOR -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IIOR
EXTERN	IOR.
IIOR=<IOR.+0>
PRGEND
	TITLE	JIOR -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JIOR
EXTERN	IOR.
JIOR=<IOR.+0>
PRGEND
	TITLE	IISHFT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IISHFT
EXTERN	ISHFT.
IISHFT=<ISHFT.+0>
PRGEND
	TITLE	JISHFT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JISHFT
EXTERN	ISHFT.
JISHFT=<ISHFT.+0>
PRGEND
	TITLE	INOT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	INOT
EXTERN	NOT.
INOT=<NOT.+0>
PRGEND
	TITLE	JNOT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
	SUBTTL	R. Meyers/RVM	12-Sep-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	JNOT
EXTERN	NOT.
JNOT=<NOT.+0>
PRGEND
	TITLE	BTEST -- Undotted Function name
	SUBTTL	R. Meyers/RVM	2-Nov-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	BTEST
EXTERN	BTEST.
BTEST=<BTEST.+0>
PRGEND
	TITLE	IAND -- Undotted Function name
	SUBTTL	R. Meyers/RVM	2-Nov-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IAND
EXTERN	IAND.
IAND=<IAND.+0>
PRGEND
	TITLE	IBCLR -- Undotted Function name
	SUBTTL	R. Meyers/RVM	2-Nov-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IBCLR
EXTERN	IBCLR.
IBCLR=<IBCLR.+0>
PRGEND
	TITLE	IBITS -- Undotted Function name
	SUBTTL	R. Meyers/RVM	2-Nov-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IBITS
EXTERN	IBITS.
IBITS=<IBITS.+0>
PRGEND
	TITLE	IBSET -- Undotted Function name
	SUBTTL	R. Meyers/RVM	2-Nov-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IBSET
EXTERN	IBSET.
IBSET=<IBSET.+0>
PRGEND
	TITLE	IEOR -- Undotted Function name
	SUBTTL	R. Meyers/RVM	2-Nov-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IEOR
EXTERN	IEOR.
IEOR=<IEOR.+0>
PRGEND
	TITLE	IOR -- Undotted Function name
	SUBTTL	R. Meyers/RVM	2-Nov-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	IOR
EXTERN	IOR.
IOR=<IOR.+0>
PRGEND
	TITLE	ISHFT -- Undotted Function name
	SUBTTL	R. Meyers/RVM	2-Nov-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	ISHFT
EXTERN	ISHFT.
ISHFT=<ISHFT.+0>
PRGEND
	TITLE	ISHFTC -- Undotted Function name
	SUBTTL	R. Meyers/RVM	2-Nov-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	ISHFTC
EXTERN	ISHFC.
ISHFTC=<ISHFC.+0>
PRGEND
	TITLE	NOT -- Undotted Function name
	SUBTTL	R. Meyers/RVM	2-Nov-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	NOT
EXTERN	NOT.
NOT=<NOT.+0>
PRGEND
	TITLE	MVBITS -- Undotted Subroutine name
	SUBTTL	R. Meyers/RVM	2-Nov-84

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;+
; Created in edit 4163.
;
; Provide the undottend name of the bit subroutine.
;
;-

SEARCH	MTHPRM
NOSYM
ENTRY	MVBITS
EXTERN	MVBIT.
MVBITS=<MVBIT.+0>
PRGEND
	TITLE	BTEST. - Test a Bit for Being On
	SUBTTL	Randall Meyers/RVM	3-Oct-83

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;++					[4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
;	This function is a logical function.  The ith bit of argument
;	'n' is tested.  If it is 1, the value of this function is
;	.TRUE.;  if it is 0, the value of the function is .FALSE.
;
; CALLING SEQUENCE:
;
;	FLAG = BTEST(N, I)
;
; INPUT PARAMETERS:
;
;	N	An INTEGER containing the bit to be tested.
;	I	An INTEGER that is the bit position of the bit to be
;		tested (0 is the rightmost bit).
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	.TRUE.		If the bit tested was one.
;	.FALSE.		If the bit tested was zero.
;
; SIDE EFFECTS:
;
;	None
;
;--




	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(BTEST.)	;Entry to BTEST function

	MOVE	T1,@1(L)	;Get second argument
	MOVEI	T0,1		;Get a one
	LSH	T0,(T1)		;Make up mask
	TDNN	T0,@0(L)	;Is the bit turned on?
	 TDZA	T0,T0		;No--return .FALSE.
	  SETO	T0,		;Yes--return .TRUE.

	POPJ	P,		;Return

	PRGEND
	TITLE	IAND. - Bitwise AND
	SUBTTL	Randall Meyers/RVM	3-Oct-83

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;++					[4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
;	This INTEGER function performs the bitwise AND of its two
;	INTEGER arguments.
;
; CALLING SEQUENCE:
;
;	IANS = IAND(M, N)
;
; INPUT PARAMETERS:
;
;	M	An INTEGER to be AND'ed
;	N	An INTEGER to be AND'ed
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	The bitwise and of the two arguments as an INTEGER.
;
; SIDE EFFECTS:
;
;	None
;
;--




	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(IAND.)		;Entry to IAND function

	MOVE	T0,@0(L)	;Get first argument
	AND	T0,@1(L)	;AND with second argument
	POPJ	P,		;Return

	PRGEND
	TITLE	IBCLR. - Clear a bit
	SUBTTL	Randall Meyers/RVM	3-Oct-83

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;++					[4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
;	This INTEGER function returns a copy of argument N with the
;	ith bit set to zero.
;
; CALLING SEQUENCE:
;
;	IANS = IBCLR(N, I)
;
; INPUT PARAMETERS:
;
;	N	An INTEGER containing the bit to be cleared.
;	I	An INTEGER that is the bit position of the bit to be
;		cleared (0 is the rightmost bit).
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	A copy of argument N with bit I set to zero.
;
; SIDE EFFECTS:
;
;	None
;
;--




	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(IBCLR.)	;Entry to IBCLR function

	MOVE	T1,@1(L)	;Get second argument
	MOVEI	T0,1		;Get a one
	LSH	T0,(T1)		;Make up mask
	ANDCA	T0,@0(L)	;Get first argument with bit turned off

	POPJ	P,		;Return

	PRGEND
	TITLE	IBITS. - Extract a bit field
	SUBTTL	Randall Meyers/RVM	3-Oct-83

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;++					[4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
;	This INTEGER function extracts a subfield of 'LEN' bits from
;	'M' starting with bit position 'I' and extending left for
;	'LEN'.  The result field is right justified and the remaining
;	bits are set to zero.  The value of I must be greater than or
;	equal to zero, and less than 35.  The value of I+LEN must be
;	less than or equal to 36.
;
; CALLING SEQUENCE:
;
;	IANS = IBITS(M, I, LEN)
;
; INPUT PARAMETERS:
;
;	M	An INTEGER, the source of the bitfield.
;	I	An INTEGER, the starting position of the bitfield (the
;		leftmost bit).
;	LEN	An INTEGER, the length of the bitfield.
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	The bitfield, right justified, as an INTEGER.
;
; SIDE EFFECTS:
;
;	None
;
;--




	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(IBITS.)	;Entry to IBITS function

	MOVE	T0,@1(L)	;Get argument 2 (The start of bit field)
	DPB	T0,[POINT 6,PTR,5] ;Store in pointer

	MOVE	T0,@2(L)	;Get argument 3 (The size of the bit field)
	DPB	T0,[POINT 6,PTR,11] ;Store in pointer

	LDB	T0,PTR		;Get bit field

	POPJ	P,		;Return

	LIT

	SEGMENT	DATA

PTR:	POINT	.-.,@0(L),.-.	;Pointer to first argument

	PRGEND
	TITLE	IBSET. - Set a bit
	SUBTTL	Randall Meyers/RVM	3-Oct-83

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;++					[4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
;	This INTEGER function returns a copy of its first argument
;	with a bit to one.
;
; CALLING SEQUENCE:
;
;	IANS = IBSET(N, I)
;
; INPUT PARAMETERS:
;
;	N	An INTEGER containing the source bitstring.
;	I	An INTEGER that is the bit position of the bit to be
;		set (0 is the rightmost bit).
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	A copy of the first argument with the I'th bit set to one.
;
; SIDE EFFECTS:
;
;	None
;
;--




	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(IBSET.)	;Entry to IBSET function

	MOVE	T1,@1(L)	;Get second argument
	MOVEI	T0,1		;Get a one
	LSH	T0,(T1)		;Make up mask
	IOR	T0,@0(L)	;Get first argument with specified bit on

	POPJ	P,		;Return

	PRGEND
	TITLE	IEOR. - Bitwise Exclusive OR
	SUBTTL	Randall Meyers/RVM	3-Oct-83

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;++					[4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
;	This INTEGER function performs the bitwise exclusive OR of its
;	two INTEGER arguments.
;
; CALLING SEQUENCE:
;
;	IANS = IEOR(M, N)
;
; INPUT PARAMETERS:
;
;	M	An INTEGER to be exclusive OR'ed
;	N	An INTEGER to be exclusive OR'ed
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	The bitwise exclusive OR of the two arguments as an INTEGER.
;
; SIDE EFFECTS:
;
;	None
;
;--




	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(IEOR.)		;Entry to IEOR function

	MOVE	T0,@0(L)	;Get first argument
	XOR	T0,@1(L)	;Exclusive OR with second argument
	POPJ	P,		;Return

	PRGEND
	TITLE	IOR. - Bitwise Inclusive OR
	SUBTTL	Randall Meyers/RVM	3-Oct-83

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;++					[4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
;	This INTEGER function performs the bitwise inclusive OR of its
;	two INTEGER arguments.
;
; CALLING SEQUENCE:
;
;	IANS = IOR(M, N)
;
; INPUT PARAMETERS:
;
;	M	An INTEGER to be inclusive OR'ed
;	N	An INTEGER to be inclusive OR'ed
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	The bitwise inclusive OR of the two arguments as an INTEGER.
;
; SIDE EFFECTS:
;
;	None
;
;--




	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(IOR.)		;Entry to IOR function

	MOVE	T0,@0(L)	;Get first argument
	IOR	T0,@1(L)	;Inclusive OR with second argument
	POPJ	P,		;Return

	PRGEND
	TITLE	ISHFT. - Logical Shift
	SUBTTL	Randall Meyers/RVM	3-Oct-83

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;++					[4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
;	This INTEGER function performs a LOGICAL shift of 'K' places.
;
; CALLING SEQUENCE:
;
;	IANS = ISHFT(M, K)
;
; INPUT PARAMETERS:
;
;	M	The INTEGER to be shifted.
;	K	The INTEGER number of places to shift.
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	'M' logically shifted by 'K' bits.
;
; SIDE EFFECTS:
;
;	None
;
;--




	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(ISHFT.)	;Entry to ISHFT function

	MOVE	T0,@0(L)	;Get first argument
	MOVE	T1,@1(L)	;Get second argument
	LSH	T0,(T1)		;Shift
	POPJ	P,		;Return

	PRGEND
	TITLE	ISHFC. - Logical Shift
	SUBTTL	Randall Meyers/RVM	3-Oct-83

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;++					[4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
;	This INTEGER function circularly shifts the rightmost 'IC'
;	bits of its argument 'K' places;  i.e., the bits shifted out
;	of one end are shifted into the opposite end.  No bits are
;	lost.  The unshifted bits of the result are the same as the
;	unshifted bits of the argument 'M'.  The absolute value of the
;	argument 'K' must be less than or equal to 'IC'.  The argument
;	'IC' must be greater than zero and less than or equal to 36.
;	(This function is known by the FORTRAN INTRISIC name 'ISHFTC'.)
;
; CALLING SEQUENCE:
;
;	IANS = ISHFTC(M, K, IC)
;
; INPUT PARAMETERS:
;
;	M	The INTEGER to rotate.
;	K	The INTEGER number of places to rotate.
;	IC	The INTEGER size of the bitfield to rotate.
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	The rightmost 'IC' bits of 'M' logically rotated by 'K' bits.
;
; SIDE EFFECTS:
;
;	None
;
;--




	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

;	T0 == argument
;	T1 == shift factor
;	T2 == byte to rotate
;	T3 == byte to rotate

	HELLO	(ISHFC.)	;Entry to ISHFTC function

	DMOVEM	T2,SAVE23	;Save T2 and T3
	PUSH	P,T4		;[4206] Save T4

	MOVE	T0,@0(L)	;Get argument 1 (the bitstring)
	MOVE	T1,@1(L)	;Get argument 2 (the shift factor)
	MOVE	T2,@2(L)	;Get argument 3 (the byte size)

	DPB	T2,[POINT 6,PTR,11] ;Store byte size in pointer
	LDB	T3,PTR		;Get byte to be rotated
	MOVE	T2,T3		;Get copy of byte

	LSH	T3,(T1)		;Shift to get high order part of rotated byte

	MOVE	T4,@2(L)	;[4206] Byte size
	SKIPGE	T1		;[4206] If shift factor was negative,
	 MOVN	T4,T4		;[4206] Then negate byte size, make it positive
	SUB	T1,T4		;[4206] Get shift factor used to form low order part

	LSH	T2,(T1)		;Shift to get low order part of rotated byte
	OR	T3,T2		;Form rotated result
	DPB	T3,PTR		;Deposit in copy of original bitstring

	POP	P,T4		;[4206] Restore T4
	DMOVE	T2,SAVE23	;Restore T2 and T3

	POPJ	P,		;Return

	LIT

	SEGMENT	DATA

PTR:	POINT	.-.,T0,35	;Pointer to copy of first argument
SAVE23:	BLOCK	2		;Local storage for T2 and T3

	PRGEND
	TITLE	MVBIT. - Extract a bit field
	SUBTTL	Randall Meyers/RVM	3-Oct-83

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;++					[4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
;	This subroutine moves 'LEN' bits from positions 'I' through
;	I+LEN-1 of argument 'M' to positions J through J+LEN-1 of
;	argument 'N'.  The portion of argument 'N' not affected by
;	the movement of bits remians unchanged.  All arguments are
;	INTEGER expressions except 'N' must be a variable or array
;	element.  Arguments 'M' and 'N' are permitted to be the same
;	numeric storage unit.  The values of I+LEN and of J+LEN must
;	be less than or equal to 36.
;
; CALLING SEQUENCE:
;
;	CALL MVBITS(M, I, LEN, N, J)
;
; INPUT PARAMETERS:
;
;	M	The source of the bitstring to be transferred.
;	I	The bit position of the source bitstring in M.
;	LEN	The number of bits.
;	N	The destination (this word will have the bitsting
;		inserted.
;	J	The bit position of the source bitstring in N.
;	
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	None
;
; SIDE EFFECTS:
;
;	None
;
;--




	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(MVBIT.)	;[4163] Entry to MVBITS function

	MOVE	T0,@1(L)	;Get argument 2 (Start of source field)
	DPB	T0,[POINT 6,SPTR,5] ;Store in pointer to source

	MOVE	T0,@4(L)	;Get argument 5 (Start of destination field)
	DPB	T0,[POINT 6,DPTR,5] ;Store in pointer to destination

	MOVE	T0,@2(L)	;Get argument 3 (The size of the bit fields)
	DPB	T0,[POINT 6,SPTR,11] ;Store in pointer to source
	DPB	T0,[POINT 6,DPTR,11] ;Store in pointer to destination

	LDB	T0,SPTR		;Get bit field from source
	DPB	T0,DPTR		;Store bit field in destination

	POPJ	P,		;Return

	LIT

	SEGMENT	DATA

SPTR:	POINT	.-.,@0(L),.-.	;Pointer to first argument  (source)
DPTR:	POINT	.-.,@3(L),.-.	;Pointer to fourth argument (destination)

	PRGEND
	TITLE	NOT. - Bitwise NOT
	SUBTTL	Randall Meyers/RVM	3-Oct-83

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.

;++					[4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
;	This INTEGER function performs the bitwise logical complement
;	of its INTEGER argument.
;
; CALLING SEQUENCE:
;
;	IANS = NOT(M)
;
; INPUT PARAMETERS:
;
;	M	An INTEGER to be complemented.
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	None
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	The bitwise logical complement of the argument.
;
; SIDE EFFECTS:
;
;	None
;
;--




	SEARCH	MTHPRM,FORPRM
	FSRCH
	SEGMENT	CODE

	HELLO	(NOT.)		;Entry to NOT function

	SETCM	T0,@0(L)	;Complement argument
	POPJ	P,		;Return

	PRGEND
	SEARCH	MTHPRM,FORPRM
	TV	FORSYM	SYMBOL TABLE MANIPULATION ROUTINES

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.

;[4152] NEW
;++
; FUNCTIONAL DESCRIPTION:
;
;	Converts an IOWD or pointer to a symbol table (usually found
;	in .JBSYM of FOROTS' section) into an address and count in
;	T1 and T2.
;
; CALLING SEQUENCE:
;
;	PUSHJ	P,%SVCNV
;
; INPUT PARAMETERS:
;
;	Symbol table IOWD or address of symbol vector in T1
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	Address of symbol table in T1
;	Length of symbol table in T2

;
; IMPLICIT OUTPUTS:
;
;	None
;
; SIDE EFFECTS:
;
;	None
;
;--

	SEGMENT	CODE

	ENTRY	%SVCNV

IF20,<
%SVCNV:	TLNE	T1,777000	;[4174] IF ANY OF THESE BITS ARE SET
	 JRST	STIOWD		;[4174] ASSUME IT'S AN IOWD
	MOVE	T3,.STLEN(T1)	;GET SYMBOL VECTOR LENGTH FOR SEARCHING IT
	SUBI	T3,1		;MINUS THE COUNT WORD
	ADDI	T1,1		;POINT TO 1ST ENTRY
SVCLP:	LDB	T2,[POINTR (.STDAT(T1),ST%TYP)] ;GET SYMBOL TYPE
	CAIN	T2,.R50D	;THE DEFINED SYMBOL TABLE?
	 JRST	SVCDON		;YES. GO PICK UP ADDRESS AND LENGTH
	ADDI	T1,3		;NO. GO TRY AGAIN
	SUBI	T3,3		;DECREMENT COUNT
	JUMPG	T3,SVCLP	;LOOP IF MORE
	SETZB	T1,T2		;RETURN NO SYMBOL TABLE IF NO MATCH
	POPJ	P,

SVCDON:	LDB	T2,[POINTR (.STDAT(T1),ST%LEN)] ;GET SYMBOL TABLE SIZE
	MOVE	T1,.STPTR(T1)	;AND ADDRESS
	POPJ	P,

> ;END IF20

IF10,<
%SVCNV:
> ;END IF10

STIOWD:	HLRO	T2,T1		;[4174] GET NEGATIVE SIZE IN T2
	MOVM	T2,T2		;GET POSITIVE
	XMOVEI	T1,(T1)		;GET ADDRESS OF SYMBOL TABLE
	POPJ	P,

	PRGEND

	SEARCH	MTHPRM,FORPRM
	TV	SECNDS	Returns seconds since midnight

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

;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1985
;ALL RIGHTS RESERVED.

;[4207] NEW
;++
; FUNCTIONAL DESCRIPTION:
;
;	User-callable routine which returns the number of seconds since
;	midnight in single precision floating point, minus the argument
;	passed to it.
;
; CALLING SEQUENCE:
;
;	X = SECNDS( Y )
;
;		Where X and Y are single precision floating point.
;
; INPUT PARAMETERS:
;
;	Y	(Shown above) A floating point number to be subtracted
;		from the number of seconds from midnight.
;
; IMPLICIT INPUTS:
;
;	None
;
; OUTPUT PARAMETERS:
;
;	Function return value is in T0.
;
; IMPLICIT OUTPUTS:
;
;	None
;
; FUNCTION VALUE:
;
;	The number of seconds since midnight in floating point format.
;
; SIDE EFFECTS:
;
;	None
;
;--



	SEGMENT	CODE

	ENTRY	SECNDS
	HELLO	(SECNDS)

	;Check for correct number of arguments.  Only 1 allowed.

	HLRZ	T0,-1(L)	;Get count of arguments
	CAIE	T0,-1		;If -1 (one argument),
	 $FCALL	WNA		;Wrong number of arguments

	;Check argument to insure that it's floating point or octal.

	LDB	T0,[POINTR (0(L),ARGTYP)]	;Get argument type
	CAIN	T0,TP%SPR	;.NE. floating point?
	 JRST	OK		;Yes, go around

	CAIE	T0,TP%SPO	;Argument single precision octal?
	 $FCALL	NFL		;Argument isn't floating or octal

OK:	SKIPE	[FLG77.##]	;Is /FLAG:ANSI on?
	 $FCALL	CFX		;Yes; give warning message, this isn't ANSI

	;Calculate milliseconds since midnight

IF10,<
	MSTIME	T0,		;Milliseconds since midnight

> ;END IF10

IF20,<
	PUSH	P,T2		; Save registers
	PUSH	P,T3
	PUSH	P,T4

	GTAD%			;Get internal time

	;Convert <days,,fraction-of-days> to milliseconds since midnight

	HRLZ	T0,T1		;Get fractional days, put in left half
	LSH	T0,-1		;Move away from sign bit
	MUL	T0,[<^D24>*<^D60>*<^D60>*<^D1000>]
				;Compute msec since midnight

	;Adjust for local time zone (from GMT) and daylight savings time
	;The general algorithm is similar to that in TIME.  If this must be
	;changed, them TIME probably ought to be changed also.

	SETO	T2,		;Want current time
	SETZ	T4,		;Use local time

	ODCNV%			;JSYS, get local zone and daylight indicator

	HLR	T3,T4		;Bits indicating time zone, daylight savings...
	HRROI	T2,<^-<(IC%TMZ)>> ;Mask -1,,777700 to isolate time zone
	TDZ	T3,T2		;Get time zone bits (12-17) only
	TRNE	T3,40		;Time zone negative (-12 to +12)?
	 TDO	T3,T2		;Yes, propogate its sign bit

	TXNE	T4,IC%ADS	;Is Daylight Savings in effect?
	 SUBI	T3,1		;Yes, subtract one hour

	IMUL	T3,[<^D60>*<^D60>*<^D1000>]
				;Convert hours to milliseconds
	SUB	T0,T3		;Add in local time/daylight savings factors

	SKIPGE	T0		;Seconds go negative?
	 ADD	T0,[<^D24>*<^D60>*<^D60>*<^D1000>]
				; yes, add in a day's milliseconds to get
				; mod 24 hrs.

	POP	P,T4		;Restore registers
	POP	P,T3
	POP	P,T2

> ;END IF20

	FLTR	T0,T0		;Convert integer milliseconds to floating point
	FDVR	T0,[1000.0]	;Convert milliseconds to seconds

	FSBR	T0,@0(16)	;Subtract off user's argument

	POPJ	P,		;Return to caller

	END