Trailing-Edge
-
PDP-10 Archives
-
BB-4157D-BM
-
sources/forcnv.mac
There are 13 other files named forcnv.mac in the archive. Click here to see a list.
TITLE FORCNV %5A(673) CONVERSION ROUTINES
SUBTTL REVISION HISTORY
;256 ----- CORRECT LSTDR% TO CHANGE FT.ELT TO FT.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
;**************** BEGINNING OF 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 FT.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
;**************** BEGINNING OF 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...
;673 22607 IMPLEMENT VBL WIDTH DOUBLE PRECISION OCTAL I/O.
;**************** END OF REVISION HISTORY
PRGEND
TITLE ALPHA% RIGHT% %4.(354) ALPHANUMBERIC INPUT/OUTPUT ROUTINES
SUBTTL D. TODD/DRT/HPW/MD 29-JUL-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) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH FORPRM ;GET THE FOROTS GLOBAL SYMBOL TABLE
; DEFINE THE LOADING PARAMETERS
SEGMEN
ENTRY ALPHA%,RIGHT%
EXTERN IBYTE.,OBYTE.,W.PNTR ;[265]
EXTERN GFDEL% ;[376]
RIGHT%: TDZA T2,T2 ;RIGHT JUSTIFY ENTRY
ALPHA%: MOVSI T2,(POINT 7,(G1)) ;LEFT JUSTIFY ENTRY
MOVEI T4,5 ;ASSUME SINGLE PRECISION
MOVE T1,DAT.TP+2(P4) ;GET THE VARIABLE TYPE
CAIN T1,TP%DOR ;DOUBLE PRECISION REAL
LSH T4,1 ;YES, ALLOW 10 CHARACTERS MAX.
LDB T5,W.PNTR ;[265] GET THE WIDTH FIELD
JUMPG T5,ALPHA1 ;[354] SPECIFIED
JUMPI [ERROR (DAT,16,16,ALPHA1)] ;[354] ERROR IF INPUT
MOVEI T5,(T4) ;[305] NO-SET DEFAULT
ALPHA1: MOVEI T3,(T5) ;[354] SAVE THE W FIELD
SUBI T3,(T4) ;COMPUTE THE EXCESS FIELD SIZE
CAILE T5,(T4) ;IS THE W FIELD IN RANGE
MOVEI T5,(T4) ;NO, SET TO MAX SING.=5 DP=10
JUMPO ALPHO ;GO TO ALPHO ON OUTPUT
ALPHI: MOVE T0,[ASCII / /];GET A SET OF 5 BLANKS
MOVEM T0,(G1) ;SET THE VARIABLE TO BLANK CLEAR BIT 35
CAIN T1,TP%DOR ;DOUBLE PRECISION REAL
MOVEM T0,1(G1) ;CLEAR THE LOW ORDER WORD
JSP P1,GFDEL% ;[376] RETRIEVE DELIMITER
JUMPG T3,ALPHI0 ;[376] EXCESS W
JUMPN T2,ALPHI3 ;[376] "A" FORMAT
SETZB T3,T4 ;[376] RIGHT JUSTIFY - CLEAR DEST.
JRST RIGHI2 ;[376] GO THERE
JSP P1,IBYTE. ;EXCESS W SKIP INPUT CHARACTERS
ALPHI0: SOJG T3,.-1 ;[376] CONTINUE SKIPPING
JUMPE T2,RIGHI ;[376] RIGHT JUSTIFY
ALPHI1: JSP P1,IBYTE. ;GET AN INPUT BYTE
ALPHI3: IDPB T0,T2 ;[376] PUT IN USER'S VARIBLE
SOJG T5,ALPHI1 ;CONTINUE UNTIL W=0
ALPHI2: POPJ P, ;RETURN FOR FOROTS
ALPHO: ;ALPHA OUTPUT ROUTINE
JUMPLE T3,ALPHO0 ;IS OUTPUT FILL NEEDED
MOVEI T0," " ;YES, GET A BLANK
JSP P1,OBYTE. ;FILL OUTPUT FILL WITH BLANKS
SOJG T3,.-2 ;CONTINUE UNTIL MAX W IS REACHED
ALPHO0: JUMPE T2,RIGHO ;RIGHT JUSTIFY
ALPHO1: ILDB T0,T2 ;GET THE CHARACTER FORM THE VARIABLE
JUMPN T0,ALPHO2 ;JUMP IF NOT A NULL
MOVEI T0," " ;NULL, GET A BLANK
ALPHO2: JSP P1,OBYTE. ;OUTPUT THE CHARACTER
SOJG T5,ALPHO1 ;CONTINUE UNTIL W=0
POPJ P, ;RETURN TO FOROTS
;ROUTINES TO RIGHT JUSTIFY ASCII STRING IN THE USER'S VARIABLE
RIGHI: ;RIGHT JUSTIFY INPUT
SETZB T3,T4 ;CLEAR THE RECEIVING WORD
RIGHI1: LSHC T3,^D7 ;SHIFT A CHARACTER
JSP P1,IBYTE. ;READ A CHARACTER
RIGHI2: IOR T4,T0 ;[376] INSERT THE CHARACTER
SOJG T5,RIGHI1 ;CONTINUE
LSHC T3,1 ;CLEAR THE LOW ORDER SIGN BIT
LSH T4,-1 ;AND POSITION
MOVEM T4,(G1) ;STORE THE LOW ORDER WORD (SINGLE)
CAIE T1,TP%DOR ;CHECK FOR DOUBLE PRECISION
POPJ P, ;NO, EXIT
DMOVEM T3,(G1) ;STORE BOTH WORDS (DOUBLE)
POPJ P, ;RETURN
RIGHO: ;RIGHT JUSTIFY OUTPUT
MOVE T2,[POINT 7,T3] ;TEMP BYTE POINTER
RIGHO1: CAIN T5,(T4) ;CHARACTERS TO SKIP
JRST RIGHO2 ;NO, GET THE DATA WORD(S)
IBP T2 ;YES, SKIP A CHARACTER
SOJA T4,RIGHO1 ;CONTINUE
RIGHO2: MOVE T3,(G1) ;GET THE HIGH ORDER WORD
SETZ T4, ;CLEAR THE LOWER ORDER
CAIN T1,TP%DOR ;DOUBLE PRECISION
MOVE T4,1(G1) ;YES, GET THE LOW ORDER WORD
LSHC T3,1 ;ASCII ALIGN
JRST ALPHO1 ;DO THE OUTPUT
PRGEND
TITLE FLIRT% %5A.(654) FLOATING POINT INPUT
SUBTTL DAVE NIXON AND TOM EGGERS
SUBTTL D.M.NIXON /DMN/DRT/HPW/MD/CLRH/DCE 26-APR-77
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH FORPRM ;GET THE FOROTS GLOBAL SYMBOL TABLE
; DEFINE THE LOADING PARAMETERS
SEGMEN
ENTRY REAL%
ENTRY FLIRT%
ENTRY FLINC% ;[206] DP INPUT TO INTEGER CONVERSION
EXTERN IBYTE.,W.PNTR,D.PNTR ;[265]
EXTERN HITEN.,LOTEN.,EXP10.,PTLEN.
EXTERN GFDEL%,SFDEL%,SKIP%,MUN ;[354]
;IF THE FLAG ILLEG. HAS BEEN SET (BY A CALL TO ILL), THE
;INPUT WORD WILL BE SET TO 0 IF ANY ILLEGAL CHARACTERS
;ARE SCANNED FOR THAT WORD.
;THE SYNTAX ANALYSIS FOR THE SINGLE AND DOUBLE PRECISION INPUT
;IS STATE TABLE DRIVEN. EACH NEW INPUT CHARACTER IS CONVERTED TO
;A CHARACTER TYPE AND COMBINED WITH THE OLD "STATE". THIS RESULT
;IS THEN LOOKED UP IN THE TABLE "NXTSTA" TO GET THE NEW STATE AND
;AN INDEX INTO THE "XCTTAB" TABLE TO DISPATCH FOR THE INPUT
;CHARACTER. THE STATE TABLE LOGIC AND THE DISPATCH ROUTINES BUILD
;THREE RESULTS: A DOUBLE PRECISION INTEGER(IN B,C) FOR THE FRACTIONAL
;PART OF THE RESULT, AN INTEGER(IN XP) FOR THE EXPONENT AFTER
;"D" OR "E", AND A COUNTER(IN "X") TO KEEP TRACK OF THE DECIMAL POINT.
;WHEN A TERMINATING CHARACTER IS FOUND, THE DOUBLE PRECISION INTEGER
;IS NORMALIZED TO THE LEFT TO GIVE A DOUBLE PRECISION FRACTION.
;THE DECIMAL POINT POSITION(FROM "X")OR THE IMPLIED DECIMAL POINT
;POSITION FROM THE FORMAT STATEMENT, THE "D" OR "E" EXPONENT, AND ANY
;SCALING FROM THE FORMAT STATEMENT ARE COMBINED INTO A DECIMAL
;EXPONENT. THIS DECIMAL EXPONENT IS USED AS AN INDEX INTO A POWER
;OF TEN TABLE (KEPT IN DOUBLE PRECISION INTEGER PLUS EXPONENT FORM
;SO INTERMEDIATE RESULTS WILL HAVE 8 MORE BITS OF PRECISION THAN
;FINAL RESULTS) TO MULTIPLY THE DOUBLE PRECISION FRACTION. THIS
;RESULT IS THEN ROUNDED TO GIVE A SINGLE PRECISION,
;KA10 DOUBLE PRECISION, OR PDP6/KI10 DOUBLE PRECISION RESULT.
;OVERFLOWS RETURN THE LARGEST POSSIBLE
;NUMBER (WITH CORRECT SIGN), WHILE UNDERFLOWS RETURN 0. NO ERROR
;MESSAGE IS GIVEN FOR EITHER OVER OR UNDERFLOW.
;OLD ACCUMULATOR DEFINITIONS
A==T0 ;RETURNED CHAR. FROM CHINN.
B=A+1 ;RESULT RETURNED IN A OR A AND B
C=B+1 ;B,C, AND D ARE USED AS A MULTIPLE PRECISION
D=C+1 ; REGISTER FOR DOUBLE PRECISION OPERATIONS
XP=D+1 ;EXPONENT AFTER D OR E
W==T5 ;FIELD WIDTH COUNTER
X==G1 ;COUNTS DIGITS AFTER POINT
F==G2 ;FLAGS
ST==G4 ;STATES
;ST+1 ;TEMPORARY, USES P1 WHICH CAN BE DESTROYED HERE
BXP==ST ;BINARY EXPONENT
;RIGHT HALF FLAGS IN AC "F"
DOTFL==1 ;DOT SEEN
MINFR==2 ;NEGATIVE FRACTION
MINEXP==4 ;NEGATIVE EXPONENT
EXPFL==10 ;EXPONENT SEEN IN DATA (MAY BE 0)
;INPUT CHARACTER TYPES
CRTYP==1 ;CARRIAGE RETURN
DOTTYP==2 ;DECIMAL POINT
DIGTYP==3 ;DIGITS 0-9
SPCTYP==4 ;SPACE OR TAB
EXPTYP==5 ;D OR E
PLSTYP==6 ;PLUS SIGN (+)
MINTYP==7 ;MINUS SIGN (-)
;ANYTHING ELSE IS TYPE 0
FT.INC==10 ;CONVERSION TO INTEGER
FLINC%: TLOA P2,FT.INC!FT.PRC;[206] DP IONPUT TO INTEGER CONVERSION
REAL%: JUMPO FLOUT%## ;OUTPUT
FLIRT%: ;INPUT
PUSH P,G1 ;SAVE THE GLOBAL AC'S BOTTOM TO TOP
PUSH P,G2 ;
; PUSH P,G3 ;DON'T NEED G3
PUSH P,G4 ;MUST PUSH LAST (P1-G4 USED AS A PAIR)
LDB W,W.PNTR ;[265] GET THE FIELD WIDTH
SETZB B,C ;INIT D.P. FRACTION
SETZB ST,XP ;INIT STATE AND DECIMAL EXPONENT
SETZB X,F ;INIT "DIGITS AFTER POINT" COUNTER
JSP P1,GFDEL% ;[354] RETRIEVE DELIMITER
JUMPG W,GETCH2 ;[354] FIELD SPECIFIED
SETO W, ;[354] SET FREE FORMAT FLAG
PUSHJ P,SKIP% ;[354] FREE FORMAT - SKIP SPACES
JRST ENDF1 ;[354] COMMA OR EOL = NULL FIELD
JRST GETCH2 ;[354] PROCESS FIELD
GETNXT:
GETCHR: JUMPE W,ENDF1 ;END OF FIELD
LSH ST,-^D30 ;MOVE STATE TO BITS 30-32
GETCH1: JSP P1,IBYTE. ;GET NEXT CHARACTER
GETCH2: CAIL T0,"0" ;CHECK FOR NUMBER
CAILE T0,"9"
JRST CHRTYP ;NO, TRY OTHER
SUBI T0,"0" ;CONVERT TO NUMBER
GOT0: IORI ST,DIGTYP ;SET TYPE
GOTST: LSHC ST,-2 ;DIVIDE BY NUMBER OF BYTES IN WORD
TLNE ST+1,(1B0) ;TEST WHICH HALF
SKIPA ST,NXTSTA(ST) ;RIGHT HALF (BYTES 2 OR 3)
HLRZ ST,NXTSTA(ST) ;UNFORTUNATELY BYTES 0 OR 1
TLNN ST+1,(1B1) ;WHICH QUADRANT
LSH ST,-9 ;BYTES 0 OR 2
ANDI ST,777 ;LEAVE ONLY RIGHT MOST QUARTER
ROT ST,-3 ;PUT DISPATCH ADDRESS IN BITS 32-35
; AND NEW STATE IN BITS 0-2
XCT XCTTAB(ST) ;DISPATCH OR EXECUTE
SOJA W,GETNXT ;RETURN FOR NEXT CHAR.
XCTTAB: JRST ILLCH ; (00) ILLEGAL CHAR
JRST CRIN ; (01) CR-LF
IORI F,DOTFL ; (02) PERIOD
JRST DIG ; (03) DIGIT BEFORE POINT
JRST BLNKIN ; (04) BLANK OR TAB
SOJA W,GETNXT ; (05) RETURN FOR NEXT CHAR.
IORI F,MINFR ; (06) NEGATIVE FRACTION
IORI F,MINEXP ; (07) NEGATIVE EXP
SOJA X,DIG ; (10) DIGIT AFTER POINT
JRST DIGEXP ; (11) EXPONENT
JRST DELCK ; (12) DELIMITER TO BACK UP OVER
CHRTYP: CAIN T0,"+" ;CONVERT INPUT CHARS TO CHARACTER TYPE
IORI ST,PLSTYP
CAIN T0,"-"
IORI ST,MINTYP
CAIE T0," " ;SPACE
CAIN T0," " ;TAB
IORI ST,SPCTYP
CAIN T0,"."
IORI ST,DOTTYP
CAIE T0,"D"
CAIN T0,"E"
IORI ST,EXPTYP
;**;[652], INSERT @CHRTYP+11 1/2, DCE,12-APR-77
CAIE T0,"d" ;[652] LOWER CASE D?
CAIN T0,"e" ;[652] LOWER CASE E?
IORI ST,EXPTYP ;[652] YES
TLNE P3,IO.EOL ;56;END OF LINE SET
TRC ST,SPCTYP!CRTYP ;56;SET UP A BLANK
JRST GOTST ;GO DISPATCH ON OLD STATE AND CHAR TYPE
DIG: JUMPN B,DPDIG ;NEED D.P. YET?
CAMLE C,MAGIC ;NO, WILL MUL AND ADD CAUSE OVERFLOW?
JRST DPDIG ;MAYBE, SO DO IT IN DOUBLE PRECISION
IMULI C,12 ;NO, MULTIPLY BY 10 SINGLE PRECISION
ADD C,0 ;ADD DIGIT INTO NUMBER
SOJA W,GETNXT ;GO GET NEXT CHARACTER
DPDIG: CAMLE B,MAGIC ;WILL MULTIPLY AND ADD CAUSE OVERFLOW?
AOJA X,DIGRET ;YES
IMULI B,12 ;MULTIPLY HIGH D.P. FRACTION BY 10
MULI C,12 ;MULTIPLY LOW D.P. FRACTION BY 10
ADD B,C ;ADD HI PART OF LO PRODUCT INTO RESULT
MOVE C,D ;GET LO PART OF LO PRODUCT
TLO C,(1B0) ;STOP OVERFLOW IF CARRY INTO HI WORD
ADD C,0 ;ADD DIGIT INTO FRACTION
TLZN C,(1B0) ;SKIP IF NO CARRY INTO HI WORD
ADDI B,1 ;PROPOGATE CARRY INTO HI WORD
DIGRET: SOJA W,GETNXT ;DECREMENT FIELD WIDTH AND GET NEXT CHAR
MAGIC: <377777777777-9>/^D10 ;LARGEST NUM PRIOR TO MULTIPLY AND ADD
DIGEXP: IORI F,EXPFL ;SET FLAG TO SAY WE'VE SEEN EXPONENT
CAILE XP,^D100 ;SIMPLE TEST FOR LARGNESS
SOJA W,GETNXT ;THROW DIGIT AWAY
IMULI XP,12 ;MULTIPLY BY TEN
ADD XP,0 ;ADD IN NEXT DIGIT
SOJA W,GETNXT ;DECREMENT FIELD WIDTH AND GET NEXT CHAR
; ? ,CR , . ,0-9, ,D E, + , - ,
NXTSTA: BYTE (9)
000,010,022,031,050,000,051,061,
000,011,022,031,041,053,054,074,
000,012,120,102,042,053,054,074,
000,013,120,114,043,000,054,074,
000,014,120,114,044,000,120,120
CRIN: TLNE P3,IO.TTY ;INPUT FROM TTY?
JRST ENDF1 ;YES, AS IF IN DELIMITER MODE (FREE FORMAT)
JUMPL W,ENDF1 ;FREE FORMAT?, ALREADY PASSED OVER CR-LF
BLNKIN: JUMPL W,ENDF ;FREE FORMAT
MOVEI 0,0 ;NO, CHANGE SPACE TO 0
LSH ST,-^D30 ;PUT STATE IN BITS 30-32
JRST GOT0 ;AND USE IT
ILLCH: ;[354]
DELCK: ;[354]
ERROR0: CAME W,MUN ;[357] [354] FIRST ILLEGAL CHAR IN FREE FORMAT
JUMPL W,ENDF ;[354] NO - DELIMITER OF FREE FORMAT
SKIPN ILLEG.(P4) ;ILLEGAL CHAR. FLAG SET?
ERROR (DAT,7,7,GETCH2);ILLEGAL CHARACTER IN INPUT
;**;[462],ERROR1,DPL,01-AUG-75
ERROR1: SOJLE W,ZERO ;[462] COUNT BAD CHARACTER
JSP P1,IBYTE. ;GET NEXT CHAR
TLNN P3,IO.EOL ;SEE IF AT END OF LINE?
JRST ERROR1 ;[462] NO, SKIP CHAR
JRST ZERO ;[462] YES, SET TO ZERO
ADDCNT:
ENDF:
ENDF1: SKIPGE W ;[354] CHECK FREE FORMAT
PUSHJ P,SFDEL% ;[354] YES, SAVE DELIMITER
MOVE G4,(P) ;GET THE WIDTH FIELD BACK
TRNE F,DOTFL ;HAS DECIMAL POINT BEEN INPUT?
JRST ENDF2 ;YES
LDB D,D.PNTR ;[265] NO, GET DIGITS AFTER POINT FROM FORMAT
SUB X,D ; AND MODIFY DECIMAL EXPONENT
ENDF2: HRRE D,SCL.SV(P4) ;GET SCALE FACTOR
TRNN F,EXPFL ;EXPONENT IN DATA?
SUB X,D ;NO, ADD INTO EXPONENT
TRNE F,MINEXP ;WAS D OR E EXPONENT NEGATIVE?
MOVNS XP ;YES, SO NEGATE IT
ADD X,XP ;ADD EXPONENT FROM D OR E
NORM: MOVEI BXP,306 ;INIT BINARY EXPON FOR D.P. INTEGER
JUMPN B,NORM1 ;XFER IF AT LEAST ONE 1 IN HIGH HALF
EXCH B,C ;HIGH HALF ZERO, MOVE LOW HALF TO HIGH,
;AND CLEAR LOW HALF
SUBI BXP,^D35 ;AND ADJUST EXPONENT FOR 35 SHIFTS
NORM1: MOVE A,B ;GET D.P. HIGH HALF INTO A
JFFO A,NORM2 ;ANY ONES NOW?
JRST ZERO ;NO, RESULT IS 0
NORM2: EXCH B,C ;YES, GET D.P. LOW HALF INTO B, AND
;PUT SHIFT COUNT INTO C
ASHC A,-1(C) ;NORMALIZE D.P. INTEGER WITH BIN POINT
;BETWEEN BITS 0 AND 1 IN HIGH WORD
SUBI BXP,-1(C) ;AND ADJUST EXPON TO ALLOW FOR SHIFTING
JUMPE X,ENDF6 ;IF DECIMAL EXP=0, NO MUL BY 10 NEEDED
ENDF3: MOVM D,X ;GET MAGNITUDE OF DECIMAL EXPONENT
CAILE D,PTLEN. ;BETWEEN 0 AND MAX. TABLE ENTRY?
MOVEI D,PTLEN. ;NO, MAKE IT SO
SKIPGE X ;AND RESTORE CORRECT SIGN
MOVNS D
SUB X,D ;LEAVE ANY EXCESS EXPONENT IN X
;**; [563] CHANGE @ ENDF3+6 CLRH 14-JUL-76
PUSH P,T2 ;[563] GET A REGISTER
MOVE T2,DAT.TP+2(P4) ;[563] GET VARIABLE TYPE
CAIN T2,TP%DOR ;[563] DOUBLE PRECISION ?
JRST [POP P,T2 ;[563] YES, RESTORE T2
JRST DPMUL ] ;[563] TO DPMUL
POP P,T2 ;[563] RESTORE T2
SPMUL: MUL A,HITEN.(D) ;NO, MULTIPLY BY POWER OF TEN
ENDF5: TLNE A,(1B1) ;NORMALIZED? 1.0 > RESULT >= 0.25
JRST ENDF5A ;YES, RESULT >= 0.5
ASHC A,1 ;NO, SHIFT LEFT ONE PLACE
SUBI BXP,1 ;AND ADJUST EXPONENT
ENDF5A: IDIVI D,4 ;CONVERT DEC EXP TO BINARY EXPONENT
LDB D,EXTAB.(D+1) ;BY TABLE LOOKUP
ADDI BXP,-200(D) ;ADJUST BINARY EXPONET (LESS EXCESS 200)
JUMPN X,ENDF3 ;ANY MORE DECIMAL EXPONENT LEFT?
ENDF6: TLO A,(1B0) ;NO, START ROUNDING (ALLOW FOR OVERFLOW)
;**; [563] CHANGE @ ENDF6+1 CLRH 14-JUL-76
PUSH P,T2 ;[563] GET A REGISTER
MOVE T2,DAT.TP+2(P4) ;[563] GET VARIABLE TYPE
;**; [654] INSERT AT ENDF6+2 SWG 26-APR-77
CAIE T2,TP%INT ;[654] INTEGER? MUST NOT BE ROUNDED AS
;[674] SINGLE PRECISION OR LOSES 8 BITS
CAIN T2,TP%DOR ;[563] DOUBLE PRECISION ?
JRST [POP P,T2 ;[563] YES, RESTORE T2
JRST DPRND ] ;[563] TO DPRND
POP P,T2 ;[563] RESTORE T2
SPRND: ADDI A,200 ;NO, ROUND IN HIGH WORD
TRZ A,377 ;GET RID OF USELESS (UNUSED) BITS
MOVEI B,0 ; DITTO
ENDF7: TLZE A,(1B0) ;CARRY PROPOGATE TO BIT 0?
JRST ENDF7A ;NO
ASHC A,-1 ;YES, RENORMALIZE TO RIGHT
ADDI BXP,1 ;AND ADJUST BINARY EXPONENT
TLO A,(1B1) ;AND TURN ON HI FRACTION BIT
ENDF7A: TRNE BXP,777400 ;IS BINARY EXPONENT TOO LARGE
JRST BADEXP ;YES, RETURN ZERO OR INFINITY
ASHC A,-8 ;NO, LEAVE ROOM FOR EXPONENT
DPB BXP,[POINT 9,A,8] ;INSERT EXPONENT INTO HI WORD
IFE CPU-KA10,<
;**; [563] CHANGE @ ENDF7A+4 (IN IFE CPU-KA10) CLRH 14-JUL-76
PUSH P,T2 ;[563] GET A REGISTER
MOVE T2,DAT.TP+2(P4) ;[563] GET VARIABLE TYPE
CAIE T2,TP%DOR ;[563] SINGLE PRECISION ?
JRST [POP P,T2 ;[563] YES, RESTORE T2
JRST ENDF8 ] ;[563] AND TO ENDF8
POP P,T2 ;[563] RESTORE T2
ASH B,-8 ;YES, ALLOW ROOM FOR LOW EXPONENT
JUMPE B,ENDF8 ;IS LOW FRACTION ALL ZERO?
SUBI BXP,^D27 ;NO, INSERT EXPONENT 27 SMALLER THAN
DPB BXP,[POINT 9,B,8] ; HIGH EXPONENT
ENDF8: >
RETURN: TLZN P2,FT.INC ;[445] FLINC TYPE CONVERSION
JRST RETRN2 ;[445] NO
HLRE C,A ;[445] YES-GET THE EXPONENT
ASH C,-9 ;[445] RIGHT 8 BITS
TLZ A,777000 ;[445] CLEAR THE EXPONENT
ASHC A,-201-^D26(C) ;[445] CHANGE FRACTION TO INTEGER
TLZ P2,FT.PRC ;[445] CLEAR DP FLAG
RETRN2: TRNE F,MINFR ;[445] RESULT NEGATIVE?
DFN A,B ;[445] YES, SO NEGATE RESULT
POP P,G4 ;RESTORE G4
; POP P,G3 ;RESTORE
POP P,G2
POP P,G1 ;NOT REQUIRED
MOVEM T0,(G1) ;STORE IN USER AREA
;**; RETRN2+7L CLRH 14-JUL-76
PUSH P,T2 ;[563] SAVE T2
MOVE T2,DAT.TP+2(P4) ;[563] GET VARIABLE TYPE
CAIN T2,TP%DOR ;[563] DOUBLE PRECISION ?
MOVEM T1,1(G1) ;YES, STORE LOW ALSO
;**; [563] INSERT @ RETRN2+8 1/2 L CLRH 14-JUL-76
POP P,T2 ;[563] RESTORE T2
POPJ P, ;RETURN TO USER
BADEXP: HRLOI A,377777 ;SET NUMBER TO LARGEST POSSIBLE
JUMPSP .+2 ;SKIP IF SINGLE PRECISION
IFN CPU-KA10,< HRLOI B,377777 > ;FOR PDP-6 OR KI10
IFE CPU-KA10,< HRLOI B,344777 > ;FOR KA10
TRNE BXP,1B18 ;IF EXPONENT IS NEGATIVE
ZERO: SETZB A,B ;SET TO ZERO
JRST RETURN
POINT 9,EXP10.-1(D),17
POINT 9,EXP10.-1(D),26
POINT 9,EXP10.-1(D),35
EXTAB.: POINT 9,EXP10.(D),8
POINT 9,EXP10.(D),17
POINT 9,EXP10.(D),26
POINT 9,EXP10.(D),35
;HERE FOR DOUBLE PRECISION MULTIPLY, ROUNDING
DPMUL: MUL B,HITEN.(D) ;LO FRAC TIMES HI POWER OF TEN(RESULT IN B,C)
MOVE P1,B ;GET HI PART OF PREVIOUS PRODUCT OUT OF WAY
MOVE B,A ;COPY HI PART OF FRACTION
MUL B,LOTEN.(D) ;HI FRAC TIMES LO POWER OF TEN
TLO P1,(1B0)
ADD P1,B ;SUM OF HI PARTS OF CROSS PRODUCTS TO AC T
MUL A,HITEN.(D) ;HI FRACTION TIMES HI POWER OF TEN
TLON P1,(1B0) ;DID CARRY OCCUR? ALLOW FOR NEXT CARRY
ADDI A,1 ;CARRY FROM ADDING CROSS PRODUCTS
ADD B,P1 ;ADD CROSS PRODUCTS TO LO PART
; OF (HI FRAC TIMES HI POW TEN)
TLZN B,(1B0)
AOJA A,ENDF5 ;AND PROPOGATE A CARRY, IF ANY
JRST ENDF5 ;GO NORMALIZE RESULT
DPRND: TLO B,(1B0) ;START ROUNDING (ALLOW FOR CARRYS)
IFN CPU-KA10,< ADDI B,200 > ;LOW WORD ROUNDING FOR PDP-6 OR KI10
IFE CPU-KA10,<
CAIGE BXP,^D27 ;KA10 LOW EXPONENT UNDERFLOW?
JRST SPRND ;YES, ROUND IN HIGH WORD
ADDI B,100000 > ;NO, KA10 ROUND IN LOW WORD
TLZN B,(1B0) ;DID CARRY PROPOGATE TO SIGN?
AOJA A,ENDF7 ;YES, ADD CARRY INTO HIGH WORD
JRST ENDF7 ;AND GO RENORMALIZE IF NECESSARY
PRGEND
TITLE FLOUT% %5A(660) FLOATING POINT OUTPUT
SUBTTL D. NIXON AND T. W. EGGERS
SUBTTL D. TODD /DMN/DRT/HPW/MD/JNG/CLRH 21-JUL-76
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH FORPRM ;GET FOROTS GLOBAL SYMBOL TABLE
; DEFINE THE LOADING PARAMETERS
SEGMEN
;OLD ACCUMULATOR DEFINITIONS
;OLD ACCS
AC0==T0 ;FLOATING POINT NO. ON ENTRY
AC1==T1 ;USED IN FORMING DIGITS
AC2==T2 ;DITTO. D.P. ONLY
XP==T3 ;DECIMAL EXPONENT
D==T4 ;D, NO. OF DIGITS AFTER DEC. POINT
W==T5 ;FIELD WIDTH/NO. OF BLANKS TO OUTPUT
C==T5 ;CNTR./NO. OF CHARS BEFORE DEC. POINT
SF==G1 ;SCALE FACTOR
F==P4 ;FLAGS (IN UNUSED BITS)
NUMSGN==1 ;NEGATIVE NUMBER
DIGEXH==2 ;DIGITS EXHAUSTED
NOSIGN==4 ;NO SPACE FOR + SIGN
;**; [566] IN P4 LEFT DEFINITIONS CLRH 21-JUL-76
EQZER==10 ;[566] ITEM IS IDENTICALLY ZERO
;**;[660] FLOUT% SJW 26-MAY-77 BIND SPMAX TO 8 NOT 9
SPMAX==8 ;[660]MAXIMUM NO. OF DIGITS TO OUTPUT (SINGLE PRECISION)
IFE CPU-KA10,<DPMAX==^D16> ;DITTO. (DOUBLE PRECISION)
IFN CPU-KA10,<DPMAX==^D18>
DPMIN==SPMAX ;NO. OF DIGITS IF LS. WORD IS NOT SIGNIFICANT
FT.FTP==-<FT.ETP!FT.PRC!FT.GTP>
ENTRY FLOUT%
EXTERN OBYTE.,EXP10.,HITEN.,LOTEN.,PTLEN.
EXTERN W.PNTR,D.PNTR ;[265]
FLOUT%:
PUSH P,P4 ;SAVE ACCS
PUSH P,P2 ;SOME FLAGS ARE CHANGED
PUSH P,G1 ;SAVE ALL G ACCS
PUSH P,G2 ;GLOBAL AC'S MUST BE SAVE BOTTOM TO TOP
PUSH P,G3 ;
PUSH P,G4 ;G4 MUST BE LAST ON THE STACK
RETRY: MOVE T0,(G1) ;LOAD AC 0 WITH NUMBER
SETZ T1, ;[%441] CLEAR LOW WORD
MOVE XP,DAT.TP+2(P4) ;[345][%441] GET VARIABLE TYPE
;**; [563] CHANGE @ RETRY+3 CLRH 14-JUL-76
CAIN XP,TP%DOR ;[563] DOUBLE PRECISION ?
SKIPA T1,1(G1) ;[220] YES, GET LOW WORD ALSO
RETRY1: FADRI T0,0 ;[%441] FORCE NORMALIZATION
;**; [566] CHANGE @ RETRY1+1 CLRH 21-JUL-76
TLZ P4,NUMSGN!DIGEXH!NOSIGN!EQZER ;[566]
SETZ XP, ;CLEAR EXPONENT
JUMPGE AC0,FLOUT1 ;NUMBER NEGATIVE?
DFN AC0,AC1 ;YES, NEGATE IT
TLOA F,NUMSGN ;AND - SET SIGN FLAG
FLOUT1: JUMPE AC0,FLOUT6 ;ESCAPE IF ZERO
HLRZ G2,AC0 ;EXTRACT EXPONENT
LSH G2,-9
IFE CPU-KA10,<CAIL G2,^D27 ;LOW HALF INVALID?
JRST .+3 ;NO
TLZE P2,FT.PRC ;YES, SINGLE PRECISION ONLY
TLO P2,FT.ETP ;IF D.P., FORCE E TYPE
LSH AC1,8 ;GET RID OF LOW EXP>
TLZ AC0,777000 ;GET RID OF HIGH EXP
ASHC AC0,8 ;PUT BIN POINT BETWEEN BITS 0 AND 1
FLOUT2: HRREI G3,-200+2(G2) ;GET RID OF EXCESS 200, +2 IS A DIDDLE
IMULI G3,232 ;DEC EXP=LOG10(2)*BIN EXP=.232(OCTAL)*BIN EXP
ASH G3,-^D9 ;GET RID OF 3 OCTAL FRACTION DIGITS
;T1 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
MOVM G4,G3 ;GET MAGNITUDE OF *10 SCALER
CAIGE G4,PTLEN. ;IS THE POWER OF 10 TABLE LARGE ENOUGH
JRST FLOUT3 ;YES
SKIPL G3 ;NO, SCALE 1ST BY LARGEST ENTRY
SKIPA G3,[PTLEN.] ;GET ADR OF LARGEST POSITIVE POWER OF 10
MOVNI G3,PTLEN. ;GET ADR OF LARGEST NEG POWER OF 10
JUMPDP [ ;DOUBLE PRECISION
PUSHJ P,DPMUL ;SCALE BY LARGE POWER OF 10
JRST FLOUT2] ;GO DO 2ND SCALING
PUSHJ P,BINEXP ;GET CORRESPONDING BINARY POWER OF 2
PUSHJ P,FLODIV ;SCALE NUMBER BY A LARGE POWER OF 10
JRST FLOUT2 ;AND GO DO THE SECOND SCALING
;GET BINARY EXPONENT OF POWER OF 10, GIVEN DECIMAL EXP
BINEXP: MOVE G4,G3 ;COPY DECIMAL POWER OF 10
LSHC G4,-2 ;DIVIDE BY 4, EXP10. HAS 4 ENTRIES/WORD
TLNE P1,(1B0) ;WHICH HALF OF WORD?
SKIPA G4,EXP10.(G4) ;RIGHT HALF
HLRZ G4,EXP10.(G4) ;LEFT HALF
TLNN P1,(1B1) ;WHICH QUADRANT
LSH G4,-^D9 ;1ST OR 3RD
ANDI G4,777 ;MASK TO SIZE
POPJ P,
;SCALE DOUBLE FRACTION BY A POWER OF 10
DPMUL: JUMPE G3,CPOPJ ;IF DEC EXP IS 0, RETURN
ADD XP,G3 ;PUT DEC SCALE FACTOR INTO XP
MOVN G3,G3 ;TAKE RECIPROCAL OF EXPONENT
PUSHJ P,BINEXP ;GET CORRESPONDING BIN EXP
ADDI G2,-200(G4) ;ADD POWER EXP INTO FRAC EXP
MUL AC1,HITEN.(G3) ;FORM FIRST CROSS PRODUCT
MOVE G4,AC0 ;COPY HI FRACTION
MUL G4,LOTEN.(G3) ;FORM 2ND CROSS PRODUCT
TLO G4,(1B0) ;AVOID OVERFLOW
ADD G4,AC1 ;ADD CROSS PRODUCTS
MUL AC0,HITEN.(G3) ;FORM HI PRODUCT
TLON G4,(1B0) ;DID CROSS PRODUCT OVERFLOW
ADDI AC0,1 ;YES
ADD AC1,G4 ;ADD CROSS PRODUCTS IN
TLZN AC1,(1B0) ;OVERFLOW?
ADDI AC0,1 ;YES
TLNE AC0,(1B1) ;NORMALIZED?
POPJ P, ;YES
ASHC AC0,1 ;NO, SHIFT LEFT ONE
SOJA G2,CPOPJ ;AND ADJUST EXPONENT
;SCALE SINGLE FRACTION BY A POWER OF 10
FLODIV: JUMPE G3,CPOPJ ;IF DEC EXP IS ZERO, RETURN
ADD XP,G3 ;PUT DEC SCALE FACTOR INTO XP
SUBI G2,-200-1(G4) ;SUB BIN POWER OF 10 EXP FROM BIN FRACTION EXP
;REMOVE EXCESS 200; -1 ALLOWS FOR ASHC
;LEFT HALF OF T GETS GARBAGED
MOVEI AC1,0 ;CLEAR LOW WORD OF BIN FRACTION
CAMGE AC0,HITEN.(G3) ;WILL DIV CAUSE DIVIDE CHECK?
SOJA G2,.+2 ;NO, ALLOW FOR NOT DOING ASHC
ASHC AC0,-1 ;YES, SCALE FRACTION
DIV AC0,HITEN.(G3) ;SCALE FRACTION BY POWER OF 10
CPOPJ: POPJ P, ;RETURN
FLOUT3: PUSHJ P,BINEXP ;GET BIN EXP THAT MATCHES DEC EXP
;**; [563] CHANGE @ FLOUT3+1 CLRH 14-JUL-76
PUSH P,T2 ;[563] SAVE T2
MOVE T2,DAT.TP+2(P4) ;[563] GET VARIABLE TYPE
CAIN T2,TP%DOR ;[563] DOUBLE PRECISION ?
JRST [POP P,T2 ;[563] YES, RESTORE T2
JRST FLOT3A ] ;[563] LEAVE
POP P,T2 ;[563] RESTORE T2
CAILE G4,(G2) ;IS THIS POWER OF 10 .GT. FRACTION?
JRST FLOUT4 ;YES, IN THE EXPONENT
CAIN G4,(G2) ;MAYBE, LOOK AT EXPONENTS SOME MORE
CAML AC0,HITEN.(G3) ;EXPONENTS THE SAME, COMPARE FRACTIONS
AOJA G3,FLOUT3 ;POWER OF 10 IS ONE TOO SMALL
FLOUT4: PUSHJ P,FLODIV ;POWER OF 10 IS OK, DO THE SCALING
ASH AC0,-200(G2) ;SCALE FRACTION RIGHT BY ANY REMAINING POWERS OF 2
JRST FLOUT6
FLOT3A: CAILE G4,(G2) ;FRACTION .GT. POWER OF 10?
JRST FLOT4A ;YES
CAIE G4,(G2)
AOJA G3,FLOT4A ;NOT IN EXPONENT
CAMGE AC0,HITEN.(G3) ;
JRST FLOT4A ;YES, IN HIGH FRACTION
CAMN AC0,HITEN.(G3)
CAML AC1,LOTEN.(G3)
ADDI G3,1 ;NO, IN FRACTION PART
FLOT4A: PUSHJ P,DPMUL ;SCALE BY POWER OF 10
ASHC AC0,-200(G2) ;SCALE BY ANY REMAINING POWERS OF 2
FLOUT6: MOVE G4,(P) ;GET THE FIELD PARAMETERS
LDB W,W.PNTR ;[265]
LDB D,D.PNTR ;[265]
HRRE SF,SCL.SV(P4) ;GET THE SCALING FACTOR
;**; [544] INSERT @ FLOUT6+3 1/2 CLRH 11-MAY-76
JUMPN AC0,FLOU6A ;[544] SKIP THIS IF NOT IDENTICALLY ZERO
;**; [566] INSERT @ FLOUT6+4 1/2 CLRH 21-JUL-76
TLO P4,EQZER ;[566] FLAG IDENTICALLY ZERO
MOVN XP,SF ;[544] MAKE DECIMAL EXPONENT SCALING FACTOR
SOJ XP, ;[544] NEGATED, LESS ONE, FOR ZERO ONLY
FLOU6A: JUMPN W,FLOUT7 ;[544]
TLNE P2,FT.PRC ;DOUBLE PRECISION?
ADDI W,1 ;YES, INCREMENT INDEX INTO TABLE
HRRZ D,FRMTAB(W) ;PICKUP DEFAULT FORMAT FOR D
HLRZ W,FRMTAB(W) ;SAME FOR W
FLOUT7: TLNN P2,FT.GTP ;G TYPE CONVERSION
JRST FLOUT8 ;NO
CAME XP,[-1]
CAMLE XP,D
TLO P2,FT.ETP ;SET E TYPE CONVERSION
FLOUT8: MOVE G3,D
TLNN P2,FT.ETP!FT.PRC
JRST .+3
JUMPLE SF,FLOUT9
AOJA G3,FLOU10
TLNE P2,-FT.FTP
JRST FLOU10
ADD G3,XP
FLOUT9: ADD G3,SF
FLOU10: CAILE G3,DPMAX ;TOO MANY DECIMAL PLACES
MOVEI G3,DPMAX ;YES, REDUCE TO MAX POSSIBLE
;**; [563] CHANGE @ FLOU10+2 CLRH 14-JUL-76
PUSH P,T2 ;[563] SAVE T2
MOVE T2,DAT.TP+2(P4) ;[563] GET VARIABLE TYPE
CAIE T2,TP%DOR ;[563] DOUBLE PRECISION ?
CAIGE G3,SPMAX ;TOO MANY DECIMAL PLACES?
JRST DIGOK ;NO, SIZE OK
MOVEI G3,SPMAX ;YES, REPLACE BY MAX PERMITTED
TLNN G4,W.MASK## ;[266] FREE FORMAT?
SUBI G3,1 ;YES, ONE LESS DIGIT HELPS ROUNDING
;**;[563] INSERT @ DIGOK CLRH 14-JUL-76
DIGOK: POP P,T2 ;[563] RESTORE T2
MOVE G2,P ;[563] MARK BOTTOM OF DIGIT STACK
PUSH P,[0] ;AND ALLOW FOR POSSIBLE OVERFLOW
SKIPGE G4,G3 ;GET # OF DIGITS INTO T2
MOVEI G4,0 ;IF NEGATIVE, ADD 0.5 TO FRACTION
ADD AC0,RNDHGH(G4) ;ROUND HI WORD TO CORRECT NUMBER OF DIGITS
;**; [563] CHANGE @ DIGOK+5 CLRH 14-JUL-76
PUSH P,T2 ;[563] SAVE T2
MOVE T2,DAT.TP+2(P4) ;[563] GET VARIABLE TYPE
CAIN T2,TP%DOR ;[563] DOUBLE PRECISION ?
JRST [POP P,T2 ;[563] RESTORE T2
JRST DIGOK3 ] ;[563] SKIP THIS
POP P,T2 ;[563] RESTORE T2
ADDI AC0,2 ;NO ROUND SLIGHTLY MORE
TLZN AC0,(1B0) ;DID CARRY PROPOGATE TO BIT 0?
AOS (P) ;YES, PROPOGATE CARRY TO LEADING 0
FLOU11: MULI AC0,^D10 ;MULTIPLY BY 10
PUSH P,AC0 ;STORE DIGIT ON DIGIT STACK
MOVE AC0,AC1 ;AND SET UP NEW FRACTION
SOJG G4,FLOU11
JRST FLOU13
DIGOK3: ADD AC1,RNDLOW(G4) ;ROUND LOW
TLZN AC1,(1B0) ;CARRY?
ADDI AC0,1 ;YES
TLZN AC0,(1B0) ;DID CARRY PROPAGATE TO BIT 0
AOS (P) ;YES , LEADING DIGIT IS A 1
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
SOJG G4,FLOU12 ;LOOP
;FALL INTO FLOU13
FLOU13: MOVEI G4,2(G2) ;GET BASE OF STACKED DIGITS
MOVE P1,1(G2)
JUMPE P1,FLOU14 ;DID OVERFLOW OCCUR?
SUBI G4,1 ;YES - MOVE BACK BASE POINTER
ADDI XP,1 ;NO, INCREMENT EXPONENT
FLOU14: TLNE P2,FT.GTP
TLNE P2,FT.ETP!FT.PRC
JRST FLOU15
SKIPL XP
CAIGE D,(XP) ;WILL F FORMAT FIT?
JRST [TLO P2,FT.ETP
JUMPE SF,FLOU15
MOVE P,G2
MOVE G1,-3(P) ;RELOAD G1
JRST RETRY]
SETZ SF,
FLOU15: SUBI C,2(D) ;SIGN, POINT AND CHARS. FOLLOWING
TLNE P2,FT.ETP!FT.PRC
JRST FLOU16
;HERE FOR F TYPE CONVERSION
ADD SF,XP ;COUNT THE LEADING DIGITS
TLNE P2,FT.GTP
JRST [SUBI D,(XP) ;NO, REDUCE CHAR. AFTER POINT FOR F
JRST FLOU17] ;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: JUMPE SF,FLOU17
JUMPG SF,[SUBI D,-1(SF)
JUMPGE D,FLOU17
ADD C,D
JRST FLOU17]
MOVM SF,SF
CAML D,SF
JRST FLOU18
ADD C,D
SUB C,SF
FLOU18: MOVN SF,SF
FLOU17: SUBI C,4 ;ALLOW FOR E+00
TRYFIT: TLNE P2,FT.ETP!FT.PRC ;[377] SPECIAL FOR F FORMAT
SKIPG SF ;[373] POSITIVE SCALING FACTOR
JUMPGE C,FIT ;[373] NO-WILL FIT FORMAT
JUMPG C,FIT ;[373] YES-WILL FIT
TLNE F,NUMSGN ;[373] IS SIGN POSITIVE
JRST TRYFI0 ;[373] NO
TLNE P2,FT.ETP!FT.PRC ;[377] SPECIAL FOR F FORMAT
SKIPG SF ;[373] POSITIVE SCALING FACTOR
AOJE C,POSIGN ;[373] NO-YES, ALLOW IT
JUMPE C,POSIGN ;[373] YES-YES, ALLOW IT
TRYFI0: TLNN P2,FT.ETP!FT.PRC ;[373] IF E FORMAT
TLZN P2,FT.GTP ;WAS IT G TO F CONVERSION?
JRST NOFIT ;E TYPE OR NOT G TO F
;**;[476] Change @ TRYFI0+3L JNG 22-Nov-75
ADDI C,4 ;[476] REMOVE 4 TRAILING SPACES
JRST TRYFIT ;AND TRY AGAIN
NOFIT:
IFN ASTFL,<MOVE P,G2 ;RESTORE STACK POINTER
POP P,G4 ;RESTORE THE WIDTH SPECS
TLNN G4,W.MASK## ;[266] FREE FORMAT?
TLO G4,17 ;[266] YES - SET FIELD WIDTH
ERROR (DAT,5,2,RETRNF) ;OUTPUT ASTERICKS>
IFE ASTFL,<ADD SF,C ;LESS DIGITS TO OUTPUT
ADD G3,C ;AND LESS IN STACK
SUB G4,C ;ADJUST STACK POINTER>
FIT: CAIG C,1 ;SPACE FOR LEADING BLANKS?
JRST GO2ERF ;NO LEADING BLANKS
TLNN P2,FT.LSD ;LEADING BLANK FILL WANTED
JSP P1,SPACE ;YES, OUTPUT ONE
SOJA C,FIT ;UNTIL ENOUGH
POSIGN: TLO F,NOSIGN ;SIGNAL NO ROOM FOR + SIGN
GO2ERF: TLNN P2,FT.ETP!FT.PRC ;TEST FLOATING POINT FLAGS
JRST FFORM ;NO, USE FIXED POINT
;FALL INTO EFORM
;E FORMAT
EFORM: JUMPN G3,.+2 ;CHECK FOR NO SIGNIFICANT DIGITS
TLO F,DIGEXH ;ENSURE ZEROES WILL BE PRINTED
SUB XP,SF ;SCALE EXPONENT
JUMPLE SF,EFORM1 ;JUMP IF NOT POSITIVE SCALING
;HAVE 1 DIGIT BEFORE POINT
JSP P1,SIGN ;OUTPUT SIGN
PUSH P,SF
JSP P1,DIGIT ;OUTPUT LEADING DIGITS
SOJN G3,.+2 ;COUNT EXPIRED?
TLO F,DIGEXH ;YES
SOJN SF,.-3 ;RETURN FOR MORE
POP P,SF
SOJA SF,EFORM2 ;SKIP LEADING ZERO
EFORM1: JSP P1,SIGN ;OUTPUT SIGN
JUMPLE C,EFORM2 ;NO SPACE LEFT FOR "0"
JSP P1,ZERO ;OUTPUT ZERO
EFORM2: JSP P1,PERIOD ;AND DECIMAL POINT
JUMPGE SF,EFORM3 ;ACCOUNT FOR POS SCALING
ADD D,SF ;NOT SO MANY DIGITS NOW
JSP P1,ZERO ;BY OUTPUTTING ZEROS
AOJL SF,.-1
EFORM3: JUMPLE D,EFORM4 ;IF NOT ANY DIGITS AFTER POINT
JSP P1,DIGIT ;OUTPUT FRACTIONAL DIGIT
SOJN G3,.+2 ;TOTAL COUNT EXPIRED?
TLO F,DIGEXH ;YES - FLAG DIGITS EXHAUSTED
SOJG D,.-3 ;RETURN IF MORE DIGITS
EFORM4: MOVEI AC0,"E"
TLNE P2,FT.PRC ;DOUBLE PRECISION?
MOVEI AC0,"D" ;YES, GIVE USUAL D INSTEAD
JSP P1,OBYTE. ;OUTPUT "E" OR "D"
;**; [566] INSERT @ EFORM4 + 3 1/2 CLRH 21-JUL-76
TLNE P4,EQZER ;[566] EXACT ZERO ?
SETZ XP, ;[566] YES, ZERO THE EXPONENT ALSO
JUMPGE XP,EFORM5
TLO F,NUMSGN ;TYPE MINUS IF EXPONENT NEGATIVE
EFORM5: JSP P1,PLUS ;PRINT SIGN
MOVEI C,2 ;AND SET DIGIT COUNT
MOVE P,G2 ;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
SKIPLE C ;ANY ROOM?
JSP P1,SPACE ;YES, ANOTHER BLANK THEN
JSP P1,SIGN ;OUTPUT SIGN
JSP P1,DIGIT ;OUTPUT INTEGRAL DIGIT
SOJG G3,.+2 ;TOTAL COUNT EXPIRED?
TLO F,DIGEXH ;YES - FLAG DIGITS EXHAUSTED
SOJG SF,.-3 ;RETURN IF MORE DIGITS
JSP P1,PERIOD ;PRINT DECIMAL POINT
FFORM1: JUMPE D,FFORM2 ;TEST FOR DIG AFTER POINT
JSP P1,DIGIT ;OUTPUT FRACTIONAL DIGIT
SOJG G3,.+2 ;TOTAL COUNT EXPIRED?
TLO F,DIGEXH ;YES - FLAG DIGITS EXHAUSTED
SOJG D,FFORM1 ;RETURN IF MORE DIGITS
FFORM2: MOVE P,G2 ;RESTORE STACK
TLNN P2,FT.GTP ;G FORMAT REQUIRES 4 BLANKS
JRST RETRNO ;FINISHED
MOVEI C,4 ;SET FOR 4
JSP P1,SPACE ;BLANKS
SOJG C,.-1
JRST RETRNO ;FINISHED
FFORM3: ADD D,SF ;REDUCE D IF SF NEGATIVE
JUMPG D,FFRM3A ; [517] IF D FIELD, GO TRY
JUMPG C,FFRM3A ; [517] IF ROOM FOR SIGN, GO DO IT
TLNE F,NUMSGN ; [517] IF MINUS SIGN, NO ROOM ANYWAYS
IFN ASTFL,<JRST NOFIT> ; [517] ASTERISK IT OUT (A LITTLE LATE)
IFE ASTFL,<JFCL> ; [517] NO *'S, CONTINUE
TLON F,NOSIGN ; [517] ELSE SET NO ROOM FOR + SIGN
ADDI C,1 ; [517] AND PUT BACK THE SPACE IT TOOK, IF ANY
FFRM3A: JSP P1,SIGN ; [517] OUTPUT SIGN
SKIPLE C ;IF ROOM FOR IT
JSP P1,ZERO ;OUTPUT "0"
JSP P1,PERIOD ;AND DEC. POINT
JUMPGE D,.+4 ;IF D IS NEG. SF IS TOO BIG
LDB SF,[POINT 6,(G2),10] ;GET THE D FIELD SIZE
MOVNS SF ;SO USE DIGIT WIDTH FOR ZEROS
SETZ D, ;AND NO DIGITS
JUMPE SF,FFORM1 ;NOW FOR DIGITS
JSP P1,ZERO ;ZERO AFTER POINT
AOJA SF,.-2 ;LOOP ON ZEROS
; OUTPUT ROUTINES
PERIOD: MOVEI AC0,"." ;DECIMAL POINT
PJSP OBYTE. ;PRINT AND RETURN
SPACE: MOVEI AC0," " ;SPACE
PJSP OBYTE.
ZERO: MOVEI AC0,"0"
JRST OBYTE.
PLUS: MOVEI AC0,"+"
JRST SIGN1
SIGN: TLZE F,NOSIGN ;NO ROON FOR SIGN?
JRSTF @P1 ;JUST RETURN
MOVEI AC0," "
SIGN1: TLZE F,NUMSGN ;ALWAYS CLEAR FLAG
MOVEI AC0,"-" ;SELECT SIGN
PJSP OBYTE. ;AND PRINT
DIGIT: MOVEI AC0,"0"
TLNE F,DIGEXH ;DIGITS EXHAUSTED?
JRST OBYTE.
MOVE AC0,(G4) ;GET NEXT DIGIT
ADDI AC0,"0" ;CONVERT TO ASCII
AOJA G4,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
JSP P1,ZERO ;YES - PRINT ONE
SOJA C,OUTP3 ;AND DECREASE UNTIL FINISHED
OUTP4: POP P,AC0 ;POP UP DIGIT
ADDI AC0,"0" ;ADD ASCII OFFSET
JSP P1,OBYTE. ;AND PRINT IT
SOJN XP,OUTP4 ;REPEAT UNTIL FINISHED
RETRNO:
POP P,G4 ;RESTORE THE STACK
RETRNF: POP P,G3 ;G4 IS RESTORE BEFORE ASTERICK FILL ROUTINE CALL
POP P,G2
POP P,G1
POP P,P2
POP P,P4
POPJ P, ; EXIT FROM ROUTINE
FRMTAB: 17,,7
DPMAX+8,,DPMAX
;ROUNDING TABLE
;THE SIGN BIT SET PREVENTS OVERFLOW WHEN ADDED
; INTO THE BINARY FRACTION
;ALL NUMBERS BELOW ARE ROUNDED UP ALWAYS
DEFINE TABLE <
ROUND 200000000000,000000000000,0 ;0.5E0
ROUND 014631463146,146314631463,2 ;0.5E-1
ROUND 001217270243,327024365605,1
ROUND 000101422335,057065176763,7
ROUND 000006433342,353070414545,1
ROUND 000000517426,261070664360,5 ;0.5E-5
ROUND 000000041433,336405536661,6
ROUND 000000003265,374515274536,5
ROUND 000000000253,314356106043,0
ROUND 000000000021,056027640466,7
ROUND 000000000001,267633766353,8 ;0.5E-10
ROUND 000000000000,053765777027,5
ROUND 000000000000,004313631402,3
ROUND 000000000000,000341134115,0
ROUND 000000000000,000026411156,1
ROUND 000000000000,000002200727,8 ;0.5E-15
ROUND 000000000000,000000163225,5
ROUND 000000000000,000000013416,9
ROUND 000000000000,000000001116,2
;ROUND 000000000000,000000000073,0
;ROUND 000000000000,000000000005,9 ;0.5E-20
;ROUND 000000000000,000000000000,5 ;0.5E-21
>
DEFINE ROUND (A,B,C)< A+1B0>
RNDHGH: TABLE
DEFINE ROUND (A,B,C)< B+1B0+1>
RNDLOW: TABLE
PRGEND
TITLE INTEG% %4.(367) DECIMAL INTEGER INPUT/OUTPUT FORTRAN IV
SUBTTL D. TODD/DRT/HPW/MD 06-SEP-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) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH FORPRM ;GET FOROTS GLOBAL SYMBOL TABLE
; DEFINE THE LOADING PARAMETERS
SEGMEN
ENTRY INTEG%
EXTERN IBYTE.,OBYTE.,W.PNTR ;[265]
EXTERN GFDEL%,SFDEL%,SKIP%,MUN ;[354]
INTEG%: ;INTEGER INPUT/OUTPUT CONVERSION ROUTINE
LDB T3,W.PNTR ;[265] GET THE FIELD WIDTH
SETZB T5,T2 ;CLEAR STORAGE
JUMPO INTO ;GO TO INTO (OUTPUT)
JSP P1,GFDEL% ;[354] RETRIEVE DELIMITER IF ANY
JUMPG T3,INTI1B ;[354] FIELD WIDTH SPECIFIED
SETO T3, ;SET VARIABLE FIELD FLAG
PUSHJ P,SKIP% ;[354] SKIP SPACES
JRST INTI6 ;[354] COMMA OR EOL (NULL FIELD)
JRST INTI1B ;[354] PROCESS FIELD
INTI1: JUMPE T3,INTI6 ;FIELD EXHAUSTED
JSP P1,IBYTE. ;NO, GET NEXT INPUT CHARACTER
INTI1B: CAIG T0,"9" ;CHECK FOR A
CAIGE T0,"0" ;DECIMAL DIGIT (0-9)
JRST INTI3 ;NOT A DECIMAL DIGIT
TLO T2,400000 ;SET DIGIT SEEN FLAG
TLNE T2,100000 ;HAS THE FIELD OVERFLOWED
SOJA T3,INTI1 ;YES, DO NOT ACCUMULATE THE SUM
INTI1A: ANDI T0,17 ;MAKE A BINARY NUMBER
IMULI T5,12 ;MULT OUTPUT BY A POWER OF 10
JFCL 11,INTI2 ;FIELD OVERFLOW
ADD T5,T0 ;ACCUMULATE THE SUM
SOJA T3,INTI1 ;GET NEXT DIGIT
INTI2: TLO T2,100000 ;SET FIELD OVERFLOW FLAG
SOJA T3,INTI1 ;GET NEXT INPUT CHARACTER
INTI3: TLNE P3,IO.EOL ;IS THIS THE END OF LINE
JRST INTI5 ;[367] YES
CAIN T0,11 ;<TAB>
MOVEI T0," " ;CLEAR THE <TAB> CHARACTER
CAIE T0," " ;CHECK FOR A BLANK
JRST INTI3A ;NOT A BLANK OR <TAB>
JUMPGE T3,INTI1A ;YES, CONTINUE IF NOT FREE FORM
JUMPGE T2,INTI1 ;NO DIGITS CONTINUE SCAN IF FREE FORM
INTI3A: JUMPL T2,INTI4 ;DIGIT SEEN YET
CAIN T0,"-" ;NO, IS THIS A MINUS SIGN
TLOA T2,200000 ;YES, SET THE FLAG
CAIN T0,"+" ;CKECK FOR A PLUS
SOJA T3,INTI1 ;YES, GET NEXT CHARACTER
INTI4: CAME T3,MUN ;[354] IF FIRST CHAR THEN ILLEGAL
JUMPL T3,INTI6 ;NO, CHECK FOR VARIABLE FIELD
ERROR (DAT,7,7,INTI1B);ILLEGAL CHARACTER IN INPUT
INTI5: TLNN P3,IO.TTY ;IS THIS A TELETYPE
JUMPGE T3,INTI1A ;NO, VARIABLE FIELD
INTI6: TLZ T5,400000 ;YES, TTY END OF LINE OF W=0
TLNE T2,200000 ;CHECK FOR SIGN
MOVNS T5 ;MINUS (NEGATE THE RESULT)
MOVEM T5,(G1) ;PUT RESULT IN USER'S VARIALBLE
PJMPL T3,SFDEL% ;[354] SAVE DELIMITER IF NECESSARY
POPJ P, ;RETURN TO FOROTS
INTO: ;INTEGER OUTPUT ROUTINE
SKIPN T3 ;CHECK FOR W=0
MOVEI T3,17 ;SET DESCRIPTOR TO I15
SKIPG T4,(G1) ;GET USER'S VARIABLE CHECK SIGN
MOVNS T4 ;NEGATIVE MAKE POSITIVE
JFCL [HRLOI T4,377777 ;GET LARGEST POSSIBLE NUMBER
IDIVI T4,12 ;GET A DIGIT
ADDI T5,"1" ;ADD AN ASCII 1
JRST INTO1+2] ;CONTINUE NORMAL CONVERSION
INTO1: IDIVI T4,12 ;FORM AN INTEGER
IORI T5,"0" ;CONVERT TO ASCII
PUSH P,T5 ;SAVE ON THE STACK
SKIPE T4 ;CKECK FOR END OF DIGITS
AOJA T2,INTO1 ;COUNT THE DIGIT AND CONTINUE
AOS T4,T2 ;COUNT LAST AND SAVE IN T4
SUB T4,T3 ;FIND THE EXCESS FIELD SIZE
SKIPGE (G1) ;CHECK THE VARIABLE SIGN
AOJLE T4,INTO2 ;COUNT THE MINUS SIGN
JUMPLE T4,INTO2 ;PLUS EXACT FIT IN THE FIELD
IFN ASTFL,< MOVEI T4,(T2) ;GET THE DIGITS ON THE STACK>
IFE ASTFL,< SUB T2,T4 ;[242] GET THE NUMBER OF DIGITS
MOVMS T4 ;MAKE POSITIVE>
HRLS T4 ;SET UP EXCESS COUNT
SUB P,T4 ;ADJUST THE STACK
IFN ASTFL,< ERROR (DAT,5,2,INTO6) ;FILL FIELD WITH ASTERICKS>
IFE ASTFL,< SETZ T4, ;CLEAR THE EXCESS COUNT>
INTO2: AOJG T4,INTO4 ;CHECK FOR BLANK FILL
INTO3: MOVEI T0," " ;GET A FILL BLANK
TLNN P2,FT.LSD ;FILL BLANKS WANTED
JSP P1,OBYTE. ;OUTPUT THE FILL BLANK
AOJLE T4,INTO3 ;CONTINUE FILLING
INTO4: MOVEI T0,"-" ;GET A MINUS SIGN
SKIPGE (G1) ;IS VARIABLE NEGATIVE
JSP P1,OBYTE. ;OUTPUT THE SIGN
INTO5: POP P,T0 ;GET A CHARACTER FROM THE STACK
JSP P1,OBYTE. ;OUTPUT A DIGIT
SOJG T2,INTO5 ;CONTINUE OUTPUTTING THE DIGITS
INTO6: POPJ P, ;RETURN TO FOROTS
PRGEND
TITLE LOGIC% %5A.(653) LOGICAL INPUT/OUTPUT CONVERSION ROUTINES
SUBTTL D. TODD/HPW/MD/DCE 26-APR-77
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH FORPRM ;GET THE FOROTS GLOBAL SYMBOLS
; DEFINE THE LOADING PARAMETERS
SEGMEN
ENTRY LOGIC%
EXTERN IBYTE.,OBYTE.,W.PNTR,O.PNTR ;[265]
EXTERN GFDEL%,SFDEL%,SKIP%,MUN ;[354]
LOGIC%: ;LOGICAL VARIABLE INPUT/OUTPUT ROUTINE
LDB T4,W.PNTR ;[265] GET THE FILD WIDTH
JUMPO LOUT ;GO TO LOUT ON OUTPUT
SETZM (G1) ;INPUT SET THE USER'S VARIABLE FALSE
JSP P1,GFDEL% ;[354] RETRIEVE DELIMITER
JUMPG T4,LINT0 ;[354] NOT FREE FORMAT
SETO T4, ;[354] FREE FORMAT
PUSHJ P,SKIP% ;[354] SKIP SPACES
PJRST SFDEL% ;[354] NULL FIELD
JRST LINT0 ;[354] PROCESS FIELD
LINT: JUMPE T4,LINT3 ;[354] IF W=0 RETURN
JSP P1,IBYTE. ;SKIP AN INPUT CHARACTER
LINT0: CAIE T0," " ;CKECK FOR A BLANK
CAIN T0,11 ;OR <TAB>
SOJA T4,LINT ;[354] YES, IGNORE THE CHARACTER
;**;[653], INSERT @ LINT0+2 1/2, DCE, 26-APR-77
CAIE T0,"f" ;[653] LOWER CASE F IS OK
CAIN T0,"F" ;CKECK FOR FALSE
JRST LINT1 ;YES, PROCESS THE FALSE CHARACTER
;**;[653], CHANGE @ LINT0+5, DCE, 26-APR-77
CAIE T0,"t" ;[653] CKECK, FOR TRUE
CAIN T0,"T" ;[653] UPPER CASE TOO
SKIPA ;[653] FOUND A TRUE
JRST LINT2 ;NO, ILLEGAL CHARACTER
SETOM (G1) ;YES, SET USER'S VARIABLE PRUE
LINT1: SOJE T4,LINT3 ;[354] SPACING REQUIRED W=0
JSP P1,IBYTE. ;YES, SKIP AN INPUT CHARACTER
JUMPG T4,LINT1 ;[354] CONTINUE UNTIL W=0
CAIL T0,"a" ;[354] FREE FORMAT - CHECK ALPHA
CAILE T0,"z" ;[354] LOWER CASE
JRST .+2 ;[354] NO
JRST LINT1 ;[354] IGNORE ALPHA
CAIL T0,"A" ;[354] CHECK ALPHA
CAILE T0,"Z" ;[354] UPPER CASE ALPHABETIC
PJRST SFDEL% ;[354] NO - CHECK DELIMITER
JRST LINT1 ;[354] IGNORE ALPHA
LINT2: ERROR (DAT,7,7,LINT0) ;ILLEGAL CHARACTER IN INPUT
LINT3: POPJ P, ;RETURN
LOUT: ;LOGICAL VARIABLE OUTPUT ROUTINE
SKIPG T4 ;[354] W SPECIFIED?
MOVEI T4,^D15 ;[354] NO - SET DEFAULT = 15.
SOJG T4,LOUT1 ;CHECK FOR W<0
JUMPE T4,LOUT2 ;CKECK FOR W=0
LOUT1: MOVEI T0," " ;GET A BLANK FOR OUTPUT
JSP P1,OBYTE. ;OUTPUT A FILL BLANK
SOJG T4,LOUT1 ;CONTINUE FILLING
LOUT2: MOVEI T0,"F" ;GET A F FOR FALSE
SKIPGE (G1) ;IS VARIABLE FALSE
MOVEI T0,"T" ;NO, SET T FOR TRUE
JSP P1,OBYTE. ;OUTPUT THE VALUE
LOUT3: POPJ P, ;RETURN TO FOROTS
PRGEND
TITLE OCTAL% %5A(673) OCTAL INPUT/OUTPUT CONVERSION ROUTINE
SUBTTL D. TODD/DRT/HPW/MD/SWG 17-AUG-77
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH FORPRM ;GET FOROTS GLOBAL SYMBOL TABLE
; DEFINE THE LOADING PARAMETERS
SEGMEN
ENTRY OCTAL%
EXTERN IBYTE.,OBYTE.,W.PNTR ;[265]
EXTERN GFDEL%,SFDEL%,SKIP%,MUN ;[354]
OCTAL%: ;OCTAL INPUT/OUTPUT CONVERSION ROUTINE
MOVEI T2,^D12 ;12 DIGITS ONLY
;**; [673] INSERT @ OCTAL%+2L SWG 17-AUG-77
MOVE T1,DAT.TP+2(P4) ;[673] GET VARIABLE TYPE
CAIN T1,TP%DOR ;[673] IF DOUBLE REAL
MOVEI T2,^D24 ;[673] THEN ALLOW 24 DIGITS
LDB T3,W.PNTR ;[265] GET THE FIELD WIDTH
JUMPO OCTO ;GO TO OCTO ON OUTPUT
OCTI: ;OCTAL INPUT ROUTINE
SETZB T4,T5 ;CLEAR THE OUTPUT WORD
JSP P1,GFDEL% ;[354] RETRIEVE DELIMITER
JUMPG T3,OCTI1B ;[354] FIELD SPECIFIED
SETO T3, ;[354] NO, SET VARIABLE FLAG
PUSHJ P,SKIP% ;[354] SKIP SPACES
JRST OCTI5 ;[354] NULL FIELD DELIMITED BY COMMA OR EOL
JRST OCTI1B ;[354] PROCESS FIELD
OCTI1: JUMPE T3,OCTI5 ;CKECK FOR END OF FIELD
JSP P1,IBYTE. ;GET AN INPUT CHARACTER
OCTI1B: CAIG T0,"7" ;CKECK FOR AN OCTAL
CAIGE T0,"0" ;DIGIT (0-7)
JRST OCTI2 ;56;NO, NOT AN OCTAL DIGIT
TLO T2,400000 ;SET DIGIT SEEN FLAG
OCTI1A: ANDI T0,7 ;MAKE AN OCTAL DIGIT
;**; [673] DELETE + INSERT @ OCTI1A+1 SWG 17-AUG-77
LSHC T4,3 ;[673] POSITION OUTPUT WORD
TDO T5,T0 ;[673] OR IN DIGIT
SOJA T3,OCTI1 ;RETURN FOR NEXT CHARACTER
OCTI2: TLNE P3,IO.EOL ;IS THIS THE END OF LINE
JRST OCTI4 ;YES, T0=BLANK
CAIN T0,11 ;<TAB> CHARACTER
MOVEI T0," " ;CLEAR THE <TAB>
CAIE T0," " ;CHECK FOR A BLANK
JRST OCTI2A ;NOT A BLANK OR <TAB>
JUMPGE T3,OCTI1A ;YES, TREAT AS A ZERO
JUMPGE T2,OCTI1 ;DIGIT NOT SEEN IN FREE FORM
OCTI2A: JUMPL T2,OCTI3 ;HAS A DIGIT BEEN SEEN
CAIN T0,"-" ;CHECK FOR A MINUS SIGN
TLOA T2,200000 ;SET MINUS FLAG
CAIN T0,"+" ;CHECK FOR A PLUS SIGH
SOJA T3,OCTI1 ;[433] YES, COUNT AND GET NEXT CHAR
OCTI3: CAME T3,MUN ;[354] FIRST CHAR ILLEGAL
JUMPL T3,OCTI5 ;NO ERROR ON VARIABLE FIELD INPUT
ERROR (DAT,7,7,OCTI1B) ;ILLEGAL CHARACTER IN INPUT
OCTI4: TLNN P3,IO.TTY ;IS THIS A TTY
JUMPGE T3,OCTI1A ;YES, IGNORE BLANKS
;**; [673] CHANGE,DEL + INSERT @ OCTI5 SWG 17-AUG-77
OCTI5: TLNN T2,200000 ;[673] CHECK THE SIGN OF THE OUTPUT
JRST OCTI6 ;[673] POSITIVE
DMOVN T4,T4 ;[673] NEGATIVE (NEGATE THE RESULT)
TLO T5,400000 ;[673] DMOVN ZEROES SIGN BIT OF RIGHT
;[673] WORD - VAL IS NEG SO TURN IT ON ALWAYS
OCTI6: MOVEM T5,(G1) ;[673] ASSUME SINGLE PREC - RETURN LOW ORDER WORD
MOVE T1,DAT.TP+2(P4) ;[673] GET DATA TYPE
CAIN T1,TP%DOR ;[673] IF DOUBLE REAL
DMOVEM T4,(G1) ;[673] THEN RETURN BOTH HALVES
PJMPL T3,SFDEL% ;[354] SAVE DELIMITER IF NECESSARY
POPJ P, ;RETURN TO FOROTS
OCTO: ;OCTAL OUTPUT ROUTINE
MOVSI T5,(POINT 3,(G1)) ;GET AN OCTAL BYTE POINTER
JUMPN T3,OCTO1 ;CHECK FOR VARIABLE FIELD OUTPUT
MOVEI T3,^D15 ;YES SET FILED WIDTH TO O15
;**; [673] INSERT @ OCTO1 SWG 17-AUG-77
CAIN T1,TP%DOR ;[673] IF DOUBLE REAL
MOVEI T3,^D25 ;[673] THEN ITS O25
OCTO1: SUB T3,T2 ;FIND THE EXCESS FIELD WIDTH
JUMPLE T3,OCTO2 ;W<= MAX FIELD WIDTH
MOVEI T0," " ;SET UP A BLANK FILLER
JSP P1,OBYTE. ;OUTPUT THE FILLER
SOJG T3,.-2 ;CONTINUE UNTIL W=0 (EXCESS)
OCTO2: ILDB T0,T5 ;GET THE NEXT OCTAL DIGIT
IFN ASTFL,<JUMPGE T3,.+3 ;CHECK FOR SPACING
JUMPN T0,[ERROR (DAT,5,2,OCTO3)];FILL WITH ASTERICKS
AOJA T3,OCTO2 ;GET THE NEXT OCTAL DIGIT>
IFE ASTFL,<AOJLE T3,OCTO2 ;CONTINUE SPACING>
ADDI T0,"0" ;CONVERT TO ASCII
JSP P1,OBYTE. ;OUTPUT A DIGIT
TLNE T5,770000 ;CHECK FOR COMPLETED WORD
JRST OCTO2 ;NO, CONTINUE
;**; [673] INSERT @ OCTO3 SWG 17-AUG-77
TRNE T5,1 ;[673] IF ADDR IN BYTE POINTER NOT 0,
JRST OCTO3 ;[673] HAVE DONE DOUBLE PRECISION OUTPUT
MOVE T1,DAT.TP+2(P4) ;[673] ELSE GET DATA TYPE
CAIN T1,TP%DOR ;[673] IF DOUBLE REAL
JRST OCTO2 ;[673] THEN CONTINUE FOR SECOND WORD
OCTO3: POPJ P, ;YES, RETURN TO FOROTS
PRGEND
TITLE DELIM% %4.(372) ROUTINE TO HANDLE DELIMITER OF FREE FORMAT
SUBTTL M. DUHAMEL/MD 07-SEP-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) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH FORPRM ;GET FOROTS GLOBAL SYMBOL TABLE
; DEFINE THE LOADING PARAMETERS
SEGMEN
ENTRY SFDEL%,GFDEL%,SKIP%
EXTERN IBYTE.
INTERNAL MUN
;[354] ROUTINE TO SAVE EVENTUAL DELIMITER
;[354] CALLED BY PUSHJ
SFDEL%: TLNE P2,FT.LSD!FT.NML ;[372] [354] NOT FOR LIST-DIRECTED INPUT
POPJ P, ;[354]
PUSHJ P,SKIP% ;[354] SKIP SPACES
POPJ P, ;[354] COMMA OR EOL - DONT SAVE
MOVEM T0,CH.SAV(P4) ;[354] NO - SAVE
POPJ P, ;[354] FINI
;[354] ROUTINE TO GET EVENTUAL DELIMITER
;[354] CALLED BY JSP
GFDEL%: SETZ T0, ;[354]
SKIPN CH.SAV(P4) ;[354] SOMETHING SAVED
PJSP IBYTE. ;[354] GO GET A CHAR
EXCH T0,CH.SAV(P4) ;[354] RETRIEVE DEL, CLEAR IT
JRST (P1) ;[354]
;[354] ROUTINE TO SKIP SPACES
;[354] NON SKIP RETURN IF CHAR IS COMMA OR EOL
SKIP%: CAIE T0," " ;[354] BLANK
CAIN T0," " ;[354] OR TAB
JRST SKIP0 ;[354] YES SKIP
CAIE T0,"," ;[354] COMMA
AOS (P) ;[354]
POPJ P, ;[354]
SKIP0: TLNE P3,IO.EOL ;[354] FINI
POPJ P, ;[354] OUI-NON SKIP RETURN
JSP P1,IBYTE. ;[354] FIND NEXT
JRST SKIP% ;[354] CONTINUE
MUN: -1 ;[354] DEFINED FOR CONVERSION ROUTINES
PRGEND
TITLE POWTB% %4.(100) D.P. INTEGER POWER OF TEN TABLE
SUBTTL D. TODD /DRT/ 08-DEC-1972 TOM EGGERS
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
SEARCH FORPRM ;DEFINE THE GLOBAL SYMBOL TABLE
; DEFINE THE LOADING PARAMETER
SEGMEN
ENTRY HITEN., LOTEN., EXP10., PTLEN.
;POWER OF TEN TABLE IN DOUBLE PRECISION
;INTEGER FORMAT. EACH ENTRY CONSISTS OF TWO WORDS,
;EACH WITH 35 BITS OF FRACTION (SIGNS ARE EXCLUDED).
;THE BINARY POINT IS BETWEEN BITS 0 AND 1 OF THE
;HI ORDER WORD. THE EXPONENT (EXCESS 200) FOR THE 70 BIT
;FRACTION IS STORED IN THE SHORT TABLE CALLED "EXPTEN".
DEFINE .TAB. (A)<
REPEAT 0,<
NUMBER 732,357347511265,056017357445 ;D-50
NUMBER 736,225520615661,074611525567
NUMBER 741,273044761235,213754053125
NUMBER 744,351656155504,356747065752
NUMBER 750,222114704413,025260341562
NUMBER 753,266540065515,332534432117
NUMBER 756,344270103041,121263540543
NUMBER 762,216563051724,322660234335
NUMBER 765,262317664312,007434303425
NUMBER 770,337003641374,211343364332
NUMBER 774,213302304735,325716130610 ;D-40
NUMBER 777,256162766125,113301556752
NUMBER 002,331617563552,236162112545 ;D-38
NUMBER 006,210071650242,242707256537
NUMBER 011,252110222313,113471132267
NUMBER 014,324532266776,036407360745
NUMBER 020,204730362276,323044526457
NUMBER 023,246116456756,207655654173
NUMBER 026,317542172552,051631227231
NUMBER 032,201635314542,132077636440
NUMBER 035,242204577672,360517606150 ;D-30
NUMBER 040,312645737651,254643547602
NUMBER 043,375417327624,030014501542
NUMBER 047,236351506674,217007711035
NUMBER 052,306044030453,262611673245
NUMBER 055,367455036566,237354252116
NUMBER 061,232574123152,043523552261
NUMBER 064,301333150004,254450504735
NUMBER 067,361622002005,327562626124
NUMBER 073,227073201203,246647575664
>
NUMBER 076,274712041444,220421535242 ;D-20
NUMBER 101,354074451755,264526064512
NUMBER 105,223445672164,220725640716
NUMBER 110,270357250621,265113211102
NUMBER 113,346453122766,042336053323
NUMBER 117,220072763671,325412633103
NUMBER 122,264111560650,112715401724
NUMBER 125,341134115022,135500702312
NUMBER 131,214571460113,172410431376
NUMBER 134,257727774136,131112537675
NUMBER 137,333715773165,357335267655 ;D-10
NUMBER 143,211340575011,265512262714
NUMBER 146,253630734214,043034737477
NUMBER 151,326577123257,053644127417
NUMBER 155,206157364055,173306466551
NUMBER 160,247613261070,332170204303
NUMBER 163,321556135307,020626245364
NUMBER 167,203044672274,152375747331
NUMBER 172,243656050753,205075341217
NUMBER 175,314631463146,146314631463 ;D-01
A: NUMBER 201,200000000000,0 ;D00
NUMBER 204,240000000000,0
NUMBER 207,310000000000,0
NUMBER 212,372000000000,0
NUMBER 216,234200000000,0
NUMBER 221,303240000000,0
NUMBER 224,364110000000,0
NUMBER 230,230455000000,0
NUMBER 233,276570200000,0
NUMBER 236,356326240000,0
NUMBER 242,225005744000,0 ;D+10
NUMBER 245,272207335000,0
NUMBER 250,350651224200,0
NUMBER 254,221411634520,0
NUMBER 257,265714203644,0
NUMBER 262,343277244615,0
NUMBER 266,216067446770,040000000000
NUMBER 271,261505360566,050000000000
NUMBER 274,336026654723,262000000000
NUMBER 300,212616214044,117200000000
NUMBER 303,255361657055,143040000000 ;D+20
REPEAT 0,<
NUMBER 306,330656232670,273650000000
NUMBER 312,207414740623,165311000000
NUMBER 315,251320130770,122573200000
NUMBER 320,323604157166,147332040000
NUMBER 324,204262505412,000510224000
NUMBER 327,245337226714,200632271000
NUMBER 332,316627074477,241000747200
NUMBER 336,201176345707,304500460420
NUMBER 341,241436037271,265620574524
NUMBER 344,311745447150,043164733651 ;D+30
NUMBER 347,374336761002,054022122623
NUMBER 353,235613266501,133413263573
NUMBER 356,305156144221,262316140531
NUMBER 361,366411575266,037001570657
NUMBER 365,232046056261,323301053415
NUMBER 370,300457471736,110161266320
NUMBER 373,360573410325,332215544004
NUMBER 377,226355145205,250330436402 ;D+38
NUMBER 402,274050376447,022416546102
NUMBER 405,353062476160,327122277522 ;D+40
NUMBER 411,222737506706,206363367623
NUMBER 414,267527430470,050060265567
NUMBER 417,345455336606,062074343124
NUMBER 423,217374313163,337245615764
NUMBER 426,263273376020,327117161361
NUMBER 431,340152275425,014743015655
NUMBER 435,214102366355,050055710514
NUMBER 440,257123064050,162071272637
NUMBER 443,332747701062,216507551406
NUMBER 447,210660730537,231114641743 ;D+50
NUMBER 452,253035116667,177340012333
>
>
DEFINE NUMBER (A,B,C)< B>
TENTAB: .TAB. HITEN.
DEFINE NUMBER (A,B,C)< C>
.TAB. LOTEN.
PTLEN.==HITEN.-TENTAB ;CALCULATE NUMBER OF TABLE ENTRIES BEFORE "TENS"
XX=PTLEN.
XX=XX-XX/4*4 ;CALC XX=XX MOD 4
BINR1=<BINR2=<BINR3=0>> ;INIT THE BINARY
DEFINE NUMBER (A,B,C)<
IFE XX-1,< BYTE (9) BINR1,BINR2,BINR3,<A>
BINR1=<BINR2=<BINR3=0>> >
IFE XX-2,<BINR3=A>
IFE XX-3,<BINR2=A>
IFE XX,<BINR1=A
XX=4>
XX=XX-1>
REPEAT 0,< ;BYTE POINTER TABLE IS IN FLIRT.
POINT 9,EXP10.-1(D),17
POINT 9,EXP10.-1(D),26
POINT 9,EXP10.-1(D),35
EXTAB.: POINT 9,EXP10.(D),8
POINT 9,EXP10.(D),17
POINT 9,EXP10.(D),26
POINT 9,EXP10.(D),35
> ;END OF REPEAT 0
.TAB. EXP10.
IFN BINR1!BINR2!BINR3,< BYTE (9) BINR1,BINR2,BINR3,0>
PRGEND
TITLE LSTDR% %5.(575) LIST-DIRECTED I/O MODULE
SUBTTL D. TODD/DRT/HPW/MD/CLRH 24-AUG-76
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) 1973,1977 BY DIGITAL EQUIPMENT CORPORATION
ENTRY LSTDR%
SEARCH FORPRM
RPT.SV==SCL.SV ;[325] TO SAVE REPEAT COUNT
SEGMEN
LSTDR%:
SETZ G4, ;SET FREE FORM CONVERSION MODE
MOVSI P2,FT.LSD!FT.NUL;[325] SET THE NO FILL FLAG FOR LIST DR.
;[325] AND COMMA SEEN FLAG FOR FIRST ITEM
SETZM RPT.SV(P4) ;[325] CLEAR REPEAT COUNT
JUMPI LSTDR1 ;SKIP THE COLUMN COUNTS
PUSHJ P,NLOEN.## ;SET UP THE COLUMN COUNTS
LSTDR1: ;LIST DIRECTED DISPATCH ROUTINE INTO NMLST%
JSP P1,IOLS%%## ;GET THE I/O LIST VARIABLE
TLNE P2,FT.SLH ;[366] SLASH SEEN
JRST LSTDR1 ;[366] YES-FINISH LIST
;**; [575] CHANGE @ LSTDR1 + 3 CLRH 24-AUG-76
TLZ P2,FT.ELT!FT.SLT;[575] [256] KILL THE EXTENDED LIST FLAGS
HLRZ T1,NMLTBL##(T5) ;GET THE NAME/LIST OUTPUT DISPATCH
JUMPO LSTDR2 ;JUMP ON OUTPUT
HRRZ T1,NMLTBL##(T5) ;GET THE NAME/LIST INPUT DISPATCH
TLZE P2,FT.QOT ;QUOTED STRING IN PROCESS
MOVEI T1,NLIS0## ;REENTER THE QUOTED STRING ROUTINE
;**; [533] INSERT @ LSTDR2 - 1/2 CLRH 14-APR-76
CAIN T5,TP%DOR ; [533] GET VARIABLE TYPE
TLOA P2,FT.PRC ; [533] SET DOUBLE PRECISION
TLZ P2,FT.PRC ; [533] OR SINGLE PRECISION
LSTDR2: PUSHJ P,(T1) ;OUTPUT THE VARIABLE
JRST LSTDR1 ;GET THE NEXT I/O LIST VARIABLE
PRGEND
TITLE NMLST% %5A(654) NAMELIST I/O
SUBTTL D. TODD /DRT/HPW/MD/JNG/CLRH/SWG 26-APR-77
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) 1972,1977 BY DIGITAL EQUIPMENT CORPORATION
;THE NAMELIST PROGRAM CONSISTS OF TWO MAJOR ROUTINES - NLIN.
;FOR NAMELIST INPUT, AND NLOUT. FOR NAMELIST OUTPUT. THE CALLING
;SEQUENCE FOR THE NAMELIST PROGRAM IS
; MOVEI G1, POINTER TO NAMELIST TABLE
; PUSHJ P, NMLST.
;IF ACCUMULATOR P3 HAS A ONE IN THE SIGN BIT, THE NAMELIST
;OUTPUT ROUTINE IS CALLED. OTHERWISE, THE NAMELIST INPUT
;ROUTINE IS CALLED. THIS ACCUMULATOR IS USUALLY SET UP BY
;FOROTS. BEFORE NAMELIST IS CALLED.
;THE NAMELIST TABLE IS CONSTRUCTED BY THE COMPILER.
SEARCH FORPRM ;GET THE FOROTS GLOBAL SYMBOL TABLE
; DEFINE THE LOADING PARAMETERS
SEGMEN
ENTRY NMLST%
EXTERN REAL%,INTEG%,OBYTE.,IBYTE.,NXTLN.,IPEEK.
RPT.SV==SCL.SV ;[325] TO SAVE REPEAT COUNT DURING
;[325] LIST DIRECTED I/O
SUBTTL NAME LIST SEQUENTIAL ACCESS CALLING SEQUENCES
REPEAT 0,<
READ (u,name)
READ (u,name,END=c,ERR=d)
MOVEI 16,ARGBLK 0 89 12 14 1718 35
PUSHJ 17,NLI. ------------------------------------
! 3 ! !I! X ! u -unit# !
------------------------------------
! ERR=d ! END=c !
------------------------------------
! ! t !I! X ! name list addr !
------------------------------------
WRITE (u,name)
WRITE (u,name,END=c,ERR=d)
MOVEI 16,ARGBLK 0 89 12 14 1718 35
PUSHJ 17,NLO. ------------------------------------
! 3 ! !I! X ! u -unit# !
------------------------------------
! ERR=d ! END=c !
------------------------------------
! ! t !I! X ! name list addr !
------------------------------------
The NAMELIST table illustrated below is generated form
the FORTRAN NAMELIST STATEMENT. The first word of the
table is the NAMELIST name in sixbit format. Following
that are a number of two-word entries for scalar
variables, and a number of (N+3)-word entries for array
variables, where N is the dimensionality of the array.
The NAMELIST argument block has the following format.
NAMELIST ADDR/ 0 89 12 14 1718 35
------------------------------------
! SIXBIT /NAMELIST NAME/ !
------------------------------------
! NAME LIST ENTRIES !
------------------------------------
! 0 !
------------------------------------
SCALAR ENTRIES
0 89 12 14 1718 35
------------------------------------
! SIXBIT /SCALAR NAME/ !
------------------------------------
! 0 ! T !I! X ! SCALAR ADDR !
------------------------------------
ARRAY ENTRIES
0 89 12 14 1718 35
------------------------------------
! SIXBIT /ARRAY NAME/ !
------------------------------------
!# DIM'S! T !I! X ! BASE ADDR !
------------------------------------
! SIZE ! OFFSET !
------------------------------------
! ! !I! X ! FACTOR 1 !
------------------------------------
! ! !I! X ! FACTOR 2 !
------------------------------------
! ! !I! X ! FACTOR 3 !
------------------------------------
! ! !I! X ! FACTOR N !
------------------------------------
>
;NAMELIST OUTPUT SECTION
;THE MAJOR FLOW OF EVENTS IN THE NAMELIST OUTPUT SECTION IS
;AS FOLLOWS: THE ROUTINE IS GIVEN A POINTER TO A NAMELIST TABLE
;(IN ACCUMULATOR P2), AND IT PROCEEDS TO OUTPUT THE VALUE OF
;EACH ARRAY IN THE TABLE, OR OF EACH ELEMENT OF EACH ARRAY IN
;THE TABLE. SINCE THERE IS INFORMATION IN THE TABLE INDICATING
;THE TYPE OF EACH VARIABLE, AND WHETHER THAT VARIABLE IS AN
;ARRAY OR A SCALAR, NLOUT. CAN DO THE FOLLOWING:
; 1. GET THE NEXT VARIABLE NAME FROM THE TABLE. PRINT
; IT ON THE OUTPUT DEVICE, FOLLOWED BY AN EQUAL SIGN.
; 2. IF THE VARIABLE IS A SCALAR, SIMPLY PLACE THE CORE
; ADDRESS WHERE THE VALUE OF THAT VARIABLE MAY BE FOUND
; IN ACCUMULATOR G1, AND PROCEED TO 4.
; 3. IF THE VARIABLE IS AN ARRAY, PREPARE AN AOBJN WORD
; IN ACCUMULATOR G1, WITH THE LEFT HALF HAVING A NEGATIVE
; COUNT OF THE NUMBER OF ELEMENTS IN THE ARRAY, AND THE
; RIGHT HALF CONTAINING THE CORE ADDRESS OF THE BASE OF
; OF THE ARRAY.
; 4. PICK UP THE TYPE OF THE ARGUMENT, AND DISPATCH TO THE
; PROPER OUTPUT ROUTINE AS A FUNCTION OF THE SCALAR/ARRAY
; AND TYPE NATURE OF THE ARGUMENT.
;A COLUMN COUNTER IS KEPT AT ALL TIMES SO THAT NLOUT. MAY KNOW
;WHICH COLUMN OF THE OUTPUT DEVICE WILL RECEIVE THE NEXT CHARACTER.
;BEFORE CALLING ONE OF THE OUTPUT ROUTINES, IT CHECKS TO MAKE SURE
;THERE IS ENOUGH ROOM ON THE LINE. IF NOT, THE ROUTINE CRLF IS
;CALLED TO OUTPUT A CARRIAGE RETURN, LINE FEED AND RESET THE
;COLUMN COUNTER.
FINCOD: 004000,,0 ;[374] CODE CALL TO FIN.
NMLST%:
MOVSI P2,FT.NML ;[400] NAMELIST IN PROGRESS
HRRI P2,(G1) ;[372] PUT THE NAME LIST POINTER IN A P AC
SETZ G4, ;SET FREE FORM I/O
JUMPI NLIN. ;IF SIGN BIT=1, ITS OUTPUT
NLOUT.:
MOVEI T0," " ;OUTPUT A SPACE IN COLUMN 1
JSP P1,OBYTE. ;SEND THE CHARACTER OFF TO FOROTS.
MOVEI T0,"$" ;OUTPUT A DOLLAR SIGN IN COL. 2
JSP P1,OBYTE. ;...
MOVE T1,(P2) ;GET THE NAMELIST NAME
PUSHJ P,NLOSIX ;TYPE IT OUT
PUSHJ P, NLOLIN ;TYPE CR,LF, SET UP COLUMN COUNT
NLOVAR: ADDI P2,1 ;MOVE POINTER TO NEXT VARIABLE
SKIPE T1,(P2) ;[374] ARE WE AT THE END OF THE TABLE?
CAMN T1,FINCOD ;[374] BY IMPLICIT CALL TO FIN.?
JRST NLOFIN ;YES, FINISH THE OUTPUT AND EXIT
;NO, PICK UP THE VARIABLE NAME
PUSHJ P,NLONAM ;TYPE THE NAME, AND AN EQUAL SIGN
HRRZ G1,1(P2) ;GET THE ADDRESS OF THE VARIABLE
LDB G2,[POINT 9,1(P2),8] ;GET THE NUMBER OF DIMENSION IF ARRAY
LDB T5,[POINT 4,1(P2),12] ;GET THE TYPE CODE
JUMPE G2,NLOVA1 ;JUMP IF SCALAR
HLRZ T1,2(P2) ;GET THE ARRAY SIZE
MOVNS T1 ;NEGATE THE ARRAY SIZE
CAIE T5,TP%DOR ;DOUBLE PRECISION OR
CAIN T5,TP%COM ;COMPLEX VARABLE
ASH T1,1 ;YES, DOUBLE THE RAY SIZE
HRLI G1,(T1) ;SET UP IOWD SIZE,,BASE
ADDI P2,1(G2) ;STEP PAST THE FACTORS,SIZE, OFFSET
NLOVA1:
;**; [654] INSERT AT NLOVA1 SWG 26-APR-77
MOVEM T5,DAT.TP+2(P4) ;[654] REMEMBER DATA TYPE
HLRZ T1,NMLTBL(T5) ;GET THE OUTPUT DISPATCH ADDRESS
PUSHJ P,(T1) ;DO IT
AOJA P2,NLOVAR ;GET THE NEXT ENTRY
;DISPATCH TABLE FOR INPUT/OUTPUT ACCORDING TO VARIABLE TYPE
NMLTBL:: ;OUTPUT INPUT TYPE
XWD NLOI, NLII ;0; INTEGER(DEFAULT)
XWD NLOL, NLIL ;1; LOGICAL
XWD NLOI, NLII ;2; INTEGER
XWD NLOER1, NLIER1 ;3; INDEX(ILLEGAL)
XWD NLOF, NLIF ;4; FLOATING POINT
XWD NLOER1, NLIER1 ;5; ILLEGAL
XWD NLOER1, NLIER1 ;6; OCTAL(ILLEGAL)
XWD NLOER1, NLIER1 ;7; ILLEGAL
XWD NLOD, NLID ;10; DOUBLE REAL
XWD NLOER1, NLIER1 ;11; ILLEGAL
XWD NLOER1, NLIER1 ;12; ILLEGAL
XWD NLOER1, NLIER1 ;13; ILLEGAL
XWD NLOC, NLIC ;14; COMPLEX
XWD NLOER1, NLIER1 ;15; ILLEGAL
XWD NLOER1, NLIER1 ;16; ILLEGAL
XWD NLOER1, NLIER1 ;17; ILLEGAL
;INTEGER OUTPUT ROUTINE
NLOI: PUSHJ P,NLORP1 ;CHECK FOR A REPEATED VARIABLE
PUSHJ P,INTEG% ;VARIABLE FIELD INTEGER OUTPUT
PUSHJ P,NLOCMA ;TYPE A COMMA
;**; [575] INSERT @ NLOI + 3 1/2 CLRH 20-AUG-76
TLNE P2,FT.LSD ;[575] LIST-DIRECTED ?
JRST [ADD G1,DAT.TP+1(P4) ;[575] YES, ADD INCREMENT
TLNE G1,400000 ;[575] STILL NEGATIVE ?
JRST NLOI ;[575] YES, LOOP
POPJ P, ] ;[575] NO, RETURN
AOBJN G1,NLOI ;CONTINUE
POPJ P, ;RETURN
;REAL OUTPUT ROUTINE
NLOF: PUSHJ P,NLORP1 ;CHECK FOR A REPEATED VARIABLE
TLO P2,FT.GTP ;SET UP FOR "G" TYPE OUTPUT
PUSHJ P,REAL% ;VARIABLE FIELD REAL OUTPUT
TLZ P2,FT.GTP ;CLEAR "G" FLAG
PUSHJ P,NLOCMA ;TYPE A COMMA
;**; [575] INSERT @ NLOF + 5 1/2 CLRH 20-AUG-76
TLNE P2,FT.LSD ;[575] LIST-DIRECTED ?
JRST [ADD G1,DAT.TP+1(P4) ;[575] YES, ADD INCREMENT
TLNE G1,400000 ;[575] STILL NEGATIVE ?
JRST NLOF ;[575] YES, LOOP
POPJ P, ] ;[575] NO, RETURN
AOBJN G1,NLOF ;CONTINUE
POPJ P, ;RETURN
;LOGICAL OUTPUT ROUTINE
NLOL: PUSHJ P,NLORP1 ;CHECK FOR A REPEATED VARIABLE
MOVEI T0, "T" ;ASSUME THAT WE HAVE A "TRUE"
SKIPL (G1) ;IS IT REALLY A "TRUE"
MOVEI T0, "F" ;NO, ITS AN "F"
JSP P1,OBYTE. ;PRINT THE CHARACTER
PUSHJ P,NLOCMA ;TYPE A COMMA
;**; [575] INSERT @ NLOL + 6 1/2 CLRH 20-AUG-76
TLNE P2,FT.LSD ;[575] LIST-DIRECTED ?
JRST [ADD G1,DAT.TP+1(P4) ;[575] YES, INCREMENT
TLNE G1,400000 ;[575] STILL NEGATIVE ?
JRST NLOL ;[575] YES, LOOP
POPJ P, ] ;[575] NO, RETURN
AOBJN G1,NLOL ;CONTINUE
POPJ P,
;DOUBLE PRECISION OUTPUT ROUTINE
NLOD: PUSHJ P,NLORP2 ;CHECK FOR A REPEATED VARIABLE
TLO P2,FT.PRC ;SET DOUBLE PRECISION FLAG
PUSHJ P,REAL% ;DO CONVERSION
TLZ P2,FT.PRC ;CLEAR THE DOUBLE PRECISION FLAG
PUSHJ P,NLOCMA ;TYPE A COMMA
;**; [575] INSERT @ NLOD + 4 1/2
TLNE P2,FT.LSD ;[575] LIST-DIRECTED ?
JRST [ADD G1,DAT.TP+1(P4) ;[575] YES, INCREMENT
TLNE G1,400000 ;[575] STILL NEGATIVE ?
JRST NLOD ;[575] YES, LOOP
POPJ P, ] ;[575] NO, RETURN
ADD G1,[XWD 1,1] ;STEP PAST THE LOW ORDER PART
AOBJN G1,NLOD ;CONTINUE
POPJ P, ;RETURN
;COMPLEX OUTPUT ROUTINE
NLOC: PUSHJ P,NLORP2 ;CHECK FOR A REPEATED VARIABLE
MOVEI T0,"(" ;OUTPUT A LEFT PARENTHESIS
JSP P1,OBYTE. ;...
PUSHJ P,REAL% ;OUTPUT REAL PART OF COMPLEX NUMBER
MOVEI T0,"," ;SEPERATE WITH A COMMA
JSP P1,OBYTE. ;OUTPUT
ADD G1,[XWD 1,1] ;MOVE POINTER TO THE COMPLEX PART
PUSHJ P,REAL% ;OUTPUT IT
MOVEI T0,")" ;OUT PUT A RIGHT PARENTHESIS
JSP P1,OBYTE. ;PRINT THE CHARACTER
PUSHJ P,NLOCMA ;TYPE A COMMA
;**; [575] INSERT @ NLOC + 13 1/2 CLRH 20-AUG-76
TLNE P2,FT.LSD ;[575] LIST-DIRECTED ?
JRST [SUB G1,[XWD 1,1] ;[575] YES, BACK UP
ADD G1,DAT.TP+1(P4) ;[575] ADD INCREMENT
TLNE G1,400000 ;[575] STILL NEGATIVE ?
JRST NLOC ;[575] YES, LOOP
POPJ P, ] ;[575] NO, RETURN
AOBJN G1,NLOC ;CONTINUE
POPJ P, ;EXIT
;ROUTINE TO COUNT THE NUMBER OF REPEATED SINGLE PRECISION
;QUANTITIES IN AN ARRAY (I.E. INTEGER,REAL,LOGICAL,LITERAL,OCTAL)
;AND OUTPUT THE COUNT (IF > 1) AS AN ITEGER FOLLOWED BY A *
NLORP1: TDZA T2,T2 ;CLEAR THE REPEAT COUNT
ADDI T2,1 ;INCREMENT COUNT
;**; [575] INSERT @ NLORP1 + 1 1/2 CLRH 20-AUG-76
TLNE P2,FT.LSD ;[575] LIST-DIRECTED ?
JRST [MOVE T1,G1 ;[575] YES, GET CURRENT ADDRESS
ADD T1,DAT.TP+1(P4) ;[575] ADD INCREMENT
MOVE T0,0(T1) ;[575] PICK UP VALUE
JRST NLRP1A ] ;[575] GO CHECK
MOVE T0, 1(G1) ;GET NEXT QUANTITY FROM ARRAY
;**; [575] CHANGE @ NLORP1 + 3 CLRH 20-AUG-76
NLRP1A: CAME T0, (G1) ;[575] DOES IT MATCH?
;**; [575] INSERT @ NLORP1 + 3 1/2 CLRH 20-AUG-76
JRST NLRP1B ;[575] NO
TLNE P2,FT.LSD ;[575] LIST-DIRECTED ?
JRST [ADD G1,DAT.TP+1(P4) ;[575] YES, INCREMENT
TLNE G1,400000 ;[575] STILL NEGATIVE ?
JRST NLORP1+1 ;[575] YES, LOOP
JRST NLRP1B ] ;[575] NO, CONTINUE
AOBJN G1, NLORP1+1 ;OR ARE WE THROUGH THE ARRAY?
;**; [575] CHANGE @ NLORP1 + 5 CLRH 20-AUG-76
NLRP1B: JUMPE T2, CPOPJ ;[575] IF COUNT WAS ZERO, IGNORE IT
ADDI T2,1 ;MAKE THE REPEAT COUNT RIGHT
NLODEC: PUSHJ P,NLODE1 ;PRINT REPETITION COUNT
MOVEI T0,"*" ;PICK UP *
JRST NLOASC ;OUTPUT IT
NLODE1: IDIVI T2, 12 ;DECIMAL NUMBER OUTPUTTER
HRLM T3, (P) ;STORE REMAINDER ON PDLIST
JUMPE T2,.+2 ;ALL DONE?
PUSHJ P, NLODE1 ;NO, CALL NUMOUT RECURSIVELY
HLRZ T0, (P) ;YES, GET NUMBER OFF STACK
ADDI T0,"0" ;MAKE IT ASCII
PJRST NLOASC ;UPDATE COLUMN COUNT,TYPE,EXIT
;ROUTINE TO COUNT THE NUMBER OF REPEATED DOUBLE PRECISION
;QUANTITIES IN AN ARRAY (DOUBLE PRECISION OR COMPLEX) AND OUTPUT
;THEM AS ABOVE
NLORP2: MOVEI T2, 0 ;INITIALIZE REPETITION COUNT
JRST NLORP3 ;SKIP THE INCREMENTATION
NLORP4: ADDI T2,1 ;INCREMENT THE REPETITION COUNT
;**; [575] INSERT @ NLORP3 CLRH 20-AUG-76
NLORP3: TLNE P2,FT.LSD ;[575] LIST-DIRECTED ?
JRST [MOVE T1,G1 ;[575] YES, GET CURRENT ADDRESS
ADD T1,DAT.TP+1(P4) ;[575] ADD INCREMENT
DMOVE T0,0(T1) ;[575] FIRST PART OF NEXT ELEMENT
JRST NLRP3A ] ;[575] AND CONTINUE
DMOVE T0,2(G1) ;[575] PICK UP NEXT DOUBLE QUANITYT
;**; [575] CHANGE @ NLORP3 + 1 CLRH 20-AUG-76
NLRP3A: CAMN T0, (G1) ;[575] DO THE FIRST WORDS MATCH?
CAME T1, 1(G1) ;YES, DO THE SECOND WORDS MATCH?
JRST NLORP5 ;NO
;**; [575] INSERT @ NLORP3 + 3 1/2 CLRH 20-AUG-76
TLNE P2,FT.LSD ;[575] LIST-DIRECTED ?
JRST [ADD G1,DAT.TP+1(P4) ;[575] YES, ADD INCREMENT
TLNE G1,400000 ;[575] STILL NEGATIVE ?
JRST NLORP4 ;[575] YES, LOOP
JRST NLORP5 ] ;[575] NO, QUIT
ADD G1,[XWD 1,1] ;INCREMENT THE ARRAY POINTER
AOBJN G1, NLORP4 ;TRY SOME MORE UNLESS THRU ARRAY
NLORP5: JUMPE T2, CPOPJ ;IGNORE IF REPETITION COUNT IS 0
AOJA T2,NLODEC ;TYPE IT OUT AND EXIT
NLOFIN: MOVEI T0,"$" ;GET A DOLLAR SIGN TO TERMINATE
JSP P1,OBYTE. ;OUTPUT IT
POPJ P, ;[252] RETURN
NLONAM: PUSHJ P, NLOEN. ;NO, OUTPUT A CR
MOVE T1,(P2) ;GET THE VARIABLE NAME
PUSHJ P,NLOSIX ;OUTPUT THE NAME
MOVEI T0,"=" ;GET AN EQUAL SIGN
PJRST NLOASC ;OUTPUT IT AND EXIT
;ROUTINE TO OUTPUT A SIXBIT NAME FROM T1
NLOSIX: SETZ T0, ;CLEAT THE OUTPUT WORD
LSHC T0,6 ;GET A SIXBIT CHARACTER
ADDI T0," " ;CONVERT TO ASCII
JSP P1,OBYTE. ;OUTPUT IT
JUMPN T1,NLOSIX ;CHECK IF DONE
POPJ P, ;RETURN
;ROUTINE TO PRINT A COMMA
NLOCMA: MOVEI T0,"," ;GET A COMMA
JSP P1,OBYTE. ;OUTPUT IT
NLOEN.::MOVM T1,POS.TB(P4) ;GET THE COLUMN POSITION
CAILE T1,^D72-^D16 ;CHECK FOR A TTY PAGE
TLNN P3,IO.TTY ;AND A TTY
CAILE T1,^D132-^D16 ;NO, ALL OTHERS 132 COLUMNS
NLOLIN: PUSHJ P,NXTLN. ;START A NEW LINE
MOVEI T0," " ;START WITH A SPACE
NLOASC: JSP P1,OBYTE. ;OUTPUT IT
CPOPJ: POPJ P, ;RETURN
;NAMELIST INPUT SECTION
;THE MAJOR FLOW OF EVENTS IN THE INPUT SECTION IS AS FOLLOWS:
; 1.GET THE NAMELIST NAME FROM THE INPUT DEVICE. THE NAME
; BEGINS IN COLUMN 3 OF A RECORD, AND IS PRECEDED BY A
; DOLLAR SIGN OR AN AMPERSAND.
; 2.COLLECT A VARIABLE NAME IN SIXBIT FORMAT FROM THE
; INPUT DEVICE. FIND THE SAME VARIABLE NAME IN THE
; NAMELIST TABLE, AND DISPATCH TO AN INPUT ROUTINE
; DEPENDING ON THE TYPE OF THE VARIABLE. A SEPARATE
; DISPATCH IS ALSO MADE FOR ARRAY VARIABLES AS OPPOSED TO
; SCALAR VARIABLES.
; 3.ONCE IN THE INPUT ROUTINE, INPUT THE VALUE WITH THE
; PROPER FORTRAN INPUT ROUTINE, AND STORE IT IN THE CORE
; ADDRESS INDICATED IN THE NAMELIST TABLE. IF AN ARRAY,
; CONTINUE THE INPUT OF MORE ELEMENTS OF THIS ARRAY.
;THERE ARE TWO SPECIAL INTERFACES WITH THE FORTRAN OPERATING
;SYSTEM WHICH SHOULD BE NOTED:
; 1. ON THE RETURN FROM ANY OF THE INPUT ROUTINES -
; THE DELIMITING CHARACTER WILL BE FOUND IN "DD.HRI+1(P3)"
; THIS FEATURE IS NECESSARY FOR NAMELIST
; TO BE ABLE TO HANDLE THE STRING LIKE
; A=6*1.0,2.0,3.0
; WHERE A IS AN ARRAY CONSISTING OF 8 ELEMENTS. THE 6
; IS A REPETITION COUNT, AND IS RECOGNIZED BY THE PRESCENE
; OF THE * .
; 2. WHEN INPUT IS DONE THROUGH THE IBYTE. ROUTINE, THE
; BUFFER POINTER WILL BE ADVANCED UNLESS THE INPUT
; CHARACTER IS A CARRIAGE RETURN. IN THAT CASE, THE
; BUFFER POINTER IS ADVANCED TO THE BEGINNING OF THE NEXT
; LINE, AND THE FLAG IO.EOL. IS SET IN P3. IN ORDER
; TO DO FURTHER INPUT, NMLST. MUST ZERO THE FLAG. ALSO,
; WHEN DOING INPUT WITH THE VARIOUS FORTRAN INPUT
; CONVERSION ROUTINES - FLIRT.,, ETC. -AN ILLEGAL
; TERMINATING CHARACTER WILL BE "GOBBLED UP". THUS, IF
; PART OF THE INPUT STRING IS ...1.0,2.0..... ONE CALL
; TO FLIRT. WILL INPUT THE 1.0, STOPPING ON AND ADVANCING
; PAST THE COMMA. THE SECOND CALL TO FLIRT. WILL BEGIN
; ITS INPUT WITH THE "2" OF 2.0
NLIN.:
JSP P1,IBYTE. ;GET FIRST CHARACTER OF RECORD
JSP P1,IBYTE. ;GET THE SECOND CHARACTER
SETZM SCL.SV(P4) ;[430] CLEAR SCALING FACTOR
CAIE T0,"$" ;IS IT A DOLLAR SIGN?
CAIN T0,"&" ;OR IS IT AN AMPERSAND?
JRST NLIN2 ;YES, CHECK THE NAMELIST NAME
NLIN1: TLNE P3,IO.EOF ;END OF FILE PENDING
POPJ P, ;YES, RETURN NOT INPUT DATA
PUSHJ P, NXTLN. ;CALL FOROTS. FOR THE NEXT RECORD
JRST NLIN. ;TRY AGAIN
NLIN2: PUSHJ P,NLINAM ;GET THE NAMELIST NAME
CAME T1, (P2) ;DOES IT MATCH THE ONE IN OUR TABLE?
JRST NLIN. ;NO, MOVE ON TO NEXT RECORD
TRNE T1,77 ;[426] HAVE WE A 6 CHARS NAME?
JSP P1,IBYTE. ;[426] YES - READ THE DELIMITER
NLIVAR:
PUSHJ P,NLINM ;GET A SIXBIT VARIABLE NAME
NLIVA0: MOVEI G4,1(P2) ;SPECIAL ENTRY, INITIALIZE SEARCH
NLIVA1: SKIPN (G4) ;END OF NAMELIST TABLE?
JRST NLIER2 ;YES, SYNTAX ERROR
ADDI G4,2 ;POINT TOT THE NEXT SYMBOL/OR DIMS
LDB G2,[POINT 9,-1(G4),8];GET THE NUMBER OF DIMS
CAMN T1,-2(G4) ;IS THIS THE VARIABLE
JRST NLIVA2 ;FOUND THE VARIABLE
JUMPE G2,NLIVA1 ;JUMP IF A SCALAR (FOR NEXT VAR.)
ADDI G4,1(G2) ;ARRAY, SKIP THE FACTORS ETC
JRST NLIVA1 ;GET THE NEXT VARIABLE
NLIVA2: ;FOUND A VARIABLE THAT MATCHES
SETZB G1,G3 ;INITIALIZE THE SUBSCRIPT AC'S
JUMPE G2,NLIAR4 ;JUMP IF A SCALAR
NLIVA3: CAIN T0,"(" ;STOP ON LEFT PAREN
JRST NLIAR1 ;YES, PARTICAL ARRAY
CAIN T0,"=" ;CHECK FOR ENTIRE ARRAY
JRST NLIAR3 ;YES, EN+w
TLNE P3,IO.EOL ;CHECK FOR END OF LINE
PUSHJ P,NXTLN. ;GET THE NEXT RECORD
JSP P1,IBYTE. ;READ A CHARACTER
JRST NLIVA3 ;CONTINUE
NLIAR1: MOVNS G2 ;NEGATE THE NUMBER OF DOM'S
MOVSS G2 ;PUT IN THE LEFT HALF
HRRI G2,1(G4) ;POINT TO THE FACTORS
NLIAR2: PUSHJ P,INTEG% ;GET A SUBSCRIPT
IMUL T0,(G2) ;MULTIPLY BY THE ASSOCIATED FACTOR
ADD G3,T0 ;ACCUMULATE THE SUM
LDB T0,DD.HRI+1(P3) ;GET THE DELIMITER
CAIE T0,")" ;END OF SUBSCRITTS
AOBJN G2,NLIAR2 ;OR DIM'S ..... NO
LDB T5,[POINT 4,-1(G4),12];GET THE TYPE CODE
CAIE T5,TP%COM ;COMPLEX
CAIN T5,TP%DOR ;OR DOUBLE REAL
ASH G3,1 ;YES, TWO WORDS/ENTRY
MOVE G1,(G4) ;GET THE OFFSET
SUBI G3,(G1) ;SUB THE OFFSET
HRRZ G1,-1(G4) ;GET THE BASE ADDRESS
ADDI G1,(G3) ;ADD IN THE SUBSCRIPT CALC.
JRST NLIAR5 ;GO DISPATCH
NLIAR3: HLLZ G1,(G4) ;GET THE ARRAY SIZE
MOVNS G1 ;NEGATE THE ARRAY SIZE
NLIAR4: LDB T5,[POINT 4,-1(G4),12];GET THE VARIABLE TYPE
CAIE T5,TP%COM ;COMPLEX
CAIN T5,TP%DOR ;OR DOUBLE PRECISION
ASH G1,1 ;DOUBLE THE ARRAY SIZE
HRR G1,-1(G4) ;GET THE VARIABLE ADDRESS
NLIAR5: PUSHJ P,NLIEQU ;SCAN FOR AN EQUAL SIGN
;**; [654] INSERT AT NLIAR5+1 SWG 26-APR-77
MOVEM T5,DAT.TP+2(P4) ;[654] REMEMBER DATA TYPE
TLZ P2,FT.PRC ;CLEAR DOUBLE PRECISION BITS
HRRZ T1,NMLTBL(T5) ;GET THE DISPATCH ADDRESS
PUSHJ P,(T1) ;GO TO THE ROUTINE
LDB T0,DD.HRI+1(P3) ;GET THE DELIMETER
JRST NLIVAR ;GET THE NEXT VARIABLE
;INTEGER INPUT ROUTINE
NLII: PUSHJ P,NLISCN ;FIND SOME DATA
TLNE P2,FT.NUL ;[366] NULL ITEM SEEN
JRST NLII1 ;[366] YES
PUSHJ P,NLILSD ;[325] CHECK RPT. LIST-DIRECTED
PUSHJ P,FLINC%## ;[206] GET AN INTEGER VARIABLE
JSP P1,NLIDLM ;CHECK THE DELIMITER
;**; [576] Change @ NLII1, JMT, 31-AUG-76
NLII1: TLNE P2,FT.LSD ;[576] LIST DIRECTED INPUT ?
JRST [ADD G1,DAT.TP+1(P4) ;[576] YES--ADD INCREMENT
JUMPL G1,NLII ;[576] STILL NEGATIVE,IF SO LOOP
POPJ P,] ;[576] NO--RETURN
AOBJN G1,NLII ;[366] CONTINUE
POPJ P, ;RETURN
;REAL INPUT ROUTINE (SINGLE/DOUBLE PRECISION)
;**;[465] Change @ NLID JNG 11-Nov-75
NLID: TLOA P2,FT.PRC ;[465] SET DOUBLE PRECISION
NLIF: TLZ P2,FT.PRC ;[465] SET SINGLE PRECISION
;**; [576] Add new label @ NLIF+1, JMT, 3-SEP-76
NLIF1: PUSHJ P,NLISCN ;[576] FIND SOME DATA
TLNE P2,FT.NUL ;[366] NULL ITEM
JRST NLIDF1 ;[366] YES
PUSHJ P,NLILSD ;[325] CHECK RPT. LIST-DIRECTED
PUSHJ P,REAL% ;GET A REAL VARIABLE
JSP P1,NLIDLM ;CHECK THE DELIMITER
;**; [576] Change @ NLIDF1, JMT, 31-AUG-76
NLIDF1: TLNE P2,FT.LSD ;[576] LIST DIRECTED INPUT ?
JRST [ADD G1,DAT.TP+1(P4) ;[576] YES--ADD INCREMENT
JUMPL G1,NLIF1 ;[576] STILL NEGATIVE,IF SO LOOP
POPJ P,] ;[576] NO--RETURN
JUMPSP NLID1 ;[366] JUMP ON SINGLE PRECISION
ADD G1,[XWD 1,1] ;POINT TO THE NEXT ENTRY
;**; [576] Change @ NLID1, JMT, 3-SEP-76
NLID1: AOBJN G1,NLIF1 ;[576] CONTINUE
POPJ P, ;RETURN
;LOGICAL INPUT ROUTINE
NLIL6: JSP P1,IBYTE. ;EAT THE CHARACTR
NLIL: PUSHJ P,NLISCN ;FIND SOME DATA
CAIN T0,"," ;IGNORE COMMAS
JRST NLIL6 ;EAT IT
CAIL T0,"0" ;IS THIS A DIGIT
CAILE T0,"9" ;0-9
JRST NLIL5 ;NO, NORMAL INPUT
PUSHJ P,INTEG% ;YES, GET THE REPEAT COUNT
MOVE G2,(G1) ;GET THE REPEAT COUNT
PUSHJ P,NLIL3 ;GET THE VARIABLE VALUE
MOVE T0,(G1) ;GET THE VALUE
;**; [576] Change @ NLIL1, JMT, 31-AUG-76
NLIL1: TLNE P2,FT.LSD ;LIST DIRECTED INPUT ?
JRST [ADD G1,DAT.TP+1(P4) ;[576] YES--ADD INCREMENT
JUMPL G1,.+2 ;[576] STILL NEGATIVE, PROCEED
POPJ P,] ;[576] NO--RETURN
AOBJP G1,CPOPJ ;END OF ARRAY
SOJLE G2,NLIL ;END OF REPEAT
MOVEM T0,(G1) ;STORE THE VARIABLE
JRST NLIL1 ;CONTINUE
NLIL5: PUSHJ P,NLIL3 ;GET THE VALUE
;**; [576] Change @ NLIL5+1, JMT, 31-AUG-76
TLNE P2,FT.LSD ;LIST DIRECTED INPUT ?
JRST [ADD G1,DAT.TP+1(P4) ;[576] YES--ADD INCREMENT
JUMPL G1,NLIL ;[576] STILL NEGATIVE,IF SO LOOP
POPJ P,] ;[576] NO--RETURN
AOBJN G1,NLIL ;CONTINUE IF ARRAY
POPJ P, ;RETURN
NLIL3: CAIN T0,"." ;DID WE STOP ON A PERIOD?
JRST NLIL2 ;YES, LOOK FOR .TRUE., ETC.
JSP P1,IBYTE. ;GET A T OR F
SETZM (G1) ;ASSUME IT'S AN "F"
CAIN T0, "T" ;WAS IT REALLY?
SETOM (G1) ;NO, BY GOSH, IT WAS A "T"
JSP P1,IBYTE. ;SET TO THE NEXT FOR DELINM
POPJ P, ;EXIT FROM COMMON LOGICAL ROUTINE
NLIL2: JSP P1,IBYTE. ;EAT THE PERIOD
JSP P1,IBYTE. ;GET A "T" OR AN "F"
SETZM (G1) ;ASSUME ITS AN "F"
CAIN T0, "T" ;WAS IT REALLY?
SETOM (G1) ;GOOD GRIEF - IT WAS A "T" !!!
NLIL4: JSP P1,IBYTE. ;NOW LOOK FOR A CLOSING PERIOD
CAIE T0,"." ;BUT WAS IT REALLY A PERIOD?
TLNE P3,IO.EOL ;END OF LINE
POPJ P, ;YES, EXIT FROM COMMON LOGICAL ROUTINE
CAIE T0,"$" ;CHECK FOR END OF NAMELIST RECORD
CAIN T0,"&"
POPJ P, ;YES, RETURN
JRST NLIL4 ;NO, TRY AGAIN
NLILSD: TLNE P2,FT.LSD ;[325] LIST DIRECTED I/O
TRNN P2,-1 ;[325] AND ADDR. SAVED
POPJ P, ;[325] NO-NO
MOVEM T0,(G1) ;[325] YES- SAVE VALUE
TLNE P2,FT.PRC ;[325] DOUBLE PRECISION?
MOVEM T1,1(G1) ;[325] SAVE SECOND WORD
AOS (P) ;[325] SET SKIP RETURN
POPJ P, ;[325]
;COMPLEX INPUT ROUTINE
NLIC5: JSP P1,IBYTE. ;EAT THE CHARACTER TRY AGAIN
NLIC: PUSHJ P,NLISCN ;FIND SOME DATA
TLNE P2,FT.LSD ;[325] LIST-DIRECTED I/O
TRNN P2,-1 ;[325] AND REPEAT COUNT
JRST NLIC7 ;[325] NO-NO
DMOVEM T0,(G1) ;[325] KNOWN VALUES
ADD G1,[XWD 1,1] ;[325] UPDATE ADDR
JRST NLIC2 ;[325] CONTINUE
NLIC7: CAIE T0,"(" ;[325] STOP AT LEFT PAREN
JRST NLIC1 ;MUST BE A REPEAT COUNT
NLIC4: JSP P1,IBYTE. ;EAT THE LEFT PAREN
PUSHJ P,REAL% ;INPUT REAL PART OF COMPLEX NMBR
ADD G1,[XWD 1,1] ;POINT TO IMAGINARY PART
PUSHJ P,NLISCN ;FIND SOME DATA
PUSHJ P,REAL% ;GET THE IMAGINARY PART OF COMPLEX
;**; [576] Change @ NLIC2, JMT, 31-AUG-76
NLIC2: TLNE P2,FT.LSD ;LIST DIRECTED INPUT ?
JRST [SUB G1,[XWD 1,1] ;[576] YES--BACK UP
ADD G1,DAT.TP+1(P4) ;[576] ADD INCREMENT
JUMPL G1,NLIC ;[576] STILL NEGATIVE,IF SO LOOP
POPJ P,] ;[576] NO--RETURN
AOBJN G1,NLIC ;CONTINUE
POPJ P, ;RETURN
NLIC1: ;REPEAT COUNT FOR COMPLEX
PUSHJ P,INTEG% ;GET THE REPEAT COUNT
MOVE G2,(G1) ;GET THE REPEAT COUNT BACK
;**;[574] @NLIC1 + 1 1/2, JMT, 10-AUG-76
LDB T0,DD.HRI+1(P3) ;[574] GET THE DELIMETER
CAIE T0,"*" ;[574] REPEAT DELIMETER ?
ERROR(DAT,15,15) ;[574] NO--ILLEGAL DELIMETER
TLNE G2,-1 ;[574] IS IT AN INTEGER ?
IFE CPU-KI10,<FIX G2,G2 ;[574] NO--CONVERT TO AN INTEGER>
IFE CPU-KA10,<
JRST [MULI G2,400 ;[574] NO--SEPERATE FRACTION AND EXP.
TSC G2,G2 ;[574] GET POSITIVE EXPONENT
EXCH G2,G3 ;[574] PUT REAL RESULT IN G2
ASH G2,-243(G3) ;[574] USE EXP. AS AN INDEX
JRST .+1]> ;[574] CONTINUE
PUSHJ P,NLISCN ;FIND THE DATA
CAIN T0,"(" ;LEFT PAREN
JSP P1,IBYTE. ;YES, EAT IT
PUSHJ P,REAL% ;GET THE REAL PART
ADD G1,[XWD 1,1] ;SET UP THE ARRAY
PUSHJ P,NLISCN ;FIND SOME DATA
PUSHJ P,REAL% ;GET THE IMAGINARY PART
TLNN P2,FT.LSD ;[325] LIST-DIRECTED I/O
JRST NLIC6 ;[325] NO
MOVEI T0,-1(G1) ;[325] GET ADDR.
HRRM T0,P2 ;[325] SAVE IT
MOVEM G2,RPT.SV(P4) ;[325] AND REPEAT COUNT
NLIC6: DMOVE T0,-1(G1) ;[325] GET THE COMPLEX NUMBER BACK
;**;[574] @NLIC3, JMT, 10-AUG-76
;**;[574] DELETE NLIC3: AOBJP G1,CPOPJ ;SET THE LOW ORDER WORD
;**; [576] Change @ NLIC3, JMT, 31-AUG-76
;**; [576] DELETE NLIC3: AOBJP G1,[HLLZS P2 ;[574] ZERO REPEAT ADDRESS
;**; [576] DELETE SETZM RPT.SV(P4) ;[574] CLEAR REPEAT COUNT ALSO
;**; [576] DELETE JRST CPOPJ] ;[574] SET THE LOW ORDER WORD
;**; [576] DELETE SOJLE G2,NLIC ;REDUCE THE REPEAT COUNT
NLIC3: TLNE P2,FT.LSD ;[576] LIST DIRECTED INPUT ?
JRST [SUB G1,[XWD 1,1] ;[576] YES--BACK UP
ADD G1,DAT.TP+1(P4) ;[576] ADD INCREMENT
JUMPL G1,.+2 ;[576] IF NEGATIVE, PROCEED
JRST NLIC8] ;[576] OTHERWISE, ONWARD
AOBJP G1,NLIC8 ;[576] [574] PROCEED IF END OF ARRAY
SOJLE G2,[SETZM RPT.SV(P4) ;[576] REDUCE THE REPEAT COUNT
JRST NLIC] ;[576] CLEAR REPEAT COUNT AND PROCEED
DMOVEM T0,(G1) ;STORE THE NEXT REPEATED COMPLEX NUMBER
ADD G1,[XWD 1,1] ;SET THE HIGH ORDER WORD
JRST NLIC3 ;CONTINUE
;**; [576] Add new label, JMT, 31-AUG-76
NLIC8: HLLZS P2 ;[576] [574] ZERO REPEAT ADDRESS
SETZM RPT.SV(P4) ;[576] [574] CLEAR REPEAT COUNT ALSO
JRST CPOPJ ;[576] [574] SET THE LOW ORDER WORD
NLIS: ;INPUT A STRING OF ASCII TEXT
;TEXT IS BOUNDED BY SINGLE QUOTES '...'
JSP P1,IBYTE.## ;EAT THE FIRST QUOTE MARK
;**;[465] Change @ NLIS0 JNG 6-Nov-75
NLIS0::MOVSI T1,(POINT 7,) ;[465] ASCII BYTE POINTER
HRRI T1,(G1) ;[465] TO OUR OUTPUT DATA WORD
MOVE T0,[ASCII / /];SET THE OUTPUT TO BLANKS FOR COMPARE
MOVEM T0,(G1) ;CLEAR THE OUTPUT WORD
PUSH P,[5] ;[465] SAVE CHAR COUNT TILL WORD FILLS
;**; [576] Change @ NLIS0+4 1/2, JMT, 8-AUG-76
CAIE T5,TP%COM ;[576] MORE TO DO IF COMPLEX, AND ALSO
JUMPSP NLIS1 ;[465] MORE FIXING NEEDED IF D.P.
MOVEM T0,1(G1) ;[465] CLEAR 2ND HALF WORD
MOVEI T0,^D10 ;[465] RESET COUNT TO 10 CHARS
MOVEM T0,(P) ;[465] SO CAN INPUT D.P. STRING
;**; [576] Delete line @ NLIS0+9L, JMT, 8-AUG-76
;**; [576] DELETE AOBJN G1,.+1 ;[465] ADVANCE G1 CORRECTLY FOR EXIT
NLIS1: JSP P1,IBYTE.## ;GET A CHARACTER
CAIE T0,"'" ;CHECK FOR THE END OF STRING
TLNE P3,IO.EOL ;OR END OF LINE
;**;[465] Change @ NLIS1+3L JNG 6-Nov-75
JRST [POP P,(P) ;[465] REMOVE JUNK FROM STACK
;**; [541] INSERT IN LITERAL @ NLIS1 + 3 1/2 L CLRH 6-MAY-76
TLZ P2,FT.QOT ;[541] CLEAR QUOTE FLAG
POPJ P,] ;[465] RETURN END OF STRING
IDPB T0,T1 ;NO, STORE THE CHARACTER
SOSLE (P) ;[465] END OF VARIABLE?
JRST NLIS1 ;NO CONTINUE
POP P,(P) ;[465] CLEAR JUNK FROM STACK
;**; [534] DELETE @ NLIS1 + 9L CLRH 23-APR-76
JSP P1,IPEEK.## ;CHECK FOR EXACT FIT
CAIE T0,"'" ;ENDING QUOTE
;**; [534] CHANGE @ NLIS1 + 12L CLRH 23-APR-76
JRST NLIS2 ;[534]
JSP P1,IBYTE.## ;YES, EAT THE QUOTE
;**; [541] INSERT @ NLIS2 -1 1/2 CLRH 6-MAY-76
TLZ P2,FT.QOT ;[541] CLEAR QUOTED STRING FLAG
POPJ P, ;END OF QUOTE FOR THIS VARIABLE
;**; [534] INSERT BEFORE NLINAM CLRH 23-APR-76
NLIS2: TLO P2,FT.QOT ;[534] SET CONTINUE QUOTE FLAG
;**; [576] Change @ NLIS2, JMT, 3-SEP-76
TLNE P2,FT.LSD ;[576] LIST DIRECTED INPUT ?
JRST [ADD G1,DAT.TP+1(P4) ;[576] YES--ADD INCREMENT
JUMPL G1,NLIS0 ;[576] IF NEGATIVE, LOOP
POPJ P,] ;[576] RETURN
AOBJN G1,NLIS0 ;[534] END OF ARRAY
POPJ P, ;[534] RETURN
SUBTTL COMMON SUBROUTINES NLI
NLINAM: ;ROUTINE TO GET A VARIABLE NAME
TLNE P3,IO.EOL ;CHECK FOR END OF LINE
PUSHJ P,NXTLN. ;GET THE NEXT RECORD
JSP P1,IBYTE. ;GET A CHARACTER
NLINM: CAIE T0,"$" ;CHECK FOR END OF
CAIN T0,"&" ;OF NAME LIST DATA BLOCK
JRST NLIFIN ;YES, END BLOCK
CAIL T0,"A" ;VARIABLE MUST START WITH ALPHA
CAILE T0,"Z" ;A-Z
JRST NLINAM ;NO, TRY AGAIN
NLINA0: TDZA T1,T1 ;CLEAR THE OUTPUT WORD
NLINA1: JSP P1,IBYTE. ;GET THE NEXT INPUT CHARACTER
CAIL T0,"A" ;IS IT AN ALPHA
CAILE T0,"Z" ;A-Z
JRST .+2 ;NO, CHECK DIGITS
JRST NLINA2 ;YES, STORE THE CHARACTER
CAIL T0,"0" ;CHECK THE DIGITS
CAILE T0,"9" ;0-9
JRST NLINA3 ;NON ALPHA/NUM CHARACTER
;**;[461],NLINA2,DPL,18-JUL-75
NLINA2: MOVE T2,T0 ;[461] USE T2, KEEP T0 ASCII
TRC T2,140 ;[461] CONVERT THE ASCII
TRNN T2,140 ;[461] CHARACTER TO A SIXIT
IORI T2,40 ;[461] CHARACTER (CORRECT THE CASE)
ANDI T2,77 ;[461] SAVE ONLY 6 BITS
LSH T1,6 ;STORE IT T1
IOR T1,T2 ;[461] INSET THE CHARACTER
JUMPGE T1,NLINA1 ;CONTINUE FOR SIX CHARACTERS
POPJ P, ;RETURN T1=SIXBIT CHARACTER
NLINA3: LSH T1,6 ;LEFT JUSTIFY THE CHARACTER
JUMPGE T1,.-1 ;CONTINUE
POPJ P, ;RETURN
NLISC1: JSP P1,IBYTE. ;EAT THIS CHARACTER
TLNE P3,IO.EOL ;AT END OF LINE
PUSHJ P,NXTLN. ;YES, ADVANCE TO NEXT LINE
TLNN P2,FT.LSD ;[350] LIST-DIRECTED INPUT
JRST NLISCN ;[350] NO
TLNE P3,IO.EOF ;[350] CHECK EOF
POPJ P, ;[350] RETURN
NLISCN: TLNE P2,FT.LSD ;[325] LIST DIRECTED I/O?
TRNN P2,-1 ;[325] ADDRESS SAVED?
JRST NLISC4 ;[325] NO-NO
SOSG RPT.SV(P4) ;[325] DONE WITH REPEAT?
JRST NLISC3 ;[325] YES
DMOVE T0,(P2) ;[325] NO-RETRIEVE VALUE
POPJ P, ;[325] RETURN
NLISC3: HRRI P2,0 ;[325] YES CLEAR SAVED ADDR.
SETZM RPT.SV(P4) ;[325] AND CLEAR REPEAT COUNT
LDB T0,DD.HRI+1(P3) ;[325] RETRIEVE DELIMITER
CAIE T0,"/" ;[325] WAS END OF INPUT?
JRST NLISC4 ;[325] NO
SUB P,[XWD 1,1] ;[366] [325] SET RETURN
TLO P2,FT.SLH ;[366] SET FLAG AS SLASH SEEN
POPJ P, ;[325]
NLISC4: JSP P1,IPEEK. ;[325] LOOK AT THE NEXT CHARACTER
NLISC2: CAIE T0,11 ;SKIP TABS
CAIN T0," " ;AND SPACES
JRST NLISC1 ;IGNORE THESE CHARACTERS
CAIE T0,15 ;.IPEEK CAN RETRUN A CR
TLNE P3,IO.EOL ;AND END OF LINES
JRST NLISC1 ;IGNORE IT
TLNE P2,FT.LSD ;LIST DIRECTED SCAN
JRST LSDSCN ;YES, CONTINUE AT LIST DIRECTED
CAIE T0,"$" ;AT END OF NAMELIST BLOCK
CAIN T0,"&" ; % OR %
JRST NLIFIN ;YES, QUIT
CAIN T0,"," ;COMMA
JRST NLISC1 ;IGNORE
POPJ P, ;GOT SOMETHING ELSE
LSDSCN: ;LIST DIRECTED SCAN ROUTINE
CAIG T0,<CR==15> ;[325] SKIP ALL THOSE CHAR.
JRST NLISC1 ;[325] EAT THEM
CAIN T0,"," ;CHECK FOR NULL INPUTS
JRST [TLON P2,FT.NUL ;[325] COMMA ALREADY SEEN?
JRST NLISC1 ;[325] NO-SET SEEN AND IGNORE
JSP P1,IBYTE. ;[325] YES-EAT COMMA
POPJ P,] ;[325] WITH "NUL" ITEM
CAIN T0,"/" ;END OF INPUT
JRST [SUB P,[XWD 1,1] ;[366]
TLO P2,FT.SLH ;[366] SET FLAG SLASH SEEN
POPJ P,] ;[366] RETURN TO LSTDR%
TLZ P2,FT.NUL ;[325] THIS ITEM IS NOT NUL
CAIN T0,"'" ;STRING MARKER
JRST [PUSHJ P,NLIS ;YES, PROCESS THE STRING
;**; [576] Change in literal @ LSDSCN+14L, JMT, 3-SEP-76
TLNE P2,FT.LSD ;[576] LIST DIRECTED ?
JRST NLISC5 ;[576] YES--PROCEED
AOBJN G1,NLISCN ;[465] ANYTHING LEFT
SUB P,[XWD 1,1] ;REDUDE THE STACK FOR THE RETURN
POPJ P,] ;RETURN TO LSTDR%
POPJ P, ;RETURN
;**; [576] New label and code @ LSDSCN+18L, JMT, 3-SEP-76
NLISC5: ADD G1,DAT.TP+1(P4) ;[576] ADD INCREMENT
JUMPL G1,NLISCN ;[576] LOOP IF STILL NEGATIVE
SUB P,[XWD 1,1] ;[576] FIX STACK FOR RETURN
POPJ P, ;[576] RETURN
NLIEQU: ;EARCH FOR AN EQUAL SIGN
CAIN T0,"=" ;IS THIS AN EQUAL
POPJ P, ;YES, RETURN
TLNE P3,IO.EOL ;AT END OF LINE
PUSHJ P,NXTLN. ;YES, READ NEXT RECORD
JSP P1,IBYTE. ;GET A CHARACTER
CAIL T0,"A" ;IS IT ALPHA
CAILE T0,"Z" ;A-Z
JRST NLIEQU ;NO, TRY =
PUSHJ P,NLINA0 ;GET THE SYMBOL NAME
JRST NLIVA0 ;MUSTBE A VARIABLE NAME
NLIDLM: ;CHECK THE DELIMITER FOR A REPEAT
LDB T0,DD