                    
/fortran subr. package - tape 1 ---------------
/24 nov 65
/version 003

/errors_.
/illegal op.code 140000 is used for error halts
/the addr. part indicates the type of error
/push continue twice to get past the halt

/140001 = mul div switches not on - program will not run until switches are on
/140002 = paper tape parity error - put char. in TW, push continue twice
/140003 = illegal format, nogo
/140004 = no c/r at end of format (paper tape input)
/140005 = non digit char. in i or f input, go on - invalid char. used anyway
/140006 = ------- not used ---------------------------
/140007 = overflow - i input - go on and overflowed value used anyway
/140010 = printer error status bit on - go on and status is rechecked
/140011 = do index .> | 131071|   ,go on - index invalid
/140012 = flt. no. too large to convert to fixed pt., go on - trash for fixed pt. no.
/140013 = not enough room in array storage, compiler error or array ig's used as decal inserts
/140014 = too many subsc. or out of range, go on - invalid subsc. used anyway
/140015 = out of bounds of array, go on - invalid subsc. used anyway
/140016 = recursive subsc. - not allowed
/140017 = exponent underflow, no go
/140020 = exponent overflow, no go
/140021 = sqrtf has a negative argument - go on, argument made positive
/140022 = logf or log10f argument .< 0   no go


/addr. 7777 is used for various debug. switches
/bit 0 on = type overbar at start of every format check
/bit 1 on = output number even if "f" or "i" field overflows

/addr. 7775 and 7776 are used for escape char. in the format routines
/if the input char. is the same as the char. in either address, for f, i, a, or x,
/the input for the field is terminated and the next format specification is checked
/normally c(7775) = tab, and c(7776) = carriage return


xsy cal lap dpy srb iot
xsy rcb cnv esm lsm cbs msm
xsy mwc mrc mcb rck cac eem lem 
xsy procedure [
xsy mcs chn mec dao iso isd
xsy asd aso asc dsc isb bac
xsy bpc bio bjm dal 
xsy goto < .< > .> ^
xsy sin cos atn sqrt ln log exp exp10 |=
xsy if then else clear set for stepu stepd
xsy until while do <=
xsy .>>04<< .=
xsy mus dis

xsy / x float unflt

x dig	beg lv6 op2 rs1 cmt
	jda fsy
	flexo imp
	lac 2 lst end

/ dig	beg lv6 op2 rs1
	jda fsy
	flexo idv
	lac 2
	fde lst
	hlt end


dss flc fdc fsb fad fmp fdv
dss idv imp float unflt
dss fbd sof











/the following is used only during initialization of the array area and
/is cleared and overlapped by the arrays
/>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<>>05<<
typ4,	0
	dap typ4exit
	law i 4. => ct
	lio typ4
	ril 6s
	jmp .+2
typ4loop,	lio typ4
	cla
	rcl 3s
	dio typ4
	sza i
	law 20
	jda swap
	jsp typ
	isp ct
	jmp typ4loop
typ4exit,	jmp 0

clear,	sub (1
	dap exit
	law 1	/check for mul div switches on
	mul (77
	div (77
	jmp .+3
	sad (1
	jmp .+3
	oct 140001	/halt - switches are not on
	jmp .-7
	lac cpbinst	/change "jda arf" to "cpb" intext /
	dac i exit
	law 36
	dac 7775
	lio  /.77
	dio 7776
	jsp typ
	lac arf
	sza i
	jmp exit-1
	final - arf => arf
	tpo
	text /arrays /
	lac arf
	jda typ4
	cli
	jsp typ
	lac final
	jda typ4
	lio (77
	jsp typ
	lac arf
	lio final
	jmp back
cpbinst,	oct 730445
/^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
/the above is all overlapped by the arrays



final,	loc .-1
arf'	0
	jmp clear
back,	jda clearmem
	lac final
	dac i arf
	cla cli clf 7
exit,	jmp 0
blk





errfmt'	lac 7777
	ral 1s
	spa
	jmp tryit
	lio (flexo   -
	xct unit
	isp w1m
	jmp .-3
	jmp nxtlist
tryit,	idx w1
	szf 4
	jmp iout
	jmp fout


digit,	0
	dap exit
	lac digit
	sub (dec 10
	sma
	oct 140005	/non-digit halt
	lac digit
exit,	jmp 0
blk




/interchange AC and IO
swap,swf'	0
	dap exit
	lac swap
	rcr 9s
	rcr 9s
exit,	jmp 0
blk



/get a char. from the typewriter
typin,	dap exit
	cla cli clf 1
	szf i 1
	jmp .-1
	clf 1
	tyi
	dio swap
	lac swap
	sad 7776
	jmp exit
	sad 7775
	jmp exit
	idx exit
	lac swap
exit,	jmp 0
blk




leav,	idx return
	jsp eol
rtf'return,list,  jmp 0


ti,	jsp typin
tif'sv1,	0
	dap return
	lac tif
	lio ti
	jmp in


typ'	dap .+10
	dio swap
	cks
	ril 2s
	spi i
	jmp .-3
	lio swap
	tyo
	jmp 0
to,	jsp typ
tof'sv2,	0
	dap return
	lio to
	lac tof
	jmp out


/Following is the input/output routine with format decoding.

/enter at "in" for input devices with the address of the format in the AC
/and a word to be executed by an "xct" intext / in the IO_ which will cause
/a 6 bit input char/ to be in the AC following the "xct" intext /
/the input routine called by the "xct" instr/, must have two returns_,
/a normal return to the word following the "xct" intext / is made if the
/input 6 bit char/ matches the contents of 7775 or 7776, a skip return
/(or return +1) is made if the input char. does not match 7775 or 7776.

/enter at "out" for output devices with the address of the format in the AC
/and a word to be executed by an "xct" intext / in the IO_ which will cause
/a 6 bit output char/ from the IO to be output.

inf'in,	stf 3
	jmp in2
out,	clf 3
in2,	dac fmtadr
	dio unit

	clf 6
	dzm rpt
	lac fmtadr
	dac format
getlist,	lac i list	/check for end of input/output list
	sad (760000
	stf 6	/flag 6 on indicates that the end of list is present
	dzm word
	lac 7777	/debug.
	sma
	jmp pst
	lio (flexo   .
	jsp typ
pst,	lio i format	/check for type of format specification
	cla
	rcl 6s
	sad (flexo   x
	jmp xfld
	sad (flexo   h
	jmp hfld
	sad (flexo   /
	jmp slash
	sad (76
	jmp eofmt
	szf 6
	jmp xfld
	sad (flexo   f
	jmp ffld
	sad (flexo   i
	jmp ifld
	sad (flexo   a
	jmp afld
	sad (flexo   c
	jmp pcc
	sza
	jmp illfmt	/illegal format
	lac i format	/must be repeat
	cma
	dac rpt
idxfmt,	idx format
	jmp getlist

nxtlist,	idx list
	isp rpt
	jmp getlist
	dzm rpt
	jmp idxfmt

illfmt,	oct 140003	/halt - unrecognized format specification
	jmp .-1

eofmt,	szf 6
	jmp leav
	jsp eol
	jmp getlist-3
blk





pcc,	cla	/format spec. "c" is for printer paper advance control
	rcl 6s
	dac caf
	jmp idxfmt






ldblks,	0
	dap exit
a37,	cli
	xct unit
	isp ldblks
	jmp a37
exit,	jmp 0
blk

setws,	dap exit
	cla
	rcl 6s
	dac w1
	cma
	dac w1m
	cla
	rcl 6s
	dac w2
exit,	jmp 0
blk



udf'	oct 140017	/halt - exp. underflow
caf'	0	/printer carriage advance control digit
format,	0
fmtadr,	0
unit,	0
ovf'	oct 140020	/halt - exp. overflow
rpt,	0


afld,	jsp setws
	szf i 3
	jmp ao
a1,	xct unit
	jmp strit-1
	rcr 6s
	lac word
	rcl 6s
	dac word
	isp w1m
	jmp a1
	lac word
strit,	xct i list
	jmp nxtlist

ao,	xct i list
	dac word
	law 3
	sub w1
	sza i
	jmp a3
	sma
	jmp a4
	jda ldblks
	law i 3. => w1m
a3,	lio word
	cla
	rcl 6s
	dio word
	jda swap
	xct unit
	isp w1m
	jmp a3
	jmp nxtlist
a4,	cma
	dac w2
	lio word
	ril 6s
	isp w2
	jmp .-2
	jmp a3+1
blk


hfld,	law 7777
	and i format
	cma
	dac w1m
	szf 3
	jmp hi
h1,	idx format
	law i 3. => w2
	lac i format
	dac temp
h2,	cla
	lio temp
	rcl 6s
	dio temp
	jda swap
	xct unit
	isp w1m
	jmp .+2
	jmp idxfmt
	isp w2
	jmp h2
	jmp h1

hi,	law i 3. => w2	/"h" input directly replaces the "h" field in the format
	idx format
	dzm word
h5,	xct unit
	nop
	rcr 6s
	lac word
	rcl 6s
	dac word
	isp w1m
	jmp .+2
	jmp h6
	isp w2
	jmp h5
	lac word
	dac i format
	jmp hi
h6,	lac word
	dac i format
h7,	isp w2
	jmp .+2
	jmp idxfmt
	lac i format
	rcl 6s
	ior (76
	dac i format
	jmp h7
blk


slash,	jsp eol
	jmp idxfmt	/"/" in a format causes an end of line

eol,	dap exit
	lio (77
	szf 3
	jmp isinp
	xct unit
exit,	jmp 0
isinp,	lac unit
	sas tif-1
	jmp papr
	jsp typ
	jmp exit
papr,	xct unit
	nop
	sad 7776
	jmp exit
	sad 7775
	jmp exit
	oct 140004	/no c/r or tab at end of line (paper tape input)
	jmp exit
blk




ifld,	jsp setws
	clf 4
	szf i 3
	jmp iout
iin,	xct unit
	jmp i7
	sad (20
	cla
	sas (flexo   -
	jmp .+3
	stf 4
	jmp i6
	dac temp
	jda digit
	law i 10. => ct	/mul previous value by 10 and add new value
	dzm fwrd	/and check for overflow
	clo
i5,	fwrd + word => fwrd
	isp ct
	jmp i5
	fwrd + temp => word
	szo
	oct 140007	/overflow   value > | 131071|
i6,	isp w1m
	jmp iin
i7,	lac word
	szf 4
	cma
	jmp strit

iout,	lac w1
	ral 6s
	jda sof
	xct i list
	jda float	/float the value in the accumulator
	dac fwrd
	dio fwrd+1
	stf 4
getrid,	law fwrd
	jda fbd
	jmp nxtlist
blk






output'	jsp .+1
	dap exit
	szf i 4
	jmp oput
	jda swap
	sad (73
	jmp nxtlist
	jda swap
oput,	xct unit
exit,	jmp 0
blk







fout,	clf 4
	noi 1
	add w1
	sub w2
	sal 6s
	ior w2
	jda sof
	efm 2
	xct i list
	dac fwrd
	lfm
	jmp getrid
blk





xfld,	jsp setws
	szf 3
	jmp xin
	lac w1m
	jda ldblks
	jmp idxfmt
xin,	xct unit
	jmp idxfmt
	isp w1m
	jmp xin
	jmp idxfmt
blk






"10.0",	oct 240000
	oct 10000
fwrd,	0
	0

ffld,	jsp setws
	szf i 3
	jmp fout
	dzm ct
	dzm fwrd
	dzm fwrd+1
	clf 5
	clf 4
gdigt,	xct unit
	jmp setfract
	sas (flexo   -
	jmp .+3
	stf 4
	jmp nxtdig
	sad (..20
	cla
	sad (73
	jmp decpt
	jda digit
	jda float	/float the integer digit in the accumulator
	dac ftemp
	dio ftemp+1
	idx ct
	efm 2
	lac fwrd
	mul "10.0"
	add ftemp
	dac fwrd
	lfm
nxtdig,	isp w1m
	jmp gdigt
setfract,	lac w2
	szf 5
	lac ct	/dec.pt. overrides format spec.
	sza i
	jmp nopt
	cma
	dac ct
	efm 2	/flt.pt. number is still in flt.accumulator
	div "10.0"
	hlt
	isp ct
	jmp .-3
strval,	szf 4



	cma
	xct i list	/store the flt. word
	lfm
	jmp nxtlist
decpt,	dzm ct
	stf 5
	jmp nxtdig
nopt,	efm 2
	jmp strval
blk
stp.
                
z                                
/fortran subroutine package - tape 2 -------------------------------




/display the sense lights in the prog. flags and halt
dff'	dap exit
	clf 7
	law 1
	sad f1f
	stf 1
	sad f2f
	stf 2
	sad f3f
	stf 3
	sad f4f
	stf 4
	sad f5f
	stf 5
	sad f6f
	stf 6
	cla cli hlt
exit,	jmp 0

f1f'	0
f2f'	0
f3f'	0
f4f'	0
f5f'	0
f6f'	0
	blk

/do handling subr.
/do loops may count up or down by any increment
/if a do loop is satisfied the index, upon exit, contains the same value

dof'ctaddr,word,  0	/"word" used in format routine
	dap exit
	clo
	xct i exit
	dac doit
	idx exit
	law i 1
	add ctaddr
	dac lmaddr
	lac i ctaddr
	spa
	jmp some
	lac (oct 650500	/sma sza i
	lio = oct 650200	/spa i
	jmp more
some,	lac (oct 650200	/spa i
	lio (oct 650500	/sma sza i
more,	dac check
	dio check2
	lac i doit
	add i ctaddr
	dac i doit
	szo
	oct 140011	/do index .> | 131071|
ok,	sub i lmaddr
	szo
	jmp over
check,w1,	0	/"w1" used in format routine
	jmp loopagain
around,	lac i doit	/restore index for exit
	sub i ctaddr
	dac i doit
exit,	jmp 0

loopagain,	idx ctaddr
	jmp i ctaddr

over,	lac i doit
	add i lmaddr
check2,w2_0	0	/"w2" used in format routine
	jmp loopagain
	jmp around
doit,w1m_0	0	/w1m used in format routine
lmaddr,temp,	0	/temp "   "     "      "
blk




/fixed to floating conversion for fortran arith. statement
/from fortran stmnt      a = i-j/k
/fortran output	i-j/k
/		jda xf
/		dac a

xf'ct,	0	/"ct" used in format routine
	dap exit
	lac i exit
	dac store
	lac xf
	jda float	/float the value in the accumulator
	dac i store
	idx store
	dio i store
	idx exit
exit,	jmp 0


/floating to fixed conversion for fortran arith.
/from fortran stmnt     i = a+b
/fortran output	efm 2
/		a+b
/		jsp ff
/		dac i


ff'	dap exitff
	jsp fdc	/store flt. AC
	loc store
	law store
	jda unflt
	oct 140012	/flt. no. too large to convert to fix.pt.
	xct i exitff
	idx exitff
exitff,	jmp 0
store,ftemp, 0
	0	/"ftemp" used in format routine
	blk

/array handling subroutines
/i1f defines 1 word (integer) arrays
/i2f defines 2 word (floating) arrays
/subsc. values begin with 1 instead of 0
/no recursive subsc.



clearmem,ptr,	0
	dap r
	dio endchk
loop,	dzm i ptr
	idx ptr
	and (7777
	sas endchk
	jmp loop
r,	jmp 0
endchk,	0
	blk


i2f'	dap exit
	cla
	jmp setrealflag

i1f'	dap exit
	law 600
setrealflag,	dap realflag	/usk for integer, nop for real
	noi 1 + exit . swap	/make call to array subr. a usk
	poi 640600 =>|  swap
	exit| .ptr
	idx exit
	idx ptr
	ptr| .ptr	/now points to num of dim in subscript storage

	lac i ptr
	dap arraynameptr
	ral 5s
	and (37
	dac nod
	cma
	dac count
	1 => length

muloop,	idx ptr
	xct i ptr
	ACxlength=>length
	isp count
	jmp muloop	/fall out pointing to nth dim

	length
realflag,	skp 0
	sal 1s	/double the length for real arrays
	AC+nod=>spaceneeded
	arf => listptr	/look thru array storage

lookloop,	listptr|
	sma
	jmp look
in,	AC^poi 377777=>listptr
	sad final
	oct 140013	/no room
	jmp lookloop

look,	sub listptr
	sub spaceneeded
	sma
	jmp enough
	listptr|
	jmp in

enough,	listptr+nod
	xct realflag
	ior (400000	/mark real arrays with sign bit a 1
arraynameptr,	dac 0	/set up name register
	listptr| =>oldptr
	lac listptr
	add spaceneeded
	ior (400000
	dac i listptr
	and (377777
	sad oldptr
	jmp past	/new array exactly fills old space
	dac ct	/this was    oldptr =>| (AC)   in old version
	lac oldptr
	dac i ct

past,	poi 400000-nod=>count	/set up for backwards isp
	1=>partialprod
prodloop,	isp count
exit,	jmp 0
	idx listptr
	xct i ptr
	ACxpartialprod=>partialprod=>| listptr	/store products of dimensions
	law i 1.+ptr=>ptr
	jmp prodloop

ptr,	0
nod,	0	/no. of dimensions
count,	0
spaceneeded,	0
listptr,	0
oldptr,	0
partialprod,length,	0

blk









test,	0
nos,	0
csn,	0
io,	0
ssc'	jda .+1	/this order is executed
ac,	0
	AC.ret1.ret2
	idx ret2	/set the return addresses
	dio io	/save io
	AC-2
a,	AC.b
b,	lac 0
	sas locssc
	jmp a	/find entry in subscript area
	idx b
	xct b
	dip operation
	dap sscptr	/set op and ptr to subscript values
	dzm csn
	sscptr|  . arrayname
	ral 5s
	AC^poi 37 => nos	/set no. of subsc.
arrayname,	lac 0
	AC . operation . dimptr
	jda swap	/save mode bit in IO sign
	cla
	spi i
	law 600
	dap efmflag	/set efmflag according to mode
	lac (oct 332400
	rcl 1s
	dac scale
loop,	idx sscptr
	noi 1 + dimptr . dimptr
	idx csn
	sad nos
	jmp lastssc
	sscptr|
	sad locssc
	jmp recurse
sscptr,	xct 0	/get subscript value (skipped if recursive)
	sub (1
dimptr,	mul 0	/mul by dimension value
	sza	/too many subsc. or out of range if not zero (spa?)
	oct 140014
	scl 9s
	scl 8s
scale,	0	/shift left 1 (mul by 2) if real array
	AC+operation.operation
	jmp loop
lastssc,	sscptr|
	sad locssc
	jmp recurse
	xct sscptr	/this instruction skipped if recursive
	sub (1
	lio i dimptr
	spi
	jmp c
	mul i dimptr	/do final mul if dimlist is not exhausted
	scl 9s
	scl 8s
c,	xct scale
	AC+operation.operation
	AC^poi 7777=>test	/set up operand address
d,	dimptr|
	spa
	jmp e
	noi 1+dimptr.dimptr
	jmp d	/step past unused dimensions
e,	(AC^poi 7777)-test
	sma sza i
	oct 140015	/bounds check
	ac
	lio io
efmflag,	skp 0
	efm 2
operation,	0
ret1,	jmp 0
ret2,	jmp 0

recurse,	oct 140016	/recursive subsc.

locssc,	loc ssc
	blk
fin.
                
e                                
xsy imp idv tpo

idv'	0
	dap exit
	xct i exit
	dac temp
	idx exit
	lac idv
	scr 9s
	scr 8s
	div temp
	jmp exit
	dac temp
	idx exit
	lac temp
exit,	jmp 0
	blk


imp'ct3,	0
	dap exit
	xct i exit
	dac temp
	idx exit
	lac imp
	mul temp
	scl 9s
	scl 8s
exit,	jmp 0
	blk

dss typ
tpo'	dap exit
next,	lac i exit
	dac temp
	idx exit
	law i 3
	dac ct3
loop,	cla
	lio temp
	rcl 6s
	dio temp
	sad (13
exit,	jmp 0
	rcr 9s
	rcr 9s
	jsp typ
	isp ct3
	jmp loop
	jmp next
temp,	0
	blk
fin.
                
>>12<<                                         
