! HALIB - FORTRAN SUBROUTINES				HALIB.MAC
!
!	WRITTEN BY HAL SYSTEMS CORPORTATION
!		3544 SW 172 ST
!		SEATTLE WA, 98166
!		206-244-6606
!
! MENU OF ROUTINES
!	MOVWRD	- MOVE AN ARRAY OF WORDS
!	MOVBYT	- MOVE AN ARRAY OF BYTES
!	LCOMP	- COMPARE LOGICAL*1 ARRAYS
!	CVAI	- CONVERT ASCII FIELD TO I*2 OR I*4
!	CVIA	- CONVERT I*2 OR I*4 TO ASCII
!	ISHFT	- SHIFT BITS WITHIN A WORD
!
.TITLE	MOVWRD FORTRAN SUBROUTINE
	.LIST	TTM
	.NLIST	SYM

;	FORTRA CALLING FORMAT
;	CALL MOVWRD (IN,IFST,ILNT,OUT,OFST)
;	IN	INPUT WORD ARRAY
;	IFST	FIRST WORD OF IN TO MOVE
;	ILNT	NUMBER OF WORDS TO MOVE FROM IN
;	OUT	OUTPUT WORD ARRAY
;	OFST	FIRST WORD OF OUT ARRAY

;	THE IN ARRAY STARTING AT IFST BYTE FOR ILNT BYTES WILL 
;	   BE MOVE TO THE OUT ARRAY STARTING AT THE OFST BYTE.

	.GLOBL	MOVWRD, MOVWD
	.MCALL	..V2..,.REGDEF,.EXIT
	.REGDEF
	.MACRO	SOB	R,ADDR
	DEC	R
	BNE	ADDR
	.ENDM

MOVWRD:
MOVWD:	TST	(R5)+			;SKIP FIRST ARG
	MOV	(R5)+,R1		;ADDRESS IF IN ARRAY
	ADD	@(R5),R1		;STARTING WORD
	ADD	@(R5)+,R1		;DOUBLE IT
	DEC	R1
	DEC	R1			;ADJUST FOR FORTRAN
	MOV	@(R5)+,	R2		;ILNT ARG
	BPL	1$			;REASONABLE VALUE
	BISB	#10,@#53		;SEVERE USER ERROR
	.EXIT
1$:	MOV	(R5)+,R3		;ADDRESS OF OUT ARRAY
	ADD	@(R5),R3		;ADD OFST
	ADD	@(R5)+,R3		;DOUBLE IT
	DEC	R3			;ADJUST FOR FORTRAN
	DEC	R3
; MAIN LOOP
2$:	MOV	(R1)+,(R3)+		;MOVE IN TO OUT
	SOB	R2, 2$
	RTS	PC
	.END
.TITLE	MOVBYT FORTRAN SUBROUTINE
	.LIST	TTM
	.NLIST	SYM

;	FORTRA CALLING FORMAT
;	CALL MOVBYT (IN,IFST,ILNT,OUT,OFST)
;	IN	INPUT BYTE ARRAY
;	IFST	FIRST BYTE OF IN TO MOVE
;	ILNT	NUMBER OF BYTES TO MOVE FROM IN
;	OUT	OUTPUT BYTE ARRAY
;	OFST	FIRST BYTE OF OUT ARRAY

;	THE IN ARRAY STARTING AT IFST BYTE FOR ILNT BYTES WILL 
;	   BE MOVE TO THE OUT ARRAY STARTING AT THE OFST BYTE.

	.GLOBL	MOVBYT
	.MCALL	..V2..,.REGDEF,.EXIT
	.REGDEF
	.MACRO	SOB	R,ADDR
	DEC	R
	BNE	ADDR
	.ENDM

MOVBYT:	TST	(R5)+			;SKIP FIRST ARG
	MOV	(R5)+, R1		;ADDRESS OF IN ARRAY
	ADD	@(R5)+, R1		;ADD IFST
	DEC	R1			;ADJUST FOR FORTRAN
	MOV	@(R5)+,R2		;LOAD ILNT FOR LOOP
	BPL	1$			;CHECK FOR BAD LENGTH
	BISB	#10, @#53		;SEVERE USER ERROR
	.EXIT
1$:	MOV	(R5)+,R3		;ADDRESS OF OUT ARRAY
	ADD	@(R5)+,R3		;ADD STARTING BYTE
	DEC	R3			;ADJUST FOR FORTRAN
; MAIN LOOP
2$:	MOVB	(R1)+,(R3)+		;MOVE IN TO OUT
	SOB	R2, 2$			;LOOP ILNT TIMES
	RTS	PC
	.END
.TITLE LCOMP
;	HAL SYSTEMS CORP

;	CALL LCOMP(LNT,ARG1,ARG2,ICK)
;	ICK = LCOMP(LNT,ARG1,ARG2)

;	BYTE COMPARE ON TWO FIELDS FOR A GIVEN LENGTH.
;	ICK IS SET TO THE FIRST UNEQUAL BYTE OR ZERO IF EQUAL.
;	IF ARG1 < ARG2 THEN ICK <0
;	IF ARG1 = ARG2 THEN ICK =0
;	IF ARG2 > ARG2 THEN ICK >0

	.MCALL ..V2..,.REGDEF
	.REGDEF
	.MACRO	SOB	R,ADDR
	DEC	R
	BNE	ADDR
	.ENDM
	.GLOBL	LCOMP

LCOMP:	MOV	(R5)+,R3		;# OF ARGS IN LOW BYTE
	MOV	@(R5)+,R4		;LENGTH OF FIELDS
	MOV	(R5)+,R1		;POINTER TO ARG1
	MOV	(R5)+,R2		;POINTER TO ARG2
	CLR	R0			;BYTE COUNTER
; MAIN LOOP
1$:	INC	R0			;COUNT BYTE
	CMPB	(R1)+,(R2)+		;COMPARE ARG1 TO ARG2
	
	BLT	3$			;ARG1 < ARG2
	BGT	4$			;ARG1 > ARG2
	SOB	R4,1$			;DONE YET?
	CLR	R0			;ARG1 = ARG2
	BR	4$
3$:	NEG	R0			;FLIP BYTE COUNT
4$:	CMPB	#4,R3			;CALL OR FUNCTION
	BHI	9$			;RETURN IN R0
	MOV	R0,@(R5)+		;RESULT TO ICK
9$:	RTS	PC
	.END
	.TITLE  CVAI & CVAJ - CONVERT ASCII TO INTEGER
;
;	CALL CVAI (IN,IFST,LNT,IVAL,ICK)  SINGLE PRECISION
;	CALL CVAJ (IN,IFST,LNT,DVAL,ICK)  DOUBLE PRECISION
;
;	IN IS A BYTE ARRAY STARTING AT IN(IFST) FOR LNT BYTES.
;	    IF IN(IFST+LNT-1) IS A DASH, THE RESULT IS
;	    NEGATIVE OR IF BLANK, POSITIVE.
;	    SPACES, COMMAS, AND PERIODS ARE IGNORED, BUT ANY OTHER
;	    NON DECIMAL BYTE WILL GIVE AN ERROR.
;
;	IVAL AND DVAL ARE SINGLE AND DOUBLE PRECISION INTEGER
;	    RESULTANT VALUE.  ANY ERRORS WILL GIVE A ZERO RESULT.
;
;	ICK  IS ZERO IF NO ERROR OR SET TO 1 IF ERROR FOUND
;
	.MCALL	..V2..,.REGDEF
	..V2..
	.REGDEF
	.GLOBL  CVAI,CVAJ
CVAI:	CLR	-(SP)		;SWITCH FOR SINGLE PRECISION
	BR	START
CVAJ:	MOV	R5,-(SP)		;DOUBLE <> 0
START:	CMP	#5,(R5)		;CHECK FOR 5 ARGUMENTS
	BNE	OVER2			;NOPE
	TST	(R5)+			;SKIP ARG
	MOV	(R5)+,R4		;FIELD START ADDR
	MOV	@(R5)+,R2		;FIELD SUBSCRIPT VALUE
	MOV	@(R5)+,R3		;FIELD LENGTH VALUE
	BLE	OVER2			;CHECK LENGTH
	DEC	R2
	ASL	R2			;(R2-1)*2
	ADD	R4,R2			;R2 POINTS TO START OF ASCII FIELD
	DEC	R3
	ADD	R2,R3			;R3 POINTS TO END OF ASCII FIELD
	CLR	R0			;LOW ORDER INTEGER
	CLR	R1			;HIGH ORDER INTEGER
AGAIN:	MOVB	(R2)+,R4		;GET BYTE
	CMP	R2,R3			;AT END OF FIELD
	BGT	OVER2			;IS THE SIGN
	CMPB	#60,R4
	BGE	AGAIN			;SKIP LEADING ZEROS
	CMPB	#71,R4
	BLT	AGAIN			;IGNORE NON DECIMAL
	BR	ADD			;START ADDING
NEXT:	MOVB	(R2)+,R4		;NEXT BYTE
	CMP	R2,R3			;CHECK FOR SIGN BYTE
	BGT	SIGN
	CMPB	#40,R4			;IGNORE SPACE
	BEQ	NEXT
	CMPB	#54,R4			;IGNORE COMMA
	BEQ	NEXT
	CMPB	#56,R4			;IGNORE DECIMAL
	BEQ	NEXT
	CMPB	#60,R4			;ASCII ZERO
	BGT	OVER2
	CMPB	#71,R4			;NON DECIMAL
	BLT	OVER2
MULT:	MOV	R1,-(SP)		;SAVE PRESENT VALUE
	MOV	R0,-(SP)
	ASL	R0			;TIMES TWO
	ROL	R1
	BVS	OVER
	ASL	R0			;TIMES TWO=FOUR
	ROL	R1
	BVS	OVER
	ADD	(SP)+,R0		;PLUS ONE=FIVE
	ADC	R1
	ADD	(SP)+,R1
	BVS	OVER2
	ASL	R0			;TIMES TWO=TEN
	ROL	R1
	BVS	OVER2
ADD:	SUB	#60,R4		;CONVERT ASCII TO OCTAL
	ADD	R4,R0			;ADD NEW DIGIT
	ADC	R1
	BVS	OVER2
	BR	NEXT
SIGN:	TST	(SP)			;DOUBLE OR SINGLE PRECISION
	BNE	DOUBLE
	TST	R1
	BNE	OVER2			;SINGLE INTEGER
	TST	R0
	BMI	OVER2
	CMPB	R4,#40			;SPACE
	BEQ	PLUS
	CMPB	R4,#55			;MINUS SIGN
	BNE	OVER2			;ILLEGAL FORMAT
	NEG	R0
PLUS:	MOV	R0,@(R5)+		;STORE RESULT
	CLR	@(R5)+			;ICK = 0
	TST	(SP)+			;SW FOR DOUBLE PRE.
	RTS	PC
DOUBLE:	CMPB	R4,#40
	BEQ	PLUS2
	CMPB	R4,#55			;MINUS SIGN
	BNE	OVER2
	NEG	R1			;CONVERT TO 2'S COMPLEMENT
	NEG	R0
	SBC	R1
PLUS2:	MOV	(R5),R4			;GET ADDR OF DVAL+2
	MOV	R1,2(R4)		;STORE HIGH ORDER
	BR	PLUS			;STORE LOW ORDER
;
; ERROR PROCESSING
OVER:	MOV	(SP)+,(SP)+		;CLEAR STACK
OVER2:	MOV	(R5)+,R4			;ADDR OF DVAL
	CLR	(R4)+			;SINGLE PRECISION
	TST	(SP)+			;SWITCH SET FOR DOUBLE
	BEQ	1$
	CLR	(R4)			;CLEAR DOUBLE PRECISION
1$:	MOV	#1,@(R5)+		;ERROR=1
	RTS	PC
	.END

	.TITLE CVIA - CONVERT INTEGER TO ASCII 
;
;	CALL CVIA (IVAL,IOUT,IFST,LNT)  SINGLE PRECISION
;	CALL CVJA (DVAL,IOUT,IFST,LNT)  DOUBLE PRECISION
;
;
;	IVAL AND DVAL IS THE INPUT VALUE TO BE CONVERTED TO ASCII.
;
;	IOUT IS BYTE ARRAY STARTING AT IFST FOR LNT BYTES.
;		THE IOUT ARRAY FROM IFST FOR LNT BYTES IS BLANKED.
;		MAXIMUM OUTPUT OF 9 DIGITS AND THE SIGN IN THE
;		LOW ORDER BYTE IS RIGHT JUSTIFIED IN THE FIELD  
;		AND ZERO SUPPRESSED.
;

	R0 = %0
	R1 = %1
	R2 = %2
	R3 = %3
	R4 = %4
	R5 = %5
	SP = %6
	PC = %7

	.GLOBL CVIA,CVJA
CVJA:	MOV	#1,-(SP)	;SET FOR DOUBLE PRECISION
	BR	CVRT
CVIA:	CLR	-(SP)		;SET FOR SINGLE PRECISION
CVRT:	TST	(R5)+		;SKIP # OF ARGS
;
; GET DVAL NOW
	MOV	(R5)+,R3	;ADR OF DVAL(OR IVAL)
	MOV	(R3)+,R0	;LOW ORDER VALUE
	CLR	R1		;HIGH ORDER
	TST	(SP)+		;SET FOR DOUBLE PRECISION
	BEQ	4$		;CLR FOR SINGLE
	MOV	(R3)+,R1	;HIGH ORDER VALUE
	BR	6$
4$:	TST	R0		;MIGHT BE NEGATIVE
	BPL	6$
	DEC	R1		;IT WAS
;
; SET SIGN AND COMPLEMENT IF DVAL IS NEGATIVE
6$:	MOV	#40,-(SP)
	TST	R1
	BPL	8$		;VALUE IS POSITIVE
	MOV	#55,(SP)	;NEGATIVE VALUE IS DASHED
	NEG	R1
	NEG	R0
	SBC	R1		;COMPLEMENTED
;
; WORK THRU POWER OF TENS TABLE
8$:	MOV	#TEN,R4		;POINTER TO TENS TABLE
10$:	MOV	(R4)+,R2	;LOW ORDER
	MOV	(R4)+,R3	;HIGH ORDER
	MOV	(SP),-(SP)	;ZERO SUPRESS IF < 60
	BIC	#^C60,(SP)	;40 OR 60
12$:	CMP	R1,R3		;COMPARE DVAL TO POWER OF TEN
	BGT	14$
	BLT	16$
	CMP	R0,R2		;LOW ORDER 
	BEQ	14$
	BLO	16$
;
; VALUE EXCEEDS OR EQUALS POWER OF TEN
14$:	INC	(SP)		;DIGIT
	BIS	#60,(SP)	;END ZERO SUPRESS
	SUB	R2,R0		;SUBTRACT POWER OF TEN
	SBC	R1		;CARRY
	SUB	R3,R1		;HIGH ORDER
	BR	12$		;TRY FOR SAME DIGIT
;
; VALUE LESS THAN POWER OF TEN
16$:	DEC	R2		;LAST POWER IS 1
	BNE	10$		;KEEP ON TRUCKING
;
; COPY TO IOUT ARRAY
	MOV	(R5)+,R0	;ADR OF IOUT
	MOV	(R5)+,R1	;ADR OF IFST
	MOV	(R1),R1		;VALUE OF IFST
	MOV	(R5)+,R2	;ADR OF LNT
	MOV	(R2),R2	;VALUE OF LNT
	MOV	R2,R3		;NEED TWICE
;
; SET IOUT TO BLANKS
	MOV	R0,R4		;DEVELOPE STARTING ADDRESS
	ADD	R1,R4		;NOW HAVE IOUT(IFST+1)
	DEC	R4		;FORTRANS WAY
22$:	MOVB	#40,(R4)+	;IOUT(I)=BLNK
	DEC	R2		;LNT=LNT-1
	BGT	22$		;IF(LNT.GT.0) GO TO 22
;
; COPY STACK TO IOUT
	MOVB	24(SP),-(R4)	;RIGHT MOST SIGN
	MOV	#10.,R0		;TEN DIGITS ON STACK
	DEC	R3		;LNT=LNT-1
	BEQ	26$		;LNT COULD BE 1
24$:	MOVB	(SP)+,-(R4)	;COPY RIGHT TO LEFT
	DEC	R0		;POP COUNT
	BEQ	30$
	DEC	R3		;LNT COUNT
	BGT	24$		;MORE WANTED
26$:	TST	(SP)+		;POP REMAINDER OF STACK
	DEC	R0		;STACK COUNT
	BGT	26$		;MORE LEFT
30$:	TST	(SP)+		;POP OVER SIGN
	RTS	PC
;
; POWER OF TEN TABLE
TEN:	.WORD	145000,035632	;1,000,000,000
	.WORD	160400,002765	;  100,000,000
	.WORD	113200,000230	;   10,000,000
	.WORD	041100,000017	;    1,000,000
	.WORD	103240,000001	;      100,000
	.WORD   023420,000000	;       10,000
	.WORD	001750,000000	;        1,000
	.WORD	000144,000000	;          100
	.WORD	000012,000000	;           10
	.WORD	000001,000000	;            1
	.END



.	.TITLE	ISHFT	FORTRAN IV COMPATIBLE LOGICAL SHIFT
	.ENABL	AMA
;
;THIS ROUTINE IMPLEMENTS THE INTEGER*2 LOGICAL FUNCTION ISHFT.
;IT IS CALLED BY
;
;	RESULT=ISHFT(VARIABLE,COUNT)
;
;IF COUNT =0, NO SHIFT OCCURS.
;IF COUNT >0, A LEFT SHIFT OCCURS.
;IF COUNT <0, A RIGHT SHIFT OCCURS.
;
	.GLOBL	ISHFT

	R0=%0
	R1=%1
	R2=%2
	R3=%3
	R4=%4
	R5=%5
	SP=%6
	PC=%7

ISHFT:	MOV	(R5)+,R4	;ARGUMENT LIST IN R5... GET # ARGUMENTS.
	MOV	@(R5)+,R0	;GET VARIABLE.
	MOV	@(R5)+,R1	;GET COUNT.
	BEQ	30$		;IF ZERO, EXIT AT ONCE.
	BMI	20$		;IF MI, RIGHT SHIFT.

10$:	ASL	R0		;LEFT SHIFT...
	DEC	R1		;SHIFT NUMBER OF COUNTS REQUIRED.
	BNE	10$
	RTS	PC		;EXIT WHEN DONE.

20$:	NEG	R1
21$:	CLC			;RIGHT SHIFT... DON'T PROPAGATE SIGN.
	ROR	R0
	DEC	R1
	BNE	21$
30$:	RTS	PC		;EXIT WHEN DONE.

	.END