Google
 

Trailing-Edge - PDP-10 Archives - BB-D480G-SB_FORTRAN10_V11.0_short - forcnv.mac
There are 13 other files named forcnv.mac in the archive. Click here to see a list.

	SEARCH	MTHPRM,FORPRM
	TV	FORCNV	CONVERSION ROUTINES ,7(4201)

;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1981, 1987
;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.

	SUBTTL	REVISION HISTORY

COMMENT \

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

256	 -----	CORRECT %LSTDR TO CHANGE F%ELT TO F%EXT
345	(Q2322)	OUTPUT 2 WORDS OF DBLE PREC VAR EVEN IF F FORMAT REQUIRED
347	 -----	RESTRICT DELIMITER FOR LIST-DIRECTED INPUT TO BLANK,
		COMMA AND LINE TERMINATOR
350	(13704)	LIST-DIRECTED INPUT DOES NOT TAKE END= RETURN
354	 -----	FIX FREE FORMAT ON INPUT
357	 -----	REDEFINE LABEL ERROR FOR MACRO V50
366	 -----	FIX LIST DIRECTED I/O FOR ARRAYS
367	(13951)	FIXED INTEGER FORMAT LOOSES BLANKS AT END OF RECORD
372	 -----	FIX NAMELIST
373	(13917)	FIX SCALING FACTOR
374	 -----	END OF NAMELIST LIST FOR F10-V2
376	 -----	CORRECT FIXED "A" FORMAT AFTER FREE FORMAT
377	 -----	FIX  F  FORMAT
400	 -----	FIX TO EDIT 372
426	15142	HAVE NAMELIST ACCEPT ANY 6 CHARS NAMELIST NAME
430	15596	FIX SO SCALING ON OUTPUT AFTER NAMELIST INPUT WORKS
433	15880	FIX INPUT OF OCTAL NUMBERS TO CORRECTLY HANDLE MINUS SIGN
441	16108	FIX %FLOUT SO SINGLE PREC. NOS. LIKE -1.999999 DON'T
		LOSE PRECISION
445	16517	FIX NAMELIST INPUT SO FLOATING POINT TO INTEGER CONV.
		WORKS FOR ALL CASES EVEN #'S LIKE 1.0

***** Begin Version 4C *****

461	16741	FIX NAMELIST TO ACCEPT ANY 6 CHAR VARIABLE NAME
462	16796	FIX %FLIRT SO CALL TO ILL CAUSES ILLEGAL CHARS IN DATA
		TO BE SET TO ZERO AND NOT SKIP VALID FOLLOWING CHARS
465	17142	FIX %NMLST TO INPUT STRINGS INTO DOUBLE PRECISION AND
		COMPLEX VARIABLES CORRECTLY.
476	17725	FIX G FORMAT WHEN FIELD TOO SMALL UNLESS 4X REMOVED.
517	18268	FIX F2.0 TO NEVER PRINT JUST A DOT.
533	19239	FIX %LSTDR TO CORRECTLY INPUT STRINGS INTO DOUBLE
			PRECISION NUMBERS.
534	19239	FIX %NMLST FOR INPUT OF STRINGS INTO ARRAYS
541	19793	FIX %NMLST FOR LIST-DIRECTED INPUT OF QUOTED STRINGS
			INTO ARRAYS WILL CLEAR F%QOT
544	12882	MAKE  P SCALING WORK WITH F FORMAT FOR NUMBERS
			WHICH ARE IDENTICALLY ZERO
563	(V5)	MAKE F FORMAT USE BOTH WORDS FOR DOUBLE PRECISION
			(%FLIRT AND %FLOUT)
566	Q00569	PRINT ZERO EXPONENT FOR IDENTICAL ZERO, D OR E
			FORMAT (%FLOUT)
574	Q00654	LIST DIRECTED INPUT OF COMPLEX NUMBERS SHOULD
		REQUIRE PARENTHESIS AROUND THE ARGUMENT, AND
		IF THERE IS A REPEAT COUNT IT SHOULD BE DELIMITED
		BY AN ASTERISK.
575	18964	LIST-DIRECTED I/O DOES NOT PROPERLY HANDLE S-LISTS
			WITH INCREMENTS NOT EQUAL TO ONE.
576	18964	LIST DIRECTED INPUT DOES NOT PROPERLY HANDLE S-LISTS
		WITH INCREMENTS OTHER THAN ONE.

	BEGIN VERSION 5A, 7-NOV-76

622	QA873	NAMELIST PARTIAL ARRAYS AT END OF LIST

***** Begin Version 5A *****

652	22508	EXPONENT FIELDS SHOULD ACCEPT LOWER CASE D AND E
653	22543	ACCEPT LOWER CASE T AND F FOR TRUE AND FALSE
654	-----	FIX FLIRT TO HANDLE ALL INTEGERS CORRECTLY AND
		FIX NAMELIST TO STORE DATA TYPE IN LOW CORE
660	-----	FIX %FLOUT TO USE 8 NOT 9 AS MAX NUMBER OF MANTISSA
		  DIGITS TO PRINT ON SINGLE PRECISION SO 5.55 IN F20.17
		  WON'T PRINT AS 5.55000001...
		NULLIFIED IN VERSION 6 - THE SINGLE PRECISION REPRESENTATION
		  OF 5.55 IS 5.55000001. IF THE USER WANTS MORE DIGITS THAN
		  THE "ACCURACY" OF THE MACHINE, WE WILL PRINT WHAT IS
		  THERE, SO AS TO PRINT ENOUGH PRECISION TO HAVE
		  ABSOLUTE DIFFERENTIATION BETWEEN NUMBERS (I.E., SO THAT
		  OUTPUT FOLLOWED BY INPUT WILL ALWAYS YIELD THE SAME
		  INTERNAL REPRESENTATION).
673	22607	IMPLEMENT VBL WIDTH DOUBLE PRECISION OCTAL I/O.

***** Begin Version 5B *****

735	24788	FIX EDIT 673 FOR KA SO THAT NEXT WORD IS NOT OVERWRITTEN
		WHEN DOING SINGLE PRECISION OCTAL INPUT
740	24891	FIX LIST-DIRECTED/NAMELIST OUTPUT TO SET G FORMAT
		FLAG BEFORE CALLING %REAL ON EACH PART OF COMPLEX VBL
756	25638	USE DEFAULT F FORMAT TO COUNT THE NO. OF ZEROS AFTER DECIMAL
		POINT WHEN THE NUMBER IS TOO SMALL TO PRINT.
761	11923	FIX EDIT 654 TO HANDLE INPUT INTEGERS CORRECTLY IN %FLIRT.
764	26523	IN %NMLST, CHECK FOR NULL FIELDS WITH LIST DIRECTED INPUT
		OF LOGICAL VARIABLE.
770	26836	FIX %NMLST TO HANDLE THE NAMELIST COMPLEX ARRAYS CORRECTLY


	BEGIN VERSION 6

	REWORK ALL CONVERSION ROUTINES SO THEY HAVE SEPARATE
	INPUT AND OUTPUT ENTRY POINTS WITH COMMON SETUP ROUTINES.
	SEPARATED R-FORMAT CODE FROM A-FORMAT CODE, BUT USED
	COMMON SETUP ROUTINES.

	REDUCED NUMBER OF ACCUMULATORS USED BY FLIRT AND FLOUT,
	AND REWORKED ALL CONVERSION ROUTINES TO USE VERSION 6
	ACCUMULATOR CONVENTIONS.

	INSTALLED EXTENDED EXPONENT HANDLING IN FLIRT, FLOUT,
	AND NAMELIST/LIST-DIRECTED I/O. INSTALLED SPARSE POWER
	OF TEN IN POWTAB FOR USE WITH EXTENDED EXPONENT.

	INCREASED NUMBER OF ENTRY POINTS IN FLOUT, AND
	THEREBY MADE G-FORMAT FLAG, E-FORMAT FLAG, AND D-FORMAT
	FLAG LOCAL TO FLOUT (ALTHOUGH THEY ARE STILL DEFINED
	IN FORPRM).

	MADE ALL NUMBER-HANDLING IN FLIRT/FLOUT DOUBLE-PRECISION,
	THUS ELIMINATING EXTRA SINGLE-PRECISION CODE, INCREASING
	ACCURACY OF SINGLE PRECISION NUMBERS, AND INCREASING
	TIME SPENT BY 1% OR SO.

	COMPLETELY REWROTE ROUNDING ALGORITHM, USING 9'S DIGIT
	COUNTER INSTEAD OF ADDING (INACCURATE) AMOUNTS FROM
	A ROUNDING TABLE.

	REMOVED OPTIONAL LEADING ZERO FROM FLOUT, THEREBY REMOVING
	A GREAT DEAL OF EXCESS CODE.

	IMPLEMENTED VARIABLE-SIZE EXPONENT WIDTH, INCLUDING
	LEAVING OFF 'D' OR 'E' IF EXPONENT IS TOO BIG.

	IMPLEMENTED S,SP,SS,BN,BZ FORMATS, AS WELL AS Iw.m AND Ow.m.

	MOVED ALL FREE-FORMAT HANDLING (SCANNING FOR DELIMITERS, ETC)
	OUT OF CONVERSION ROUTINES INTO THE FORMAT PROCESSOR,
	NAMELIST/LDIO, AND %SKIP.


????	???	??-???-80	Q10-04560
	FIXED ERROR CALL IN NAMELIST/LDIO AT SETNUL. SHOULD HAVE
	BEEN %ILCHR, WAS %ILCH1, ARROW WAS OFF BY 1.

1153	JLC	9-Sep-80	---------
	SPED UP ALPHI/ALPHO BY REMOVING SOME COMMON CODE,
	REMOVING CALL TO %SAVE2.

1154	JLC	9-Sep-80	---------
	FIX TO INTI FOR OVERFLOW - OUTPUTS OVERFLOW MSG
	AND SETS VALUE TO HIGHEST INTEGER.

1155	JLC	9-Sep-80	---------
	FIX FLOUT TO TURN OFF BIT 0 OF 2ND WORD TO
	PREVENT INTEGER OVERFLOWS FROM FLOUT.

1156	JLC	26-Sep-80	---------
	NAMELIST WAS NOT INSISTING ON BEGINNING
	'$' BEING IN COLUMN 2 AFTER SKIPPING DATA. IT WAS
	ALSO EATING THE BEGINNING '$' OF A NAMELIST WHILE
	TRYING TO READ THROUGH GARBAGE RECORDS IF THE GARBAGE
	HAD A ENDING '$' FROM A PREVIOUS ABORTIVE NAMELIST READ

1163	JLC	23-Oct-80	---------
	FIXED R-FORMAT INPUT

1172	JLC	2-Dec-80	Q20-01318
	DPFLG WAS NOT GETTING CLEARED IN ALPHI/ALPHO.

1314	EDS	4-Mar-81	Q20-01392
	Change NAMELIST input to ignore anything in column 1 of the
	data stream under a feature test switch FTNLC1.  Change
	NAMELIST output to terminate with $END.

1347	DAW	16-Mar-81
	Patch to allow FLIRT. to run in extended addressing, also
	changes to list-directed I/O routines.

1371	JLC	27-Mar-81
	Make zero-trip I/O loops work for list-directed I/O

1440	DAW	17-Apr-81
	Some extended addressing support.

1446	DAW	22-Apr-81
	Rework NMLST code to not smash P4 in a lower-level routine;
	fixes bug caused by edit 1440.

1464	DAW	12-May-81
	Error messages.

1470	CKS	22-May-81	Q20-1360
	Fix overflow in FLOUT. Incrementing double integer didn't check
	for carry between words.

1514	JLC	8-Jun-81
	Fix several bugs in NAMELIST code (subscript out of range),
	added code to accept rest of array if data specifies array
	reference, fixed column 1 skip feature test code.

1521	JLC	26-Jun-81
	Change EOF processing so it doesn't use D%EOF to check.
	Instead check D%END and IRCNT(D).LE.0.

1522	JLC	01-Jul-81
	Fix R format output to match R format input. For width
	greater than 5, bit 0 of low-order word is still 0, and
	excess characters are right justified in the high-order
	word.

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

1557	JLC	24-Jul-81
	FLOUT uses double precision for everything. Therefore
	output the same number of digits maximum (20) if the
	program asks for them.

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

1606	DAW	13-Aug-81
	Fix right-justified output of one-word items.

1625	DAW	21-Aug-81
	Get rid of "DF".

1626	DAW	24-Aug-81
	Change AC names in FLIRT and FLOUT so "D" is not defined there.

1644	JLC	27-Aug-81
	Make free-format A stop on comma. Change R*<space>C to
	be R*C, at least for version 6. Leave code to make it
	R*,C in repeat 0 in case the ANSI Committee makes a
	firm decision.

1662	DAW	4-Sep-81
	%CALU; user error handling routine.

1710	JLC	14-Sep-81
	Fixed problems with delimiter in namelist/ldio.

1733	BL	22-Sep-81
	Problem finding beginning of NAMELIST.

1736	JLC	23-Sep-81
	Fix to edit 1733.

1740	JLC	23-Sep-81
	Added check for legal delimiter at end of scan for
	namelist and list-directed I/O.

1745	JLC	24-Sep-81
	Fixed "r*,", was skipping over the comma.

2014	AHM/JLC	19-Oct-81
	Number of dimensions in a NAMELIST is now bits 2-8 for
	extended addressing compatability.
	Fixed illegal (too big) subscript in NAMELIST to give
	error.

2016	JLC	20-Oct-81
	Remove temporary one-trip in LDSET, now fixed in SLIST
	and ELIST.

2021	JLC	22-Oct-81
	Change ALPHI to substitute 5 or 10 for field width of 0,
	required by ANSI standard.

2024	DAW	26-Oct-81
	Make $ECALL ILC return to %ABORT - it's a fatal error now.

2032	JLC	29-Oct-81
	Fix KI code for DPMUL.

2033	JLC	19-Nov-81
	Pad R-format with spaces instead of nulls (like V5A).
	Make ILS error go to %ABORT if no ERR= branch.

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

2037	DAW	21-Dec-81
	NAMELIST input runs too slowly if a large array is read
	one element at a time.

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

3002	JLC	23-Oct-81
	Add character I/O to ALPHI and ALPHO.

3004	JLC	27-Oct-81
	Fix ALPHI - was not blank-filling character variables.

3010	JLC	2-Nov-81
	Merged fix from V6.

3012	JLC	4-Nov-81
	Fix character I/O for SLISTS - use some new parameters.

3017	AHM	6-Nov-81
	Make NAMELIST I/O assume that the address of the NAMELIST block
	was specified by an immediate argument.

3023	JLC	15-Nov-81
	Various V6 patches: blank-fill for R-format output, %ABORT call
	after illegal subscript in NAMELIST.

3036	BL	10-Feb-82
	Inserted code for list-directed I/O for character strings.

3040	JLC	11-Feb-82
	Make 0 written with G-format 0.000000E+00, as the ANSI Standard
	says so.

3044	BL	19-Feb-82
	Put NLCPTR in DATA, where it belongs. Initialize properly in
	NLINIT.

3045	BL	23-Feb-82
	Really initialize properly. see #3044.

3050	BL	25-Feb-82
	Install changes from code review (NAMELIST & LISTDIRECTED
	character I/O.

3056	JLC	23-Mar-82
	Separate FORCNV into FORCNV and FORNML (namelist and list-directed
	I/O). Inserted floating overflow and underflow messages in FLIRT.

3075	JLC	31-Mar-82
	Fix overflow/underflow messages in FLIRT and INTI.

3122	JLC	28-May-82
	Change error message calls, make FTAST a switchable flag
	instead of an assembly parameter.

3126	JLC	7-Jun-82
	Remove substitution of blank for null in ALPHO.

3136	JLC	26-Jun-82
	Performance work, fix GFLOAT bug in FLIRT which got overflow or
	underflow results for legal GFLOAT numbers in LDIO.

3143	AHM	6-Jul-82
	Correct AC field of the  XBLT at ALPBLT-3L that sets  extended
	hollerith arrays to spaces before doing input.

3144	AHM	6-Jul-82
	Mend fencepost  at ALPBLT-3L  which cleared  one location  too
	many in the user's array with an XBLT.

3150	JLC	13-Jul-82
	Fixed INTO so it leaves the user's specification of minimum
	number of digits for G-format.

3154	JLC	20-Jul-82
	Fix input of G-float numbers.

3165	JLC	28-Aug-82
	Fix INTI, OCTI, and HEXI so that free format read of
	just a sign returns 0 and does not go into infinite loop.

3166	JLC	30-Aug-82
	Fix to edit 3165 - minus signs were giving Illegal char in data.

3171	JLC	1-Sep-82
	Fix integer input, as edits 3165 and 3166 were slightly off.

3202	JLC	26-Oct-82
	Eliminate double printing of overflow message if exponent
	too large in FLIRT.

3203	JLC	31-Oct-82
	Fix SPCWD problem.

3253	JLC	12-Jan-83
	Fix %SKIP so it actually skips past end of record. Otherwise
	%SFDEL backs up over a real character.

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

3273	JLC	21-Feb-83
	Print * if the exponent including the E does not fit into
	the specified format.  Also, when SP is specified, print
	* if the + sign does not fit into the specified format.

3302	TGS	05-Mar-83
	Exponent-width check in Edit 3273 trashes AC2, can fail for
	Gfloat numbers with no exponent specified.

3342	TGS	16-Aug-83	SPR:10-34005
	Input of double-precision octal numbers whose high-order word
	is all zero will in effect swap words, placing the significant
	digits in the high-order word on output.  


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

4010	JLC	14-Apr-83
	Enlarge the power of ten table so that non-gfloat numbers
	will never have to do more than 1 scaling multiplication.
	Modify FLIRT and FLOUT accordingly.

4016	JLC	22-Jun-83
	Put SEGMENT CODE before PRGEND so literals will be in high
	segment.

4023	JLC	29-Jun-83
	Make overflows and underflows user-fixable. Use global
	variables for BZ and SP format flags.

4034	JLC	19-Jul-83
	Remove extraneous, erroneous instruction from OCTO
	field width overflow code.

4036	JLC	3-Aug-83
	Make "field width too small" asterisks user-modifiable,
	by providing a character descriptor pointing to the
	asterisks in the FOROTS record buffer.

4043	JLC	15-Sep-83
	Move FLIRT, INTI/INTO, HEXI/HEXO, OCTI/OCTO and POWTB
	to MTHLIB.

4111	JLC	15-Mar-84
	Changed the default leading zero output to LZALWAYS.

4113	JLC	23-Mar-84
	Fix LZALWAYS, did not mix well with SP format.

4166	MRB	15-NOV-84
	Change the way ALPNIN was creating a word of spaces. It was 
	under the impresstion that the internal bite-size was the 
	same as the external byte-size. Internal bytesize is always
	7. 

4201	JLC	29-Jan-85
	Fix FLOUT so that -1PE10.1 "works": it used to output an
	extra zero after the decimal point. Insert some code to handle
	rounding up the zero preceding the decimal point if there
	are no trailing digits.

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

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

	PRGEND
	TITLE	ALPHA	ALPHANUMERIC INPUT/OUTPUT ROUTINES 
	SUBTTL	D. TODD/DRT/HPW/MD		28-Oct-81
	SEARCH	MTHPRM,FORPRM




;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, 1987
;ALL RIGHTS RESERVED.

;FROM LIB40 %4(354)

	SEGMENT	CODE

	ENTRY	%ALPHI,%ALPHO,%RIGHI,%RIGHO
	EXTERN	%IBYTE,%OBYTE,%FWVAL
	EXTERN	IO.ADR,IO.SIZ,IO.TYP,%SAVE2
	EXTERN	%SIZTB,%IMBYT,%OMBYT,%OMSPC
	EXTERN	%CIPOS,IO.INS,IO.NUM,IO.INC,ENC.LR

DPFLG==1

%ALPHI:	MOVE	T1,IO.TYP	;GET DATA TYPE
	CAIE	T1,TP%CHR	;CHARACTER?
	 JRST	ALPNIN		;NO. NUMERIC
	PUSHJ	P,ALPCHR	;DO CHARACTER SETUP
	MOVE	T1,ALPSIZ	;USE FULL ENTRY SIZE, AS FILL IS NEEDED
	MOVEM	T1,ALPBYT
AICOM:	MOVE	T2,ALPSIZ	;GET FULL ENTRY SIZE IN BYTES
	MOVE	T1,ALPWID	;GET FORMAT WIDTH
	CAMG	T1,T2		;WIDTH .GT. SIZE?
	 JRST	AIMAT		;NO. GO MOVE AND FILL
	SUB	T1,T2		;GET # CHARS TO SKIP
	PUSHJ	P,%CIPOS	;SKIP THEM
	MOVE	T0,ALPBYT	;USE DEST COUNT FOR LEFTOVER SOURCE COUNT
	JRST	AIMOVE

AIMAT:	MOVE	T0,ALPWID	;GET # CHARS TO TRANSFER
AIMOVE:	MOVE	T3,ALPBYT	;GET DESTINATION SIZE
	MOVE	T4,ALPNTR	;AND DEST POINTER
	PUSHJ	P,%IMBYT	;MOVE THE STRING
	SKIPN	T1,ALPLI	;ANY LOCAL INCREMENT?
	 JRST	AINLI		;NO
	XCT	ALPINS		;YES. INCREMENT THE POINTER
	MOVEM	T1,ALPNTR	;SAVE IT BACK
	SOSLE	ALPLC		;DECR LOCAL COUNT
	 JRST	AICOM		;MORE TO GO
AINLI:	SKIPN	T1,ALPINC	;GET TOTAL INCREMENT
	 POPJ	P,		;NONE
	XCT	IO.INS		;INCREMENT DATA POINTER
	MOVEM	T1,IO.ADR	;SAVE IT BACK
	MOVN	T1,ALPNEN	;GET NUMBER OF EXTRA ENTRIES PROCESSED
	ADDM	T1,IO.NUM	;DECR NUMBER ENTRIES
	ADDM	T1,ENC.LR	;DECR FORMAT REPEAT COUNT
	POPJ	P,

ALPNIN:	PUSHJ	P,ALPNUM	;SET VARIABLES FOR NUMERIC ENTRIES
	MOVE	T1,ALPSIZ	;GET DESTINATION SIZE
	CAMLE	T1,ALPWID	;BIGGER THAN FORMAT WIDTH?
	 MOVE	T1,ALPWID	;YES. USE WIDTH
	MOVEM	T1,ALPBYT	;AS # INPUT BYTES, AS NO PAD NEEDED
	MOVE	T1,[ASCII/     /] ;[4166]GET A WORD OF SPACES
	MOVEM	T1,@IO.ADR	;INITIALIZE 1ST DATA WORD
	MOVE	T2,ALPNEL	;GET # WORDS TO INIT
	CAIG	T2,1		;MORE THAN 1?
	 JRST	AICOM		;NO. JUST MOVE THE STRING
	MOVE	T3,IO.ADR	;YES. GET THE SOURCE ADDR
	TLNN	T3,-1		;NON-ZERO SECTION?
	 JRST	ALPBLT		;NO. USE STANDARD BLT
	SUBI	T2,1		;[3144] One word has already been cleared
	XMOVEI	T4,1(T3)	;DEST IS C(IO.ADR)+1
	EXTEND	T2,[XBLT]	;[3143] Init the array
	JRST	AICOM		;JOIN COMMON CODE

ALPBLT:	ADDI	T2,(T3)		;GET FINAL ADDR+1
	HRLI	T3,(T3)		;GET SOURCE ADDR
	ADDI	T3,1		;GET DEST ADDR
	BLT	T3,-1(T2)	;INIT THE ARRAY
	JRST	AICOM


%ALPHO:	MOVE	T1,IO.TYP	;GET DATA TYPE
	CAIN	T1,TP%LIT	;LITERAL STRING?
	 JRST	ALPLOU		;YES. TAKE THE SLOW BOAT
	CAIE	T1,TP%CHR	;CHARACTER?
	 JRST	ALPNOU		;NO. NUMERIC
ALPCOU:	PUSHJ	P,ALPCHR	;DO CHARACTER SETUP
AOCOM:	MOVE	T2,ALPSIZ	;GET ENTRY SIZE
	MOVE	T3,ALPWID	;GET FORMAT WIDTH
	CAMG	T3,T2		;WIDTH .GT. SIZE?
	 JRST	AOTRUN		;NO. GO MOVE AND TRUNCATE IF NECESSARY
	SUB	T3,T2		;GET # CHARS TO SKIP
	PUSHJ	P,%OMSPC	;FILL WITH SPACES
	MOVE	T0,ALPSIZ	;AND PROCEED WITH MOVING STRING
	JRST	AOMOVE

AOTRUN:	MOVE	T0,ALPWID	;USE FORMAT WIDTH
AOMOVE:	MOVE	T1,ALPNTR	;GET DATA POINTER
	PUSHJ	P,%OMBYT	;MOVE STRING
	SKIPN	T1,ALPLI	;ANY LOCAL INCREMENT?
	 JRST	AONLI		;NO
	XCT	ALPINS		;YES. INCREMENT THE POINTER
	MOVEM	T1,ALPNTR	;SAVE IT BACK
	SOSLE	ALPLC		;DECR LOCAL COUNT
	 JRST	AOCOM		;MORE TO GO
AONLI:	SKIPN	T1,ALPINC	;GET TOTAL INCREMENT
	 POPJ	P,		;NONE
	XCT	IO.INS		;INCREMENT DATA POINTER
	MOVEM	T1,IO.ADR	;SAVE IT BACK
	MOVN	T1,ALPNEN	;GET NUMBER OF EXTRA ENTRIES PROCESSED
	ADDM	T1,IO.NUM	;DECR NUMBER ENTRIES
	ADDM	T1,ENC.LR	;DECR FORMAT REPEAT COUNT
	POPJ	P,

ALPNOU:	PUSHJ	P,ALPNUM	;SETUP FOR NUMERIC DATA
	JRST	AOCOM		;JOIN COMMON CODE

;LITERAL OUTPUT - SCAN THE SOURCE STRING FOR A NULL, COUNTING
;THE CHARACTERS. THEN CREATE A STRING DESCRIPTOR, AND JOIN THE
;CHARACTER CODE ABOVE.
ALPLOU:	MOVE	T1,IO.ADR	;GET ADDRESS
	$BLDBP	T1		;BUILD A BYTE POINTER TO IT
	MOVEM	T1,IO.ADR	;SAVE IT BACK FOR LATER
	SETZ	T2,		;CLEAR A CHAR COUNT
LOULP:	ILDB	T3,T1		;GET A CHAR
	JUMPE	T3,LOUEND	;NULL. WE'RE DONE COUNTING
	AOJA	T2,LOULP	;NOT. COUNT IT

LOUEND:	MOVEM	T2,IO.SIZ	;SAVE SIZE
	JRST	ALPCOU		;GO TO CHARACTER OUTPUT


ALPCHR:	MOVE	T1,IO.SIZ	;GET ENTRY SIZE
	MOVEM	T1,ALPSIZ	;SAVE IT
	PUSHJ	P,CHKOPT	;CHECK FOR POSSIBLE OPTIMIZATIONS
	MOVE	T1,IO.ADR	;GET BYTE PNTR
	MOVEM	T1,ALPNTR	;SAVE IT
	MOVE	T1,[ADJBP T1,ALPNTR] ;GET PNTR INCR INSTRUCTION
	MOVEM	T1,ALPINS	;SAVE IT FOR LOOP
	POPJ	P,

ALPNUM:	MOVE	T1,IO.SIZ	;GET ENTRY SIZE IN WORDS
	IMULI	T1,IBPW		;GET IT IN BYTES
	MOVEM	T1,ALPSIZ	;SAVE IT
	PUSHJ	P,CHKOPT	;CHECK FOR POSSIBLE OPTIMIZATIONS
	MOVE	T1,IO.ADR	;GET DATA ADDR
	$BLDBP	T1		;BUILD A BYTE POINTER
	MOVEM	T1,ALPNTR	;SAVE IT
	MOVE	T1,[ADD	T1,ALPNTR] ;GET ADDR INCR INSTRUCTION
	MOVEM	T1,ALPINS	;SAVE IT FOR LOOP
	POPJ	P,

CHKOPT:	MOVE	T1,%FWVAL	;GET FORMAT WIDTH
	JUMPN	T1,GOTAWD	;DEFAULT TO ENTRY SIZE IF ZERO
	MOVE	T1,ALPSIZ
GOTAWD:	MOVEM	T1,ALPWID	;SAVE IT
	MOVE	T1,IO.SIZ	;GET ELEMENT SIZE
	CAME	T1,IO.INC	;SAME AS INCREMENT?
	 JRST	NOOPT		;NO. SHOULDN'T OPTIMIZE
	MOVE	T1,IO.NUM	;GET # ENTRIES BEING PROCESSED
	CAIG	T1,1		;USEFUL TO OPTIMIZE?
	 JRST	NOOPT		;NO
	MOVE	T2,ENC.LR	;GET # ENTRIES FOR THIS FORMAT ATOM
	CAIG	T2,1		;USEFUL TO OPTIMIZE?
	 JRST	NOOPT		;NO
	CAMLE	T1,T2		;GET SMALLER OF THE TWO
	 MOVE	T1,T2
	MOVEM	T1,ALPLC	;SAVE AS LOCAL ENTRY COUNT
	SUBI	T1,1		;CALC # EXTRA ENTRIES BEING PROCESSED
	MOVEM	T1,ALPNEN	;SAVE IT
	IMUL	T1,IO.SIZ	;GET # WORDS/CHARS TO COMBINE
	MOVEM	T1,ALPINC	;SAVE TOTAL INCREMENT
	ADD	T1,IO.SIZ	;RESTORE TO FULL ELEMENT COUNT
	MOVEM	T1,ALPNEL	;SAVE # WORDS/CHARS
	MOVE	T1,ALPWID	;GET FORMAT WIDTH
	CAME	T1,ALPSIZ	;SAME AS ELEMENT SIZE?
	 JRST	OPTONE		;NO. ONE BY ONE CASE
	MOVE	T1,ALPLC	;GET # ENTRIES AGAIN
	IMULB	T1,ALPWID	;CALCULATE # CHARS, MAKE IT WIDTH
	MOVEM	T1,ALPSIZ	;SAVE AS HUGE SIZE
	SETZM	ALPLI		;NO LOCAL INCREMENT
	SETZM	ALPLC		;NO LOCAL COUNT
	POPJ	P,

OPTONE:	MOVE	T1,IO.INC	;USE GIVEN INCREMENT
	MOVEM	T1,ALPLI	;AS LOCAL ONE
	POPJ	P,

NOOPT:	SETZM	ALPNEN		;NO EXTRA ENTRIES BEING PROCESSED
	SETZM	ALPINC		;NO TOTAL INCREMENT
	SETZM	ALPLC		;NO LOCAL COUNT
	SETZM	ALPLI		;AND NO LOCAL INCREMENT
	MOVE	T1,IO.SIZ	;GET # ELEMENTS/ENTRY
	MOVEM	T1,ALPNEL	;SAVE AS WORDS/CHARS PROCESSED
	POPJ	P,

;ROUTINES TO RIGHT JUSTIFY ASCII STRING IN THE USER'S NUMERIC VARIABLE
;CHARACTER VARIABLES ILLEGAL
%RIGHI:	PUSHJ	P,ALPSET	;DO GENERAL SETUP
	MOVE	T2,IO.ADR	;GET THE VARIABLE ADDR
	JUMPG	T5,RI1		;WIDTH SPECIFIED
	 MOVEI	T5,(T4)		;NO-SET DEFAULT
RI1:	SUBI	T4,(T5)		;GET NEG FILL NEEDED
	JUMPGE	T4,RIGHI1	;NO SKIP IF .GE. 0
	ADD	T5,T4		;THERE IS FILL. SET WIDTH TO MAX DEFAULT
RIGHI0:	PUSHJ	P,%IBYTE	;EXCESS W SKIP INPUT CHARACTERS
	AOJL	T4,RIGHI0	;CONTINUE SKIPPING
RIGHI1:	SETZB	T3,T4		;CLEAR THE RECEIVING WORD
RIGHI2:	LSHC	T3,^D7		;SHIFT A CHARACTER
	PUSHJ	P,%IBYTE	;READ A CHARACTER
	IOR	T4,T1		;INSERT THE CHARACTER
	SOJG	T5,RIGHI2	;CONTINUE
	LSHC	T3,1		;CLEAR THE LOW ORDER SIGN BIT
	LSH	T4,-1		;AND POSITION
	MOVEM	T4,(T2)		;STORE THE LOW ORDER WORD (SINGLE)
	TXNE	F,DPFLG		;DOUBLE PRECISION?
	 DMOVEM	T3,(T2)		;STORE BOTH WORDS (DOUBLE)
	POPJ	P,		;RETURN

%RIGHO:	PUSHJ	P,ALPSET	;DO GENERAL SETUP
	SETZ	T2,		;CLEAR HIGH ORDER WORD
	MOVE	T3,@IO.ADR	;GET LOW WORD
	TXNE	F,DPFLG		;BUT IF DOUBLE PRECISION
	 DMOVE	T2,@IO.ADR	;GET BOTH WORDS
	LSH	T3,1		;PUSH LOW WORD TO BIT 0
	TXNE	F,DPFLG		;If double-precision,
	 LSHC	T2,1		;PUSH BOTH WORDS TO BIT 0
	JUMPG	T5,RO1 		;SPECIFIED
	 MOVEI	T5,(T4)		;NO-SET DEFAULT
RO1:	SUBI	T4,(T5)		;GET NEG FILL NEEDED

;Note: T5= # chars to output
;	T4= 0 if output (T5) chars
;	T4= positive if first chars must be skipped
;	T4= negative if not enough chars (pad with spaces)

	JUMPGE	T4,INCPT	;IF NO FILL, TRY SKIP
	ADD	T5,T4		;SET DATA WIDTH TO DEFAULT
	MOVEI	T1," "		;OUTPUT SPACES FOR SKIP WIDTH
RIGHO1:	PUSHJ	P,%OBYTE	;OUTPUT THE SPACE
	AOJL	T4,RIGHO1	;LOOP FOR SKIP WIDTH
INCPT:	JUMPLE	T4,ROLP1	;IF NO SKIP, GO OUTPUT CHARS
RIGHO2:	LSHC	T2,7		;TOSS THE CHARACTER
	SOJG	T4,RIGHO2
ROLP1:	TXNN	F,DPFLG		;If single precision,
	 MOVE	T2,T3		;Get correct word to output
ROLP2:	ROTC	T2,7		;ROTATE CHAR INTO T3
	MOVEI	T1,(T3)		;COPY THE CHAR (WITH TRASH)
	ANDI	T1,177		;TOSS THE TRASH
RONN:	PUSHJ	P,%OBYTE	;OUTPUT THE CHAR
	SOJG	T5,ROLP2
	POPJ	P,		;RETURN TO FOROTS
;Routine to setup for alphabetic conversions
ALPSET:	MOVEI	T4,5		;ASSUME SINGLE PRECISION
	MOVE	T5,%FWVAL	;GET THE WIDTH FIELD
	MOVE	T1,IO.TYP	;GET THE VARIABLE TYPE
	MOVE	T1,%SIZTB(T1)	;GET ENTRY SIZE
	ASH	T4,-1(T1)	;IF DP, MUL # CHARS BY 2
	CAIN	T1,2		;DOUBLE?
	 TXOA	F,DPFLG		;YES. SET FLAG
	TXZ	F,DPFLG		;NO. CLEAR IT
	POPJ	P,


	SEGMENT	DATA

ALPLI:	BLOCK	1		;LOCAL PNTR INCREMENT
ALPLC:	BLOCK	1		;LOCAL ENTRY COUNT
ALPNEN:	BLOCK	1		;NUMBER OF EXTRA ENTRIES PROCESSED
ALPINS:	BLOCK	1		;LOCAL PNTR INCREMENT INSTRUCTION
ALPINC:	BLOCK	1		;LOCAL INCREMENT
ALPNEL:	BLOCK	1		;# WORDS OR CHARS BEING PROCESSED
ALPSIZ:	BLOCK	1		;LOCAL ENTRY SIZE IN BYTES
ALPBYT:	BLOCK	1		;FOR INPUT, # CHARS TO TRANSFER
ALPWID:	BLOCK	1		;LOCAL FORMAT WIDTH
ALPNTR:	BLOCK	1		;BYTE POINTER TO VARIABLE

	SEGMENT	CODE

	PRGEND
	TITLE	FLOUT 	FLOATING POINT OUTPUT 
	SUBTTL	D. NIXON AND T. W. EGGERS
	SUBTTL	D. TODD /DMN/DRT/HPW/MD/JNG/CLRH/CYM	28-Oct-81
	SUBTTL	JLC - VERSION 6
	SEARCH	MTHPRM,FORPRM



;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, 1987
;ALL RIGHTS RESERVED.

	SEGMENT	CODE

	AC0==T0		;FLOATING POINT NO. ON ENTRY
	AC1==T1		;USED IN FORMING DIGITS
	AC2==T2		;DITTO. D.P. ONLY
	AC3==T3		;EXTENDED EXPONENT ONLY
	AC4==T4
	AC5==T5
	C==T4		;CNTR./NO. OF CHARS BEFORE DEC. POINT
	XP==T5		;DECIMAL EXPONENT
	SF==P4		;SCALE FACTOR
	

	NUMSGN==1	;NEGATIVE NUMBER
	NOSIGN==4	;NO SPACE FOR + SIGN
	EQZER==10	;ITEM IS IDENTICALLY ZERO
	DPFLG==20	;VARIABLE IS DOUBLE PRECISION
	EEFLG==40	;VARIABLE IS EXTENDED EXPONENT DOUBLE PRECISION
	NOEFLG==100	;DO NOT PRINT "D" OR "E" IN EXPONENT
	NOPNT==200	;DO NOT PRINT THE DECIMAL POINT (FOR FTAST=0)

	LOCFLG==NUMSGN+NOSIGN+EQZER+DPFLG+EEFLG+NOEFLG

	SPMAX==^D20
	DPMAX==^D20	;MAXIMUM NUMBER OF DIGITS TO PRINT
			;IF WE PRINT ANY MORE, WE WILL BE LYING TO THE
			;USER, AS THIS IS THE MAXIMUM PRECISION OF
			;OUR SCALING FACTORS OF 10.
			;WE CANNOT KNOW WHETHER THE NUMBER WE
			;HAVE IN THE MACHINE IS AN EXACT REPRESENTATION
			;OF WHATEVER WAS INPUT - WE MUST ASSUME THAT
			;WHAT IS IN THE MACHINE IS EXACTLY WHAT IS DESIRED.
			;THEREFORE THERE IS NO REASON NOT TO GIVE AS MANY
			;DIGITS AS ARE ACCURATE. THE ONLY LIMITATION ON
			;THIS CURRENTLY IS THE SCALING ALGORITHM.

	LZALWAYS==1	;SWITCH FOR ALWAYS PRINTING LEADING ZEROES
	LZSOME==0	;SWITCH FOR SOMETIMES - ALWAYS EXCEPT WHEN
			;POSITIVE NUMBER IS PRINTED WITH ONLY ONE LEADING
			;SPACE
	ENTRY	%FLOUT,%DOUBT,%GROUT,%EOUT
	ENTRY	%EEMUL,%EEDIV,%EENRM
	EXTERN	%OBYTE,%EXP10,%HITEN,%LOTEN,%PTMAX
	EXTERN	%FWVAL,%DWVAL,%XPVAL
	EXTERN	IO.ADR,IO.TYP,%FLINF,%SCLFC,%SAVE4,%FTAST,%FTSLB,%SPFLG
	EXTERN	%SIZTB,%BEXP,%DEXP,%PMEXP
	EXTERN	%FTSUC

;INSTEAD OF HAVING MANY GLOBAL FLAGS PASSED TO FLOUT, THERE ARE
;SEVERAL ENTRY POINTS WHICH SET FLAGS LOCAL TO THE ROUTINE.

%DOUBT:	TXZ	F,F%GTP+F%ETP		;NOT G OR E FORMAT
	TXO	F,F%DTP			;FLAG TO PRINT A "D"
	JRST	REALO

%GROUT:	TXZ	F,F%DTP+F%ETP		;TRY WITHOUT SCIENTIFIC NOTATION
	TXO	F,F%GTP
	JRST	REALO

%EOUT:	TXZ	F,F%GTP+F%DTP		;TURN OFF THE OTHER FLAGS
	TXO	F,F%ETP			;FLAG TO PRINT AN "E"
	JRST	REALO

%FLOUT:	TXZ	F,F%GTP+F%ETP+F%DTP
REALO:	PUSHJ	P,%SAVE4		;SAVE P1-P4
	TXZ	F,LOCFLG	;CLEAR LOCAL FLAGS IN F
	MOVE	AC1,IO.TYP	;GET VARIABLE TYPE
	MOVE	AC2,%SIZTB(AC1)	;GET ENTRY SIZE
	CAIN	AC2,2		;IS VARIABLE DOUBLE PRECISION?
	TXO	F,DPFLG		;YES. SET FLAG
	CAIN	AC1,TP%DPX	;EXTENDED EXPONENT?
	TXO	F,EEFLG		;YES. SET FLAG
	MOVE	AC2,IO.ADR	;GET VARIABLE ADDR
	MOVE	AC0,(AC2)	;LOAD AC 0 WITH NUMBER
	SETZ	AC1,		;CLEAR LOW WORD
	TXNE	F,DPFLG		;DOUBLE PRECISION?
	MOVE	AC1,1(AC2)	;YES, GET LOW WORD ALSO
	TLZ	AC1,(1B0)	;ELIMINATE GARBAGE SIGN BIT
	SETZ	XP,		;CLEAR EXPONENT
	JUMPGE	AC0,FLOUT1	;NUMBER NEGATIVE?
	DMOVN	AC0,AC0		;YES. NEGATE IT
	TXO	F,NUMSGN	;AND - SET SIGN FLAG

;THE INTENTION IN THE CODE FOLLOWING IS TO LEFT-JUSTIFY THE MANTISSA
;AFTER EXTRACTING THE BINARY EXPONENT, AND THEN TO "SCALE" THE NUMBER
;BY ONE OR MORE POWERS OF TEN SO THAT IT ENDS UP WITH VALUE LESS
;THAN 1.0 BUT GREATER THAN OR EQUAL TO 0.1, KEEPING TRACK OF THE
;POWERS OF TEN USED IN THE SCALING PROCESS. THESE POWERS OF TEN
;ARE ACCUMULATED INTO A DECIMAL EXPONENT, KEPT IN XP.
;
;EXTENDED EXPONENT NUMBERS WHICH REQUIRE A HUGE POWER OF TEN TO SCALE
;THEM DOWN (OR UP) ARE FILTERED THROUGH A SPECIAL ROUTINE WHICH USES
;A SPARSE POWER OF TEN TABLE TO BRING THE NUMBER INTO THE "NORMAL"
;RANGE.

FLOUT1:	JUMPN	AC0,FLONZ	;OK IF NON-ZERO
	JUMPE	AC1,FLOUT6	;ZERO IF BOTH ZERO
FLONZ:
	TXNN	F,EEFLG		;EXTENDED EXPONENT?
	JRST	FLOU1A		;NO
	PUSHJ	P,EEDEC		;YES. HANDLE SEPARATELY
	JRST	FLOUT2

FLOU1A:	HLRZ	P1,AC0		;EXTRACT EXPONENT
	LSH	P1,-9
	HRREI	P1,-200(P1)	;EXTEND SIGN
	TLZ	AC0,777000	;GET RID OF HIGH EXP
FLOUT2:	ADDI	P1,^D8		;EXPONENT IS 8 BIGGER ON NORM
	MOVE	AC3,AC0		;GET THE HI FRACTION
	JFFO	AC3,FLOU2A	;GET HI BIT
	EXCH	AC0,AC1		;NONE. SWAP LO AND HI
	SUBI	P1,^D35		;AND DECR BINARY EXPONENT
	MOVE	AC3,AC0		;GET NEW HI WORD
	JFFO	AC3,FLOU2A	;GET HI BIT
	JRST	FLOUT6		;NUMBER IS ZERO
FLOU2A:	ASHC	AC0,-1(AC4)	;NORMALIZE NUMBER
	SUBI	P1,-1(AC4)	;AND MODIFY BINARY EXPONENT
FLOU2B:	MOVE	P2,P1		;GET BINARY EXPONENT
	IMULI	P2,232		;DEC EXP=LOG10(2)*BIN EXP=.232(OCTAL)*BIN EXP
	ADDI	P2,400		;ROUND TO NEAREST INTEGER
	ASH	P2,-^D9		;GET RID OF 3 OCTAL FRACTION DIGITS
				;THE ABOVE WORKS FOR NEGATIVE EXPONENTS BECAUSE
				;THE ASH TRUNCATION EFFECTIVELY
				;ROUNDS UP IN THE NEGATIVE DIRECTION
				;FOR NEGATIVE VALUES

;P2 HOLDS A FIRST TRIAL DECIMAL EXPONENT. IT MAY BE
;ONE (BUT NO MORE) TOO SMALL TO DIVIDE THE BINARY NUM
;BY TO GET THE RANGE 1.0 .GT. NUM .GE. 0.1

FLOUT3:	MOVE	P3,%EXP10(P2)	;GET BIN EXP THAT MATCHES DEC EXP
	CAMLE	P3,P1		;FRACTION .GT. POWER OF 10?
	JRST	FLOT4A		;YES
	CAME	P3,P1
	AOJA	P2,FLOT4A	;NOT IN EXPONENT
	CAMGE	AC0,%HITEN(P2)	;
	JRST	FLOT4A		;YES, IN HIGH FRACTION
	CAMN	AC0,%HITEN(P2)
	CAML	AC1,%LOTEN(P2)
	ADDI	P2,1		;NO, IN FRACTION PART
FLOT4A:	PUSHJ	P,DPMUL		;SCALE BY POWER OF 10
	ASHC	AC0,(P1)	;SCALE BY ANY REMAINING POWERS OF 2
	TLO	T1,(1B0)	;PREVENT OVERFLOW
	ADDI	T1,1		;ROUND IT UP SOME MORE
	TLZN	T1,(1B0)	;CARRY INTO SIGN?
	  ADDI	T0,1		;YES, PROPAGATE TO HIGH WORD
FLOUT6:	MOVE	C,%FWVAL
	MOVE	T3,%DWVAL
	HRRE	SF,%SCLFC	;GET THE SCALING FACTOR
	JUMPN	AC0,FLOU6A	;IS NUMBER ZERO?
	TXO	F,EQZER		;YES. SET FLAG
	TXZ	F,NUMSGN	;AND CLEAR ANY SIGN!
	SETZ	XP,		;AND THE EXPONENT!
FLOU6A:	JUMPN	C,FLOUT7
	TXNE	F,DPFLG		;DOUBLE PRECISION?
	ADDI	C,1		;YES, INCREMENT INDEX INTO TABLE
	HRRZ	T3,FRMTAB(C)	;PICKUP DEFAULT FORMAT FOR DECIMAL WIDTH
	HLRZ	C,FRMTAB(C)	;SAME FOR WIDTH

;HERE IS THE FIRST G-FORMAT NUMBER FILTER. THE NUMBER IS CHECKED
;IF IT IS "PROPER MAGNITUDE" FOR G-FORMAT. IF THE MAGNITUDE OF THE
;NUMBER IS SMALLER THAN 10**D OR GREATER THAN OR EQUAL TO 0.1,
;THE NUMBER SHOULD BE PRINTED IN F-FORMAT. SINCE THE NUMBER HAS NOT
;BEEN ROUNDED YET, WE CHECK THE NUMBER JUST USING THE DECIMAL EXPONENT XP,
;AND ALLOW NUMBERS WITH XP GREATER THAN -1 (WHICH COULD INCLUDE
;NUMBERS LESS THAN 0.1). A SECOND CHECK IS DONE AT CHKRND, AFTER
;THE NUMBER HAS BEEN ENCODED, TO SEE IF ROUNDING FORCED THE NUMBER
;INTO OR OUT OF THE F-FORMAT RANGE.
FLOUT7:	TXNN	F,F%GTP		;G TYPE CONVERSION?
	JRST	FLOUT8		;NO
	TXNE	F,EQZER		;NUMBER ZERO?
	 JRST	CETYP		;YES. ANSI STANDARD SAYS IT'S E-FORMAT!
	CAML	XP,[-1]		;IF EXPONENT .LT. 1
	CAMLE	XP,T3		;OR .GT. # DECIMAL PLACES
CETYP:	TXOA	F,F%ETP		;SET E CONVERSION
	JRST	FLOUT8		;NOT E, JUMP

;HERE WE FIGURE OUT HOW MANY SIGNIFICANT DIGITS TO GET FROM THE
;NUMBER.  FOR G-FORMAT, THIS IS JUST "D" (AS IN W.D). FOR D AND
;E-FORMATS, IT DEPENDS ON THE SCALE FACTOR. FOR SCALE FACTORS
;LESS THAN ZERO, THE NUMBER OF DIGITS IS REDUCED BY THE SCALE
;FACTOR. FOR POSITIVE SCALE FACTORS, THE NUMBER OF DIGITS IS
;INCREASED BY ONE, UNLESS THE SCALE FACTOR IS MORE
;THAN ONE LARGER THAN THE NUMBER OF DECIMAL PLACES, IN WHICH
;CASE THE NUMBER OF DIGITS IS SET TO THE SCALE FACTOR ALONE.
;FOR F-FORMAT, THE SIZE OF THE NUMBER (DECIMAL EXPONENT) IS
;ADDED TO THE NUMBER OF DIGITS IN ADDITION TO THE SCALE
;FACTOR.
FLOUT8:	MOVE	P2,T3		;GET # DECIMAL PLACES
	TXNN	F,F%ETP!F%DTP	;D OR E FORMAT?
	JRST	FLOU8A		;NO
	JUMPLE	SF,FLOUT9	;IF NEG, JUST GO ADD SCLFCT
	CAILE	SF,1(T3)	;WITHIN DEFINED RANGE?
	MOVEI	P2,-1(SF)	;NO. SET TO SCLFCT
	ADDI	P2,1		;YES. JUST ADD 1
	JRST	FLOU10
FLOU8A:	TXNE	F,F%GTP		;G-FORMAT?
	JRST	FLOU10		;YES. WE'RE ALL DONE
	ADD	P2,XP		;NO. ADD MAGNITUDE OF NUMBER
FLOUT9:	ADD	P2,SF		;ADD SCLFCT TO # DIGITS DESIRED
FLOU10:	JUMPN	AC0,FLO10A	;IF NUMBER IS ZERO
	SETZ	P2,		;DON'T ENCODE ANY DIGITS
FLO10A:	CAILE	P2,DPMAX	;TOO MANY DECIMAL PLACES
	 MOVEI	P2,DPMAX	;YES, REDUCE TO MAX POSSIBLE
	TXNE	F,DPFLG		;DOUBLE PRECISION?
	 JRST	DIGOK		;YES
	CAILE	P2,SPMAX	;NO. RESTRICT TO SPMAX
	 MOVEI	P2,SPMAX
DIGOK:	MOVE	P1,P		;MARK BOTTOM OF DIGIT STACK
	PUSH	P,[0]		;AND ALLOW FOR POSSIBLE OVERFLOW
	SETZM	%FLINF		;CLEAR 9'S COUNTER
	MOVE	P3,P2		;GET # OF DIGITS
	JUMPLE	P2,CHKRND	;NO DIGITS WANTED.
FLOU12:	EXCH	AC0,AC1		;PUT HI WORD IN AC1
	MULI	AC1,^D10	;MUL HI WORD BY 10
	PUSH	P,AC1		;STORE DIGIT ON STACK
	MULI	AC0,^D10	;MUL LOW WORD BY 10
	TLO	AC0,(1B0)	;STOP OVERFLOW
	ADD	AC0,AC2		;ADD HI WORD BACK INTO AC0
	TLZN	AC0,(1B0)	;CARRY
	AOS	(P)		;YES, INCREMENT DIGIT ON STACK
	MOVE	AC2,(P)		;GET THE DIGIT
	CAIN	AC2,^D9		;IS IT A 9?
	AOSA	%FLINF		;YES. INCR 9'S COUNT
	SETZM	%FLINF		;NO. CLEAR 9'S COUNT
	SOJG	P3,FLOU12

;FOR G-FORMAT OUTPUT, THERE IS THE POSSIBILITY THAT ROUNDING THE
;NUMBER WILL MAKE IT TOO LARGE TO PRINT IN F-FORMAT, OR THAT NUMBERS
;THAT WE LET THROUGH AT FLOUT7 WILL NOT BE ROUNDED UP, AND WILL BE
;TOO SMALL TO PRINT IN F-FORMAT. THE FOLLOWING CODE CHECKS FOR
;THESE CONDITIONS, AND SETS THE E-FORMAT FLAG IF THE NUMBER IS TOO
;LARGE OR TOO SMALL. IF THERE IS A SCALE FACTOR INVOLVED, IT MODIFIES
;THE NUMBER OF DIGITS ENCODED - NEGATIVE SCALE FACTORS REDUCE THE
;NUMBER OF DIGITS ENCODED, WHILE POSITIVE SCALE FACTORS INCREASE THE
;NUMBER OF DIGITS ENCODED BY 1 DIGIT (OR IF THE SCALE FACTOR
;IS OUTSIDE THE DEFINED RANGE, MODIFIES THE NUMBER OF DIGITS ENCODED
;TO THE SCALE FACTOR).
CHKRND:	TXNE	F,F%GTP		;G-FORMAT?
	TXNE	F,F%ETP+F%DTP	;YES. D OR E?
	JRST	CHKRN2		;D OR E OR NOT G. LEAVE
	TLNE	AC0,(1B1)	;ROUNDING BIT ON?
	JRST	TEST9		;YES. TEST # 9'S
	JUMPL	XP,FGFIX	;NO. NG IF EXP STILL LOW
	JRST	FLOU13		;OTHERWISE OK
TEST9:	CAMN	P2,%FLINF	;IS 9'S COUNT SAME AS DIGITS?
	JRST	TESTXP		;YES. WE GOT OVERFLOW
	JUMPL	XP,FGFIX	;NO. NG IF EXPONENT STILL LOW
	JRST	DORND		;OTHERWISE WE'RE OK
TESTXP:	CAMGE	XP,T3		;IS UNINCREMENTED EXP TOO BIG?
	JRST	DORND		;NO. WE'RE OK

FGFIX:	TXO	F,F%ETP		;SET TO TYPE "E"
	JUMPE	SF,CHKRN2	;NO # DIGITS CHANGE IF SF=0
	JUMPG	SF,FGPOS	;NEED MORE IF SF.GT.0
	MOVM	AC2,SF		;GET MAGNITUDE OF SCLFCT
	CAMLE	AC2,P2		;.LE. # OF DIGITS?
	JRST	FLOU13		;NO. WE'RE ROUNDING ON ZEROES
	ADD	P,SF		;NEED LESS IF SF.LT.0
	ADD	P2,SF		;ADJUST # DIGITS
	ADDM	SF,%FLINF	;AND 9'S COUNTER
	SKIPGE	%FLINF		;IF 9'S COUNT IS NOW .LT. 0
	JRST	FLOU13		;WE HAVE NO ROUNDING
	JRST	DORND		;NOW ROUND WITH FEWER DIGITS

FGPOS:	MOVEI	P3,(SF)		;ENCODE MORE DIGITS
	SUBI	P3,(P2)		;EITHER 1 OR (SF-P2)
	CAIG	SF,1(T3)	;WITHIN DEFINED RANGE?
	MOVEI	P3,1		;YES. JUST ADD 1
	ADDI	P2,(P3)		;INCREASE RECORDED # DIGITS
	JRST	FLOU12		;GO ENCODE

CHKRN2:	TLNN	AC0,(1B1)	;ROUNDING BIT ON?
	JRST	FLOU13		;NO
DORND:	XMOVEI	AC2,(P)		;GET STACK POINTER
	MOVE	AC1,%FLINF	;GET 9'S COUNT
	JUMPLE	AC1,FLO12B	;INCR LAST DIG IF NO 9'S
ZERLP:	SETZM	(AC2)		;MAKE DIGIT ZERO
	SUBI	AC2,1		;DECR POINTER
	SOJG	AC1,ZERLP	;DO FOR ALL CONSECUTIVE 9'S
FLO12B:	AOS	(AC2)		;INCR NEXT DIGIT

FLOU13:	XMOVEI	P3,2(P1)	;GET BASE OF STACKED DIGITS
	SKIPN	1(P1)		;DID OVERFLOW OCCUR?
	JRST	FLOU14		;NO
	SUBI	P3,1		;YES - MOVE BACK BASE POINTER
	ADDI	XP,1		;INCREMENT EXPONENT
	ADDI	P2,1		;ADD 1 TO # DIGITS

FLOU14:	JUMPG	P2,FLO14A	;ANY DIGITS?
	TXZ	F,NUMSGN	;NO. CLEAR ANY SIGN
FLO14A:	TXNE	F,F%GTP		;YET ANOTHER G-FORMAT TEST
	TXNE	F,F%ETP+F%DTP
	JRST	FLOU15		;E OR D OR NOT G
	SETZ	SF,		;SCLFCT IS USELESS NOW FOR G-FORMAT

FLOU15:	SUBI	C,2(T3)		;SIGN, POINT AND CHARS. FOLLOWING
	TXNE	F,F%ETP!F%DTP
	JRST	FLOU16

;HERE FOR F TYPE CONVERSION
	TXNE	F,EQZER		;IS NUMBER ZERO?
	SETZ	SF,		;YES. SET SCALE FACTOR TO 0
	ADD	SF,XP		;COUNT THE LEADING DIGITS
	TXNE	F,F%GTP
	JRST	[SUBI	T3,(XP)		;NO, REDUCE CHAR. AFTER POINT FOR F
		JRST	CHEKDE]		;BUT IGNORE SCALE FACTOR IN WIDTH
	JUMPLE	SF,TRYFIT	;IGNORE NEG SCALING
	SUBI	C,(SF)		;+SCALING
	JRST	TRYFIT
;HERE FOR E AND D TYPE CONVERSION
FLOU16:	JUMPLE	SF,CHEKDE	;IF FACTOR .LE. 0, GO CHECK EXP
	SUBI	C,1		;EXTRA DIGIT PRINTED
	SUBI	T3,-1(SF)	;REDUCE DIGITS AFTER POINT
	JUMPGE	T3,CHEKDE	;TO COMPENSATE FOR THOSE IN FRONT
	ADD	C,T3		;HOWEVER IF NOT ENOUGH LEFT
				;TAKE FROM IN FRONT
CHEKDE:	MOVE	AC2,%XPVAL	;GET EXPONENT WIDTH
	JUMPN	AC2,GOTEXW	;MIGHT BE DEFAULT
	MOVEI	AC2,2		;WHICH IS 2
GOTEXW:	MOVEM	AC2,%FLINF	;SAVE FOR LATER
	TXNE	F,F%DTP+F%ETP	;D OR E FORMAT?
	CAIL	AC2,3		;YES. ROOM FOR LARGEST EXPONENT?
	JRST	EXPOK		;SURE
	MOVE	AC1,XP		;GET EXPONENT
	SUB	AC1,SF		;REDUCE BY SCALE FACTOR
	MOVM	AC1,AC1		;GET MAGNITUDE
	CAMGE	AC1,EXPTAB(AC2)	;[3273] WILL EXPONENT FIT?
	 JRST	EXPOK		;[3273] YES
	MOVE	AC2,%XPVAL	;[3273] NO. IF EXPONENT WIDTH GIVEN, DIE
	 JUMPN	AC2,NOFIT	;[3273] TOO BAD. THE STANDARD REQUIRES STARS
	TXO	F,NOEFLG	;MAYBE JUST BARELY WITH NO "D" OR "E"
	MOVE	AC2,%FLINF	;[3302] GET DEFAULTED VALUE AGAIN
	CAML	AC1,EXPTAB+1(AC2);WILL IT FIT AT ALL?
	JRST	NOFIT		;NO
EXPOK:	SUB	C,%FLINF	;REDUCE SPACE FOR NUMBER
	SUBI	C,2		;ALLOW FOR E+ OR + AND 1ST DIGIT OF EXP
TRYFIT:	JUMPG	C,FIT1		;WILL IT FIT?
	JUMPL	C,TRYF0		;NO. SERIOUS IF .LT. 0
	JUMPG	SF,GO2ERF	;C=0, OK IF DIGITS BEFORE POINT
IFN LZALWAYS,<
	TXNE	F,NUMSGN	;IS SIGN POSITIVE?
	 JRST	TRYTZ		;NO. GO TEST IF TRAILING ZEROES
	SKIPN	%SPFLG		;YES. PLUS SIGN REQUIRED?
	 AOJA	C,POSIGN	;NO. ELIMINATE IT FOR LEADING ZERO>
TRYTZ:	JUMPG	T3,GO2ERF	;YES. BUT WE'RE OK IF DIGITS AFTER POINT
TRYF0:	TXNE	F,NUMSGN	;IS SIGN POSITIVE
	 JRST	NOFIT		;NO.
	JUMPG	T3,TRYF1	;YES. ANY DIGITS AFTER POINT?
	JUMPG	SF,TRYF1	;NO. ANY DIGITS BEFORE POINT?
	JUMPL	C,NOFIT		;NO. MUST BE ROOM FOR LEADING 0
TRYF1:	CAML	C,[-1]		;YES. WOULD THERE BE ROOM WITHOUT SIGN?
	 AOJA	C,POSIGN	;YES. PRINT WITHOUT SIGN
NOFIT:	MOVE	AC2,%FWVAL	;GET THE WIDTH
	JUMPE	AC2,FIT		;ALWAYS FITS IF FREE FORMAT

	SKIPN	%FTAST		;ASTERISKS FOR OVERFLOW?
	 JRST	FNOAST		;NO. PRINT PART OF NUMBER INSTEAD
	MOVE	P,P1		;RESTORE STACK POINTER
	PJRST	%FTSUC		;OUTPUT ASTERISKS, CALL USER SUBROUTINE

FNOAST:	TXNE	F,NUMSGN	;NEGATIVE?
	 JRST	NOFIT1		;YES. CAN'T REMOVE SIGN
	ADDI	C,1		;NO. REMOVE SIGN
	TXO	F,NOSIGN	;AND PRINT NO SIGN LOC
NOFIT1:	ADD	T3,C		;REDUCE # DIGITS AFTER DEC POINT
	JUMPGE	T3,FIT		;IF WE HAVE NEGATIVE
	TXO	F,NOPNT		;OUTPUT NO DECIMAL POINT
	AOJGE	T3,FIT		;IF WE STILL HAVE NEGATIVE
	ADD	SF,T3		;REDUCE THE DIGITS BEFORE DEC PNT

FIT:	JUMPLE	C,GO2ERF	;NO LEADING BLANKS
FIT1:	JUMPG	SF,FIT2		;NO 2ND CHECK IF DIGITS BEFORE POINT
	CAIG	C,1		;MUST LEAVE ROOM FOR LEADING 0
	JRST	GO2ERF
FIT2:	PUSHJ	P,SPACE		;OUTPUT SPACE
	SOJA	C,FIT		;UNTIL ENOUGH

POSIGN:	SKIPE	%SPFLG		;FORCE PLUS SIGN?
	 JRST	NOFIT		;[3273] YES. TOO BAD. STANDARD REQUIRES STARS
	TXO	F,NOSIGN	;[3273] SIGNAL ROOM FOR LEADING ZERO
				; AND NO ROOM FOR + SIGN
GO2ERF:	TXNN	F,F%ETP!F%DTP	;TEST FLOATING POINT FLAGS
	JRST	FFORM		;NO, USE FIXED POINT
				;FALL INTO EFORM
;E FORMAT

EFORM:	SUB	XP,SF		;SCALE EXPONENT
	JUMPG	P2,EFORMA	;ANY SIGNIFICANT DIGITS?
	SETZ	XP,		;NO. CLEAR THE EXPONENT
EFORMA:	JUMPLE	SF,EFORM1	;JUMP IF NOT POSITIVE SCALING
	PUSHJ	P,SIGN		;OUTPUT SIGN
EFORMB:	PUSHJ	P,DIGIT		;OUTPUT LEADING DIGITS
	SOJG	SF,EFORMB	;RETURN FOR MORE
	PUSHJ	P,PERIOD	;OUTPUT DOT
	JUMPLE	T3,EFORM4	;NO MORE IF NO DEC
EFORMC:	PUSHJ	P,DIGIT		;OUTPUT ANOTHER DIGIT
	SOJG	T3,EFORMC	;UNTIL DECS USED UP
	JRST	EFORM4		;GO OUTPUT EXPONENT

EFORM1:	PUSHJ	P,SIGN		;OUTPUT SIGN
IFN LZALWAYS!LZSOME,<
	JUMPLE	C,EFORM2	;[4201] IF NO ROOM, DON'T OUTPUT LEADING 0
	JUMPL	SF,EFRM1A	;[4201] IF NEG SCALING, JUST OUTPUT ZERO
	JUMPG	T3,EFRM1A	;[4201] IF THERE ARE NO DIGITS TO OUTPUT
	PUSHJ	P,DIGIT		;[4201] USE THE "OVERFLOW" ZERO ON THE STACK
	JRST	EFORM2		;[4201] BECAUSE IT MIGHT BE A 1 FROM ROUNDING
>
IFE LZALWAYS!LZSOME,<
	JUMPG	T3,EFORM2	;[4201] IF TRAILING DIGITS, DON'T OUTPUT A ZERO
	JUMPL	SF,EFRM1A	;[4201] IF NEG SCALING, JUST OUTPUT ZERO
	PUSHJ	P,DIGIT		;[4201] USE THE "OVERFLOW" ZERO ON THE STACK
	JRST	EFORM2		;[4201] BECAUSE IT MIGHT BE A 1 FROM ROUNDING
>
EFRM1A:	PUSHJ	P,ZERO		;[4201] JUST OUTPUT A ZERO
EFORM2:	PUSHJ	P,PERIOD	;AND DECIMAL POINT
	JUMPLE	T3,EFORM4	;GO TO EXPONENT IF NO DIGITS
	JUMPE	SF,EFORM3	;ACCOUNT FOR ZERO SCALING
	MOVM	SF,SF		;GET MAGNITUDE
	CAIGE	SF,(T3)		;SCLFCT .GE. # DECS?
	JRST	EFRM2A		;NO. THINGS ARE OK
	CAIE	SF,(T3)		;EQUAL?
	MOVEI	SF,1(T3)	;GREATER. SET SF=D
	SUBI	SF,1		;EQUAL. SET SF=D-1
EFRM2A:	JUMPE	SF,EFORM3	;[4201] IF SCLFCT NOW ZERO, NO LEADING ZEROES
	SUBI	T3,(SF)		;REDUCE # SIGNIFICANT DIGITS
EFRM2B:	PUSHJ	P,ZERO		;OUTPUT LEADING ZEROES
	SOJG	SF,EFRM2B
EFORM3:	JUMPLE	T3,EFORM4	;LEAVE IF NO DIGITS AFTER POINT
EFRM3A:	PUSHJ	P,DIGIT		;OUTPUT FRACTIONAL DIGIT
	SOJG	T3,EFRM3A	;RETURN IF MORE DIGITS

EFORM4:	MOVEI	AC1,"E"
	TXNE	F,F%DTP		;USER SPECIFY D-FORMAT?
	MOVEI	AC1,"D"		;YES, GIVE D INSTEAD
	TXNN	F,NOEFLG	;DON'T PRINT IF NO ROOM
	PUSHJ	P,%OBYTE	;OUTPUT "E" OR "D"
	JUMPGE	XP,EFORM5
	TXO	F,NUMSGN	;TYPE MINUS IF EXPONENT NEGATIVE
EFORM5:	PUSHJ	P,PLUS		;PRINT SIGN
	MOVE	C,%FLINF	;AND SET DIGIT COUNT
	TXNE	F,NOEFLG	;DID WE PRINT "D" OR "E"?
	ADDI	C,1		;NO. MORE ROOM FOR EXPONENT
	MOVE	P,P1		;RESTORE STACK POINTER
	MOVM	AC0,XP		;GET EXPONENT
	JRST	OUTP1		;AND LET OUTP1 DO THE WORK
;F FORMAT

FFORM:	JUMPLE	SF,FFORM3	;NO LEADING DIGITS
	PUSHJ	P,SIGN		;OUTPUT SIGN
FFORMA:	PUSHJ	P,DIGIT		;OUTPUT INTEGRAL DIGIT
	SOJG	SF,FFORMA	;RETURN IF MORE DIGITS
	PUSHJ	P,PERIOD	;PRINT DECIMAL POINT

FFORM1:	JUMPLE	T3,FFORM2	;TEST FOR DIG AFTER POINT
	PUSHJ	P,DIGIT		;OUTPUT FRACTIONAL DIGIT
	SOJG	T3,FFORM1	;RETURN IF MORE DIGITS

FFORM2:	MOVE	P,P1		;RESTORE STACK
	TXNN	F,F%GTP		;G FORMAT REQUIRES 4 BLANKS
	 POPJ	P,		;DONE
	MOVE	C,%XPVAL	;GET EXPONENT WIDTH
	CAIN	C,0		;IF SET
	  MOVEI	C,2		;IF NOT, DEFAULT IS 4 (2+2)
	ADDI	C,2		;PLUS 2 FOR E+ OR E-
FFRM2A:	PUSHJ	P,SPACE		;BLANKS
	SOJG	C,FFRM2A
	POPJ	P,		;DONE

FFORM3:	PUSHJ	P,SIGN		;OUTPUT SIGN
IFN LZALWAYS!LZSOME,<
	JUMPLE	C,NOLZ		;AND IF WE CAN,>
IFE LZALWAYS!LZSOME,<
	JUMPG	T3,NOLZ		;OR IF NO TRAILING DIGITS>
	PUSHJ	P,ZERO		;OUTPUT LEADING "0"
NOLZ:	PUSHJ	P,PERIOD	;OUTPUT DEC. POINT
	ADD	T3,SF		;REDUCE DEC BY SCLFCT
	JUMPGE	T3,FFRM3C	;FINISH IF OK
	SUB	T3,SF		;RESTORE D
	MOVN	SF,T3		;USE FOR SCLFCT
	SETZ	T3,		;AND NO DIGITS

FFRM3C:	JUMPGE	SF,FFORM1	;NOW FOR DIGITS
	PUSHJ	P,ZERO		;ZERO AFTER POINT
	AOJA	SF,FFRM3C	;LOOP ON ZEROS


;EXTENDED EXPONENT NUMBERS HAVE 3 MORE BITS OF EXPONENT,
;SO WE MOVE THE MANTISSA OVER TO WHERE IT WOULD BE WERE IT
;A NORMAL FLOATING POINT NUMBER. IF THE EXPONENT IS WITHIN THE NORMAL
;FLOATING POINT RANGE, WE JUST DROP INTO THE STANDARD CODE. IF NOT,
;WE USE A SPARSE POWER OF TEN TABLE TO SCALE THE MANTISSA
;AND LOWER THE MAGNITUDE OF THE BINARY EXPONENT. THE TABLE IS ARRANGED
;SO THAT EACH POWER OF TEN WILL SCALE 2**35 MORE THAN THE NEXT,
;SO WE JUST DIVIDE THE BINARY EXPONENT BY 35 TO GET THE TABLE ENTRY
;TO USE.
;WE LEAVE THE MANTISSA ALIGNED WITH BIT 9 TO AVOID DIVIDE CHECKS. WE
;DON'T LOSE ANY PRECISION THEREBY BECAUSE FOR BOTH MULTIPLICATION
;AND DIVISION WE GET A 4-WORD RESULT. AFTER THE SCALING OPERATION,
;WE HAVE TO ALIGN THE MANTISSA ON BIT 1. THIS TIME,
;HOWEVER, IT MIGHT START ANYWHERE, SO WE CALL %EENRM.
EEDEC:	LDB	P1,[POINT 12,AC0,11];GET THE EXPONENT
	TLZ	AC0,777700	;AND WIPE IT OUT IN MANTISSA
	ASHC	AC0,3		;MAKE IT LOOK NORMAL
	HRREI	P1,-2000(P1)	;EXTEND SIGN OF EXPONENT
	MOVM	P2,P1		;GET MAGNITUDE OF EXP
	CAMGE	P2,%PMEXP	;OUT OF RANGE?
	 POPJ	P,		;NO. USE REGULAR CODE
	SUBI	P2,^D70		;MODIFY FOR SPARSE 10'S TABLE
	IDIVI	P2,^D35		;DERIVE INDEX FOR EXPONENT
	IMULI	P2,3		;GET PROPER INDEX
	JUMPL	P1,EENEG	;GO DO MUL IF NEGATIVE
	PUSHJ	P,%EEDIV	;AND DIVIDE IF POSITIVE
	SUBI	P1,(P3)		;REDUCE THE BINARY EXPONENT
	POPJ	P,

EENEG:	PUSHJ	P,%EEMUL	;DO D.P. MULT
	MOVNI	XP,(XP)		;RECORD NEGATIVE DECIMAL EXPONENT
	ADDI	P1,(P3)		;REDUCE MAGNITUDE OF BINARY EXP
	POPJ	P,

%EEDIV:	SETZB	AC2,AC3		;CLEAR LOWER AC'S
	SETZB	AC4,AC5		;AND EVEN LOWER AC'S
	DDIV	AC0,%BEXP(P2)	;GET 2-WORD RESULT
	DDIV	AC2,%BEXP(P2)	;GET 4-WORD RESULT
	JRST	EECOM		;JOIN COMMON CODE

%EEMUL:	DMOVE	AC2,%BEXP(P2)	;GET POWER OF TEN
	ADDI	AC3,1		;BIAS IT - IT IS TRUNCATED
	DMUL	AC0,AC2		;GET 4-WORD RESULT
EECOM:	PUSHJ	P,%EENRM	;NORMALIZE IT
	TLO	AC0,(1B0)	;PREPARE FOR OVERFLOW
	TLNE	AC2,(1B1)	;ROUNDING BIT ON?
	DADD	AC0,[EXP 0,1]	;YES. ROUND UP
	TLZ	AC1,(1B0)	;TURN OFF LOW SIGN
	TLZE	AC0,(1B0)	;DID WE OVERFLOW?
	JRST	EEOK		;NO
	TLO	AC0,(1B1)	;YES. TURN HIGH BIT ON
	ADDI	P1,1		;AND INCR THE BINARY EXP
EEOK:	HLRZ	P3,%DEXP(P2)	;GET THE BINARY EXPONENT
	HRRZ	XP,%DEXP(P2)	;GET DECIMAL EXPONENT
	POPJ	P,

%EENRM:	MOVE	T4,AC0		;GET THE HIGH WORD
	JFFO	T4,EENZ		;LOOK FOR 1ST 1
	DMOVE	AC0,AC1		;SHOVE THE NUMBER OVER
	SUBI	P1,^D35		;AND MODIFY THE EXPONENT
	MOVE	T4,AC0		;TRY NEXT WORD
	JFFO	T4,EENZ
	JRST	EENEND		;STILL NONE
EENZ:	SOJE	T5,EENEND	;LEAVE STARTING AT BIT 1, DONE IF NO SHIFT
	SUB	P1,T5		;MODIFY THE BINARY EXPONENT
	MOVN	T4,T5		;AND GET NEG SHIFT ALSO
	JUMPL	T5,RGTSFT	;DIFFERENT FOR RIGHT SHIFT
	ASHC	AC0,(T5)	;MOVE 1ST AND 2ND WORDS
	ASH	AC1,(T4)	;MOVE BACK 2ND WORD
	ASHC	AC1,(T5)	;MOVE 2ND AND 3RD WORD
EENEND:	POPJ	P,

RGTSFT:	ASHC	AC1,(T5)	;MOVE 2ND AND 3RD
	ASH	AC1,(T4)	;MOVE 2ND BACK
	ASHC	AC0,(T5)	;MOVE 1ST AND 2ND
	POPJ	P,

		;SCALE DOUBLE FRACTION BY A POWER OF 10
DPMUL:	JUMPE	P2,CPOPJ	;IF DEC EXP IS 0, RETURN
	ADD	XP,P2		;PUT DEC SCALE FACTOR INTO XP
	MOVN	P2,P2		;TAKE RECIPROCAL OF EXPONENT
	MOVE	P3,%EXP10(P2)	;GET CORRESPONDING BIN EXP
	ADD	P1,P3		;ADD POWER EXP INTO FRAC EXP

	MOVE	AC2,%HITEN(P2)	;GET DOUBLE SCALING FACTOR
	MOVE	AC3,%LOTEN(P2)
	ADDI	AC3,1		;BIAS IT - IT IS TRUNCATED
	DMUL	AC0,AC2		;GET DP PRODUCT
	TLO	AC1,(1B0)	;PREPARE FOR CARRY
	TLNE	AC2,(1B1)	;ROUNDING BIT ON?
	ADDI	AC1,1		;YES. ADD 1 TO LOW WORD

	TLZN	AC1,(1B0)	;OVERFLOW
	ADDI	AC0,1		;YES
	TLNE	AC0,(1B1)	;NORMALIZED?
	POPJ	P,		;YES
	ASHC	AC0,1		;NO, SHIFT LEFT ONE
	SUBI	P1,1		;AND ADJUST EXPONENT
CPOPJ:	POPJ	P,		;RETURN

; OUTPUT ROUTINES

PERIOD:	TXNE	F,NOPNT		;SUPPRESS DEC PNT?
	 POPJ	P,		;YES. JUST LEAVE
	MOVEI	AC1,"."		;DECIMAL POINT
	PJRST	%OBYTE		;PRINT AND RETURN

SPACE:	SKIPE	%FTSLB		;SUPPRESS LEADING BLANKS?
	 POPJ	P,		;YES. LEAVE
	MOVEI	AC1," "		;SPACE
	PJRST	%OBYTE

ZERO:	MOVEI	AC1,"0"
	JRST	%OBYTE

PLUS:	MOVEI	AC1,"+"
	JRST	SIGN1
SIGN:	TXZE	F,NOSIGN	;NO ROOM FOR SIGN?
	POPJ	P,		;JUST RETURN
	MOVEI	AC1," "
	SKIPE	%SPFLG		;FORCE PLUS SIGN?
	 MOVEI	AC1,"+"		;YES

SIGN1:	TXZE	F,NUMSGN	;ALWAYS CLEAR FLAG
	 MOVEI	AC1,"-"		;SELECT SIGN
	CAIN	AC1," "		;IS IT A SPACE?
	 SKIPN	%FTSLB		;YES. SUPPRESS LEADING BLANK?
	  PJRST	%OBYTE		;NO. PRINT
	POPJ	P,

DIGIT:	JUMPLE	P2,ZERO		;OUTPUT ZERO IF NO DIGITS
	SUBI	P2,1		;DECR # DIGITS LEFT
	MOVE	AC1,(P3)	;GET NEXT DIGIT
	ADDI	AC1,"0"		;CONVERT TO ASCII
	AOJA	P3,%OBYTE	;AND PRINT

OUTP1:	MOVEI	XP,1		;SET UP DIGIT COUNT

OUTP2:	IDIVI	AC0,^D10	;AND GENERATE DIGITS IN REVERSE
	PUSH	P,AC1		;AND SAVE THEM ON THE STACK
	JUMPE	AC0,OUTP3	;ANY LEFT?
	AOJA	XP,OUTP2	;YES - COUNT AND CARRY ON

OUTP3:	CAML	XP,C		;ANY LEADING SPACES?
	JRST	OUTP4		;NO
	PUSHJ	P,ZERO		;YES - PRINT ONE
	SOJA	C,OUTP3		;AND DECREASE UNTIL FINISHED

OUTP4:	POP	P,AC1		;POP UP DIGIT
	ADDI	AC1,"0"		;ADD ASCII OFFSET
	PUSHJ	P,%OBYTE	;AND PRINT IT
	SOJN	XP,OUTP4	;REPEAT UNTIL FINISHED
	POPJ	P,		; EXIT FROM ROUTINE

FRMTAB:	^D15,,7			;15.7 DEFAULT
	^D25,,^D17		;25.17 DEFAULT

EXPTAB:	1	;10**0
	^D10	;10**1
	^D100	;10**2
	^D1000	;10**3

	PRGEND
	TITLE	LOGIC	LOGICAL INPUT/OUTPUT 
	SUBTTL	D. TODD/HPW/MD/DCE	28-OCT-81
	SEARCH	MTHPRM,FORPRM




;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, 1987
;ALL RIGHTS RESERVED.

	SEGMENT	CODE

	ENTRY	%LINT,%LOUT,%GLINT,%GLOUT
	EXTERN	%IBYTE,%OBYTE,%FWVAL
	EXTERN	%SKIP
	EXTERN	IO.ADR,%FLINF,%SAVE1
	EXTERN	%ABORT,%FTSLB

%GLINT:
%LINT:	PUSHJ	P,%SAVE1	;SAVE P1
	PUSHJ	P,LOGSET	;DO SETUP
	SETZM	(P1)		;INPUT SET THE USER'S VARIABLE FALSE
	MOVEI	T3,6		;SETUP TO SAVE 6 CHARS
	MOVE	T2,[POINT 6,%FLINF];IN SIXBIT
	JUMPG	T4,LINT		;NOT FREE FORMAT
	SETO	T4,		;FREE FORMAT
	PUSHJ	P,%SKIP		;SKIP SPACES
	  POPJ	P,		;NULL FIELD
	JRST	LINT0		;PROCESS FIELD
LINT:	JUMPE	T4,LINT3	;IF W=0 RETURN
	PUSHJ	P,%IBYTE	;SKIP AN INPUT CHARACTER
LINT0:	JUMPE	T1,LSKIP	;SKIP IF NULL
	CAIE	T1," "		;CHECK FOR A BLANK
	CAIN	T1,11		;OR <TAB>
LSKIP:	SOJA	T4,LINT		;YES, IGNORE THE CHARACTER
	CAIE	T1,"."		;PERIOD?
	JRST	NOTDOT		;NO
	SOJE	T4,LINT2	;ERROR IF JUST DOT
	PUSHJ	P,%IBYTE	;GET NEXT CHAR
NOTDOT:	PUSHJ	P,DEPINF	;DEPOSIT IN INFO WORD
	CAIE	T1,"f"		;LOWER CASE F IS OK
	CAIN	T1,"F"		;CHECK FOR FALSE
	JRST	LINT1		;YES, PROCESS THE FALSE CHARACTER
	CAIE	T1,"t"		;CHECK FOR TRUE
	CAIN	T1,"T"		;UPPER CASE TOO
	TRNA			;FOUND A TRUE
	JRST	LINT2		;NO, ILLEGAL CHARACTER
	SETOM	(P1)		;YES, SET USER'S VARIABLE PRUE
LINT1:	SOJE	T4,LINT3	;SPACING REQUIRED W=0
	PUSHJ	P,%IBYTE	;YES, SKIP AN INPUT CHARACTER
	JUMPG	T4,LINT1	;CONTINUE UNTIL W=0
	CAIE	T1," "		;SPACE, TAB, OR COMMA ENDS FREE FMT
	CAIN	T1,11
	 POPJ	P,
	CAIN	T1,","
	 POPJ	P,
	MOVE	T0,FLAGS(D)
	TXNN	T0,D%LSD	;LIST-DIRECTED?
	 JRST	NOTLSD		;NO
	CAIN	T1,"/"		;SLASH ENDS LDIO
	POPJ	P,
NOTLSD:	MOVE	T0,FLAGS(D)
	TXNN	T0,D%NML	;NAMELIST?
	 JRST	NOTNML		;NO
	CAIE	T1,"("		;YES. EQUAL AND LEFT PAREN
	CAIN	T1,"="		;ARE DELIMITERS
	POPJ	P,		;SO WE STOP
	CAIE	T1,"$"		;ALSO MIGHT BE NAMELIST DELIM!
	CAIN	T1,"&"
	POPJ	P,		;IN WHICH CASE WE LEAVE
NOTNML:	PUSHJ	P,DEPINF	;ELSE DEPOSIT IN INFO WORD
	JRST	LINT1		;IGNORE ALL ELSE
LINT2:	$ACALL	ILC		;"ILLEGAL CHARACTER IN DATA"
LINT3:	POPJ	P,		;RETURN

%GLOUT:
%LOUT:	PUSHJ	P,%SAVE1	;SAVE P1
	PUSHJ	P,LOGSET	;DO SETUP
	SKIPE	%FTSLB		;IF SUPPRESS BLANKS ON
	 JRST	LOUT1		;Don't bother with blank fill
	SKIPG	T4		;W SPECIFIED?
	SKIPA	T4,[^D15-1]	;NO - SET DEFAULT = 15.
	SOJE	T4,LOUT1	;CHECK FOR W=1
	MOVEI	T1," "		;GET A BLANK FOR OUTPUT
	PUSHJ	P,%OBYTE	;OUTPUT A FILL BLANK
	SOJG	T4,.-1		;CONTINUE FILLING
LOUT1:	MOVEI	T1,"F"		;GET A F FOR FALSE
	SKIPGE	(P1)		;IS VARIABLE FALSE
	MOVEI	T1,"T"		;NO, SET T FOR TRUE
	PJRST	%OBYTE		;OUTPUT THE VALUE AND RETURN TO FOROTS

DEPINF:	SOJL	T3,INFDON	;NO MORE THAN 6 CHARS
	MOVEI	T5,(T1)		;COPY THE CHAR
	CAIL	T5,140		;CONVERT TO SIXBIT
	SUBI	T5,40
	SUBI	T5,40
	IDPB	T5,T2		;DEPOSIT IN INFO WORD
INFDON:	POPJ	P,

LOGSET:	SETZM	%FLINF			;CLEAR INFO WORD
	MOVE	P1,IO.ADR	;GET ADDR OF VARIABLE
	MOVE	T4,%FWVAL	;GET THE FIELD WIDTH
	POPJ	P,

	PRGEND
	TITLE	DELIM	ROUTINE TO HANDLE DELIMITER OF FREE FORMAT 
	SEARCH	MTHPRM,FORPRM


;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, 1987
;ALL RIGHTS RESERVED.

	SEGMENT	CODE

	ENTRY	%SKIP,%FTSUC

	EXTERN	%IBYTE,%OMPAD,%FIXED,%ERTYP,IO.TYP,%FWVAL,%GOPTR

;ROUTINE TO SKIP SPACES OR NULLS
;NON SKIP RETURN IF CHAR IS COMMA OR EOL
%SKIP:	SKIPGE	IRCNT(D)	;ANY CHARS LEFT?
	 POPJ	P,		;NO. NON-SKIP RETURN FOR EOL
	PUSHJ	P,%IBYTE	;GET A CHAR
	JUMPE	T1,%SKIP	;SKIP NULLS
	CAIE	T1," "		;BLANK
	CAIN	T1,"	"	;OR TAB
	JRST	%SKIP		;YES.  SKIP IT
	CAIE	T1,","		;COMMA?
	AOS	(P)		;NO. SKIP RETURN
	POPJ	P,

%FTSUC:	PUSHJ	P,%GOPTR	;GET OUTPUT REC PNTR/COUNT
	CAMLE	T1,%FWVAL	;IF REC COUNT .GE. FIELD WIDTH
	 MOVE	T1,%FWVAL	;USE FIELD WIDTH
	DMOVEM	T0,%FIXED	;SAVE FOR USER
	MOVEI	T1,"*"		;FILL WITH ASTERISKS
	MOVE	T3,%FWVAL	;GET OUTPUT WIDTH
	PUSHJ	P,%OMPAD	;OUTPUT STARS
	MOVE	T1,IO.TYP	;GET DATA TYPE
	MOVEM	T1,%ERTYP	;SAVE FOR USER SUBR
	$ECALL	FTS		;ISSUE ERROR MSG, CALL SUBR IF DESIRED
	POPJ	P,

	END