.MCALL	.MODULE
.MODULE	JFLT,VERSION=04,COMMENT=<IDJFLT,DJFLT,IAJFLT,AJFLT/SYSLIB>,IDENT=NO,LIB=YES

; Copyright (c) 1998 by Mentec, Inc., Nashua, NH.
; All rights reserved
;
; This software is furnished under a license for use only on a
; single computer system and  may  be  copied  only  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 except for  use  on  such
; system and to one who agrees to these license  terms.  Title
; to  and  ownership of the software shall at all times remain
; in Mentec, Inc.
;
; The information in this document is subject to change without
; notice and should not be construed as a commitment by Digital
; Equipment Corporation, or Mentec, Inc.
;
; Digital and Mentec  assume  no  responsibility for the use or
; reliability of its software on equipment which is not supplied
; by Digital  or Mentec,  and listed  in the  Software  Product
; Description.
	.SBTTL	Module Declaration

	.NLIST
	.ENABL	LC
	.DSABL	GBL
	.NLIST	CND
	.LIST
; ++
; FACILITY:
;
;    RT-11 System Subroutine Library
;
; CALLABLE ENTRIES:
;
;    IDJFLT, DJFLT, IAJFLT, AJFLT
;
; ENVIRONMENT:
;
;    These routines can be used by any job running in a single-job
;    or multi-job environment . It uses "TRAP" to provide error processing.
;
;
; INCLUDE FILES:
;

	; SYSMAC.SML		; RT-11 system macro library.

;
; EXTERNAL REFERENCES:
;

	.GLOBL	$SYSLB		; Include system library work area.
	.GLOBL	$SETR0		; Entry point to SET R0 routine

	.SBTTL	IDJFLT,DJFLT,IAJFLT,AJFLT - Fortran-callable routines
;
; ++
; FUNCTIONAL DESCRIPTION:
;
;    IDJFLT - converts an INTEGER*4 value into a REAL*8(DOUBLE PRECISION)
;	      value and stores the result 
;
;    DJFLT  - converts an INTEGER*4 value into a REAL*8(DOUBLE PRECISION)
;	      value and stores the result as the function value   
;
;    IAJFLT - converts an INTEGER*4 value to a REAL*4 value and stores 
;	      the result
;
;    AJFLT  - converts an INTEGER*4 value to a REAL*4 value and stores
;	      the result as the function value
;
; CALLING SEQUENCE:
;
;    i = IDJFLT(jsrc,dres)
;    d = DJFLT(jrsc)
;    i = IAJFLT(jsrc,ares)
;    a = AJFLT(jsrc)
;
; INPUT PARAMETERS:
;
;    R5	    -  address of IDJFLT,DJFLT,IAJFLT,AJFLT argument block
;
;    0(R5)  -  argument count of IDJFLT,DJFLT,IAJFLT,AJFLT call
;    2(R5)  -  address of INTEGER*4 variable that is to be converted
;    4(R5)  -  address of REAL*4(IAJFLT) or REAL*8(for IDJFLT) variable to 
;	       receive the converted value
;
; OUTPUT PARAMETERS:
;
;    R0 and R1     - returns REAL*4
;    R0 through R3 - returns REAL*8
;
;    d =  REAL*8 value; result of the operation (DJFLT)
;    a =  REAL*4 value; result of the operation (AJFLT)
;
; RETURNED FUNCTION VALUE:
;
;    i =  -1 normal return; the result is negative (IAJFLT, IDJFLT)
;      =   0 normal return; the result is zero (IAJFLT, IDJFLT)
;      =   1 normal return; the result is positive (IAJFLT, IDJFLT)
;      =  -2 significant digits were lost during conversion (IAJFLT) 
;
; --


	.PSECT	SYS$I

IDJFLT::
DJFLT::	MOV	(PC)+,-(SP)	; set D entry flag
IAJFLT::
AJFLT::	CLR	-(SP)		; set A entry flag
	MOV	(R5)+,-(SP)	; save arg count
	MOV	(R5)+,R4	; get addr of i*4 quantity
	CLR	R2		; init possible 3rd word of result
	MOV	(R4)+,R1	; get low part
	BNE	10$		; branch if not 0
	MOV	@R4,R0		; is entire number 0
	BEQ	70$		; branch if yes

10$:	MOV	@R4,R0		; get high part
	BPL	20$		; branch if positive
	NEG	R0		; negate high part, c=1
	NEG	R1		; negate low part
	SBC	R0
20$:	MOV	#237,R3		; set maximum exp+1
30$:	BIT	#177400,R0	; look for a string of 8 0 bits
	BNE	50$		; branch if not found
	SWAB	R0		; left justify them
	SUB	#8.,R3		; perform a shift by 8
	SWAB	R1		;
	BISB	R1,R0		; insert new bits
	CLRB	R1		; remove them
	BR	30$		; try again

40$:	DEC	R3		; fix exp count
	ROL	R1		; normalize r0:r1
	ROL	R0		;
50$:	BPL	40$		; loop till implied norm bit in sign
	BISB	R1,R2		; put in bits 25-32
	SWAB	R2		; justify it
	CLRB	R1		; remove the bits from 2nd word
	BISB	R0,R1		; move the new ones in from r0
	SWAB	R1		; justify it
	CLRB	R0		; remove them from high word
	SWAB	R0		; justify it
	SWAB	R3		; get exp into high byte
	TST	@R4		; was original number + or -
	BPL	60$		; branch if positive, C=0
	SEC			;
60$:	ROR	R3		; insert with exp
	ADD	R3,R0		; create result
70$:	CLR	R3		; init just in case d entry
	DECB	(SP)+		; is result argument wanted?
	BNE	80$		; branch if yes to store it
	TST	(SP)+		; remove extra word
	RETURN

80$:	MOV	@R5,R5		; get destination adress
	MOV	R0,(R5)+	; store high order word
	MOV	R1,(R5)+	; store next word
	TST	(SP)+		; 2 word or 4 word result?
	BEQ	90$		; branch if only 2 word result
	MOV	R2,(R5)+	; store next word
	CLR	@R5		; store last word
90$:	MOV	R4,R1		; set pointer to I*4 quantity for $SETR0
	CLR	R0		; set for $SETR0 
	CALLR	$SETR0		; exit via $SETR0 routine

	.END