.TITLE	IBMR4

;++
; -----------------------------------------------------------------------------
; PP&L KWH System <> Standard Library Routine
; -------------------------------------------
;
; Convert from Digitial REAL*4 internal format to IBM four-byte floating
; point internal format
;
; Written by Gary Peressini
; -----------------------------------------------------------------------------
;--

	.PSECT	$CODE,PIC,CON,REL,LCL,SHR,EXE,RD,NOWRT,LONG

	.ENTRY	IBMR4,^M<R2,R3,R4,R5,R6,R7,R8,R9,R10,R11>

	CMPB	#2,(AP)		; must pass 2 arguments
	BEQL	OK		; OK
	CLRL	R0		; error
	RET			; return

OK:	MOVL	#^X800000,R6	; load constant
	MOVL	#^XC1FFFFFF,R7	; load constant
	MOVL	#^X20000000,R8	; load constant
	MOVL	#^X40000000,R9	; load constant
	MOVL	#^X80000000,R10	; load constant
	MOVL	#^XFE7FFFFF,R11	; load constant
	MOVL	@4(AP),R0	; loop count
	BEQL	DONE		; no reals to convert, so return
	MOVL	8(AP),R1	; address of reals
LOOP:	MOVL	(R1)+,R5	; put input real in R5 and point R1 to next
	BEQL	60$		; a zero is a zero so jump to end
	ROTL	#^X10,R5,R5	; swap word
	BICL3	#^XFF800000,R5,R2 ; copy fraction
	BISL	R6,R2		; put in hidden bit
	BICL3	R11,R5,R3	; copy low 2 bits of exponet
	ASHL	#-^X17,R3,R3	; shift to bit 0
	BEQL	10$		; no shift of fraction
	SUBL3	R3,#4,R4	; convert to shift value
	MNEGL	R4,R4		; convert to a shift right
	ASHL	R4,R2,R2	; shift the fraction
10$:	BICL3	R7,R5,R4	; copy top 5 bits of exponet
	ASHL	#-1,R4,R4	; shift exponet down one
	BITL	R9,R5		; compliment of second bit from top on
	BNEQ	20$		;  DEC goes to third bit from top on IBM
	BISL2	R8,R4		; 
	BRB	30$		; 
20$:	BISL2	R9,R4		; second bit from top goes to second bit
30$:	TSTL	R3		; if low 2 bits of exponet are not zero
	BEQL	40$		;  then add 1 to exponet
	ADDL2	R6,R4		; 
	ADDL2	R6,R4		; 
40$:	BITL	R10,R5		; sign bit
	BEQL	50$		; 
	BISL2	R10,R4		; 
50$:	BISL3	R4,R2,R5	; combine exponet with fraction
				;  and replace DEC format with IBM format
60$:	PUSHL	R5		; put on stack
	MOVB	(SP)+,-(R1)	; put back in memory and point to next real
	MOVB	(SP)+,-(R1)	;  swaping the bytes in the process
	MOVB	(SP)+,-(R1)	; 
	MOVB	(SP)+,-(R1)	; 
	TSTL	(R1)+		; put r1 back right
	SOBGTR	R0,LOOP		; repeat process
DONE:	MOVL	#1,R0		; indicate success
	RET			; return

	.END