|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 15360 (0x3c00)
Types: TextFile
Names: »tw3j«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦09b4e9619⟧ »thcømat«
└─⟦this⟧
(w3j=slang fpnames type.yes insertproc entry.no
w3j w3l)
;S.E.Harnung.
;
;real procedure w3j(j1,j2,j3,m1,m2,m3);
;parameters value,real
;
;real procedure w3l(l1,l2,l3,cs1,cs2,cs3);
;parameters value,integer
;
;
;b. h100 w.
;m. fpnames
;t.
b. c4,g1 ;block with names for tails and insertproc
k=0
s. ;start of slang segment
a2,b9,d4,e21,f8,g2,j41
h.
g0=0 ;no externals
c0:
g1: g2,g2 ;head word:
;rel last point, rel last abs word
j0: 1<11 o. 1,0 ;segment table address of next segment
j4: g0+4,0 ;RS: take expression
j6: g0+6,0 ;RS: end register expression
j13: g0+13,0 ;RS: last used
j29: g0+29,0 ;RS: param alarm
j30: g0+30,0 ;RS: saved stack ref, saved w3
d0=k-c0
j40: 0,1 ;mode ;sign of w3l
d1=k-c0
j41: 0,3 ;wrk loc
g2=k-2-g1 ;rel of last abs word; no points
w.
c1: g0,0 ;externals, own bytes to be initialized
18 11 76, 26 01 81 ;first date, date current version
a0: 3 ;mask
0
a1: 2048 ;floating 0
a2: 0 ;wrk loc
0
d2: 0 ;sum: addr of entry on next segment
c2: al w1 1 ;entry w3l: mode:=1
jl. e1.
c3: al w1 0 ;entry w3j: mode:=0
e1: rs. w1 (j40.) ;save mode
rl. w2 (j13.) ;get stack top
ds. w3 (j30.) ;saved stack ref, saved w3
al w3 8
rs. w3 (j41.) ;rel of formal2
e2: sl w3 29 ;for w3:=8 step 4 until 28 do
jl. e3. ;get actual param
am x3
dl w1 x2 ;get formals
so w0 16 ;if expr
jl. w3 (j4.) ;then take expr
ds. w3 (j30.) ;save return
rl w1 x1 ;get value
rs. w1 d2. ;save value for test
rl. w3 (j41.)
al w3 x3+4
as w3 -1 ;w3:=(w3+4)//2
am x3
rs w1 x2 ;store param in stack
as w3 1
rs. w3 (j41.)
jl. e2. ;end reading of param
e3: al w2 x2+6 ;w2 points to stackbyte(6)
rl. w3 (j40.)
sn w3 0 ;if mode=0
jl. e9. ;then w3j else w3l
al w3 0
rs. w3 (j40.) ;j40 points to exp of (-1) ;exp:=0
e4: rl w0 x2+10
sh w0 -1
ac w0 (0) ;w0:=abs cs3
am x3 ;if w3=0 then w1:=cs1
rl w1 x2+6 ;else if w3=2 then w1:=cs2
sh w1 -1
ac w1 x1 ;w1:=abs cs1 (abs cs2)
sl w0 x1 ;if abs cs3<abs cs1 (abs cs2)
jl. e5. ;then permute
rl w0 x2+4 ;w0:=l3
am x3
rl w1 x2 ;w1:=l1 (l2)
am x3
rs w0 x2 ;l1 (l2) :=l3
rs w1 x2+4 ;l3:=l1 (l2)
rl w0 x2+10 ;w0:=cs3
am x3
rl w1 x2+6 ;w1:=cs1 (cs2)
am x3
rs w0 x2+6 ;cs1 (cs2) :=cs3
rs w1 x2+10 ;cs3:=cs1 (cs2)
rl. w1 (j40.)
al w1 x1+1
rs. w1 (j40.) ;exp:=exp+1
e5: se w3 0
jl. e6.
al w3 2
jl. e4. ;end permutation
e6: rl. w3 (j40.) ;w3l phase: exp>=0
rl w1 x2
wa w1 x2+2
wa w1 x2+4 ;w1:=2*(l1+l2+l3)
so w1 2 ;if l1+l2+l3 even
al w3 0 ;then exp:=0
rl w0 x2+4
ws w0 x2+10
as w0 -1
wa w3 0 ;exp:=exp+l3-cs3
as w1 -1
ws w1 x2+4 ;w1:=l1+l2-l3+
rl w0 x2+6
sh w0 -1
am 1
al w1 x1 ;+(if cs1<0 then 1 else 0)
rl w0 x2+8
sh w0 -1
am 1
al w1 x1 ;+(if cs2<0 then 1 else 0)
rl w0 x2+10
sh w0 -1
am -1
al w1 x1 ;-(if cs3<0 then 1 else 0)
sh w1 -1
ac w1 x1 ;w1:=abs w1
la. w1 a0. ;w1:=w1 mod 4 (clearbit 0-21)
sz w1 1 ;if w1=1 or w1=3
jl. e7. ;then endproc
sn w1 2 ;if w1=2
al w3 x3+1 ;then exp:=exp+1
al w1 -1
sz w3 1 ;if exp odd
rs. w1 (j40.) ;then sign:=-1
al w1 1
so w3 1 ;else
rs. w1 (j40.) ;sign:=+1
rl w3 x2+6
sh w3 -1
ac w3 x3
rs w3 x2+6 ;m1:=+abs cs1
rl w3 x2+8
sh w3 -1
ac w3 x3
rs w3 x2+8 ;m2:=+abs cs2
rl w3 x2+10
sl w3 1
ac w3 x3
rs w3 x2+10 ;m3:=-abs cs3
jl. e9. ;end phase of w3l
e7: dl. w1 a1. ;w3j:=w3l:=0
d4=k-c0
e8: jl. (j6.) ;end reg expr
e9: al w3 0 ;test of j and m in w3j
e10: sl w3 5 ;for w3:=0,2,4 do
jl. e11. ;if j<abs m or j<0 then param alarm
am x3
rl w0 x2 ;w0:=2*j
sh w0 -1 ;if 2*j<0
jl. w3 (j29.) ;then paramalarm
am x3
rl w1 x2+6 ;w1:=2*m
sh w1 -1
ac w1 x1 ;w1:=abs 2*m
ws w0 2 ;w0:=2*j-abs 2*m
sl w0 0 ;if 2*j<abs 2*m
sz w0 1 ;or 2*j-abs 2*m odd
jl. w3 (j29.) ;then paramalarm
al w3 x3+2
jl. e10. ;end test
e11: rl w3 x2+6 ;symmetry conditions
wa w3 x2+8
wa w3 x2+10
se w3 0 ;if 2*(m1+m2+m3)<>0
jl. e7. ;then endproc
rl w3 x2
wa w3 x2+2
wa w3 x2+4
sz w3 1 ;if 2*(j1+j2+j3) odd
jl. e7. ;then endproc
as w3 -1
sl w3 52 ;if (j1+j2+j3+1)>50
jl. w3 (j29.) ;then paramalarm
ws w3 x2+4
rs. w3 a2.
rs w3 x2+22 ;up:=(a2):=j1+j2-j3
sh w3 -1 ;if (j1+j2-j3)<0
jl. e7. ;then endproc
rl w3 x2+2
wa w3 x2+4
ws w3 x2
sh w3 -1 ;if 2*(j2+j3-j1)<0
jl. e7. ;then endproc
rl w3 x2+4
wa w3 x2
ws w3 x2+2
sh w3 -1 ;if 2*(j3+j1-j2)<0
jl. e7. ;then endproc ;end symmetry
al w3 0 ;determination of limits of the sum
rs w3 x2+20 ;low:=0
rl w3 x2+2
ws w3 x2+4
ws w3 x2+6
as w3 -1
rs w3 x2+12 ;store -j3+j2-m1
sl w3 1 ;if w3>0
rs w3 x2+20 ;then low:=-j3+j2-m1
rl w3 x2
wa w3 x2+8
ws w3 x2+4
as w3 -1
rs w3 x2+14 ;store -j3+j1+m2
sl w3 (x2+20) ;if w3>low
rs w3 x2+20 ;then low:=-j3+j1+m2
rl w3 x2
ws w3 x2+6
as w3 -1
rs w3 x2+16 ;store j1-m1
sh w3 (x2+22) ;if w3<up
rs w3 x2+22 ;then up:=j1-m1
rl w3 x2+2
wa w3 x2+8
as w3 -1
rs w3 x2+18 ;store j2+m2
sh w3 (x2+22) ;if w3<up
rs w3 x2+22 ;then up:=j2+m2
rl w3 x2+22
ws w3 x2+20
sh w3 -1 ;if (up-low)<0
jl. e7. ;then endproc ;end limits
rl. w3 (j0.) ;w3:=segment table addr(next segment)
al. w1 g1. ;w1:=segment table addr(this segment)
rs w1 x3+f0 ;save it on next segment
rs w2 x3+f1 ;save w2 on next segment
al w1 x3+f3 ;calculation of the sum: entry
rs. w1 d2. ;save it on this segment
rl. w1 a2.
rs w1 x3+f2 ;save j1+j2-j3 on next segment
;calculation of the sum
dl. w1 a1. ;w0w1:=0
ds w1 x3+f8 ;sum:=0
rl w3 x2+20 ;w3:=r:=low
d3=k-c0
rl w2 x2+22 ;w2:=up
sl w2 x3 ;for r:=low step 1 until up do
jl. (d2.) ;goto f3
sn w0 0 ;if sum=0
jl. e8. ;then endproc
rl. w2 (j0.)
rl w2 x2+f1
rl w3 x2 ;else calculate phase
ws w3 x2+2
ws w3 x2+10 ;w2:=2*(j1-j2-m3)
so w3 2 ;if phase=+1
al w2 1 ;then 1*
sz w3 2 ;else
al w2 -1 ;(-1)*
al w3 x2
rl. w2 (j0.)
jl x2+f4 ;goto f4
m.end segment 1
h. 0,r.(:504-k:) ;fill
w. <:w3j segm 1<0>:> ;alarmtxt
;segment 2:
c4: 0 ;head word: no abs words, no points
f0=k-c4, b0: 0 ;segment table addr(previous segment)
f1=k-c4, b1: 0 ;abs addr of stackbyte(6)
f2=k-c4, b2: 0 ;wrk loc
;calculation of sqrt(r), where
;r=s*2**t, 0.5<=s<1, -2048<=t<=2047:
;s1:=2.5764869 - 5.0350099/(s + 2.1938165)
;s2:=(s1 + s/s1)/2
;s3:=(s2 + s/s2)/2
;sqrt(r):=s3*2**(t//2)*(if t odd then sqrt(2) else 1)
;fixed binary fractions:
b3: 8.2143 1676 ; c/4 = 2.1938165/4
b4: 8.6573 4114 ; b/16 = -5.0350099/16
b5: 8.1116 2452 ;a/2 - 1 = 2.5764869/2 - 1
8.2650 1171
b6: 8.4640 0001 ;floating sqrt(2)
b7: 8.3777 7777 ;2**23-1 = 8388607
0
f8=k-c4, b8: 0 ;w3j: sum
0
b9: 0 ;w3j: term
f3=k-c4
dl. w1 e21. ;1
al w2 x3 ;current r is kept in w3
as w2 2 ;addr of r! rel to 0!
fd. w1 x2+e21. ;/r!
rl. w2 b2.
ws w2 6
as w2 2
fd. w1 x2+e21. ;/(j1+j2-j3-r)!
am. (b1.)
rl w2 16
ws w2 6
as w2 2
fd. w1 x2+e21. ;/(j1-m1-r)!
am. (b1.)
rl w2 18
ws w2 6
as w2 2
fd. w1 x2+e21. ;/(j2+m2-r)!
al w2 x3
am. (b1.)
ws w2 12
as w2 2
fd. w1 x2+e21. ;/(j3-j2+m1+r)!
al w2 x3
am. (b1.)
ws w2 14
as w2 2
fd. w1 x2+e21. ;/(j3-j1-m2+r)!
rl. w2 b1.
ds. w1 b9. ;(b9):=term
dl. w1 b8. ;w0w1:=sum
so w3 1 ;if r even
fa. w1 b9. ;then add
sz w3 1 ;else
fs. w1 b9. ;subtract
ds. w1 b8. ;(b8):=sum:=sum+(signed term)
al w3 x3+1 ;r:=r+1
am. (b0.)
jl d3 ;goto d3
f4=k-c4
ci w3 0
fm w1 6
ds. w1 b8. ;(b8):=final sum, w3j
am. (b0.)
rl w3 (d0)
sn w3 0 ;if -,w3l
jl. e19. ;then continue
ci w3 0 ;else adjust phase
fm w1 6
ds. w1 b8. ;(b8):=final sum, w3l
e19: rl. w3 b1. ;calculation of arg of sqrt
rl. w2 b2.
as w2 2
dl. w1 x2+e21. ;(j1+j2-j3)!
rl. w2 b2.
wa w2 x3+4
rs. w2 b2. ;(b2):=j1+j2+j3
ws w2 x3
as w2 2
fm. w1 x2+e21. ;*(-j1+j2+j3)!
rl. w2 b2.
ws w2 x3+2
as w2 2
fm. w1 x2+e21. ;*(j1-j2+j3)!
rl. w2 b2.
al w2 x2+1
as w2 2
fd. w1 x2+e21. ;/(j1+j2+j3+1)!
rl w2 x3+16
wa w2 x3+6
as w2 2
fm. w1 x2+e21. ;*(j1+m1)!
rl w2 x3+16
as w2 2
fm. w1 x2+e21. ;*(j1-m1)!
rl w2 x3+18
as w2 2
fm. w1 x2+e21. ;*(j2+m2)!
rl w2 x3+18
ws w2 x3+8
as w2 2
fm. w1 x2+e21. ;*(j2-m2)!
rl w2 x3+4
wa w2 x3+10
as w2 1
fm. w1 x2+e21. ;*(j3+m3)!
rl w2 x3+4
ws w2 x3+10
as w2 1
fm. w1 x2+e21. ;*(j3-m3)! ;w0w1:=arg of sqrt
;sqrt(w0w1):
rl w3 0 ;1. iteration: w3:=two bytes of s
as w3 -2 ;s:=s/4
rs. w3 b2. ;(b2):=s/4
wa. w3 b3. ;w3:=s/4 + c/4
rl. w2 b4. ;w2:=b/16
wd w3 6 ;w3:=b/2/(s+c)
la. w3 b7. ;remove signbit of w3
wa. w3 b5. ;s1/2:=w3:=a+b/(s+c)
rl. w2 b2. ;2. iteration: w2:=s/4
rs. w3 b2. ;(b2):=s1/2
wd w3 6 ;w3:=s/s1
as w3 -1 ;w3:=s/s1/2
wa. w3 b2. ;s2:=w3:=(s1+s/s1)/2
al w2 x3 ;3. iteration: w2:=s2
bl w3 3 ;w3:=t
as w3 -1 ;w3:=t//2
sz w1 1 ;if t odd
fm. w3 b6. ;then w2w3:=w2w3*sqrt(2)
fd w1 6 ;w0w1:=s/s2
fa w1 6 ;w0w1:=s/s2+s2
bl w2 3 ;w2:=two-exp of w0w1
al w2 x2-1 ;w2:=two-exp - 1
hl w1 5 ;w0w1:=w0w1/2:=sqrt(r)
rl. w2 b1.
am. (b0.)
rl w3 (d0)
sn w3 0 ;if -,w3l then
jl. e20. ;endproc
rl w3 x2+6
sn w3 0 ;if cs1<>0
jl. e20.
rl w3 x2+8 ;and cs2<>0
sn w3 0 ;then
jl. e20.
fd. w1 b6. ;w3l:=w3l/sqrt(2)
e20: fm. w1 b8.
am. (b0.)
jl d4 ;endproc
1024<12 ;table of factorials:
e21: 1 ;0!
8.2000 0000
8.0000 0001 ;1!
8.2000 0000
8.0000 0002 ;2!
8.3000 0000
8.0000 0003 ;3!
8.3000 0000
8.0000 0005 ;4!
8.3600 0000
8.0000 0007 ;5!
8.2640 0000
8.0000 0012 ;6!
8.2354 0000
8.0000 0015 ;7!
8.2354 0000
8.0000 0020 ;8!
8.2611 4000
8.0000 0023 ;9!
8.3353 7000
8.0000 0026 ;10!
8.2302 1240
8.0000 0032 ;11!
8.3443 1760
8.0000 0035 ;12!
8.2714 5063
8.0000 0041 ;13!
8.2423 0354
8.5000 0045 ;14!
8.2301 6735
8.6540 0051 ;15!
8.2301 6735
8.6540 0055 ;16!
8.2415 7673
8.5466 0061 ;17!
8.2657 5663
8.1235 0065 ;18!
8.3300 5344
8.6032 0071 ;19!
8.2070 3316
8.7620 0076 ;20!
8.2612 0357
8.5155 0102 ;21!
8.3635 6511
8.4126 0106 ;22!
8.2571 3414
8.6576 0113 ;23!
8.2033 0511
8.5037 0120 ;24!
8.3152 2403
8.0320 0124 ;25!
8.2466 3022
8.3651 0131 ;26!
8.2145 7037
8.4567 0136 ;27!
8.3662 2267
8.2220 0142 ;28!
8.3371 4506
8.0643 0147 ;29!
8.3211 7661
8.5611 0154 ;30!
8.3125 5264
8.1255 0161 ;31!
8.3125 5264
8.1255 0166 ;32!
8.3210 2611
8.6302 0173 ;33!
8.3360 6742
8.3216 0200 ;34!
8.3627 3457
8.5053 0205 ;35!
8.2105 1412
8.6270 0213 ;36!
8.2360 0004
8.3665 0220 ;37!
8.2735 0005
8.2447 0225 ;38!
8.3445 2606
8.3710 0232 ;39!
8.2167 2564
8.0335 0240 ;40!
8.2670 7174
8.5433 0245 ;41!
8.3602 5403
8.5223 0252 ;42!
8.2413 6346
8.3533 0260 ;43!
8.3360 1674
8.7035 0265 ;44!
8.2340 7240
8.6354 0273 ;45!
8.3403 2407
8.1223 0300 ;46!
8.2446 3361
8.2044 0306 ;47!
8.3671 5151
8.7066 0313 ;48!
8.2752 1071
8.0441 0321 ;49!
8.2236 7274
8.4542 0327 ;50!
m.end segment 2
h. 0,r.(:1016-k:)
w. <:w3j segm 2<0>:>
e. ;end slang segment
w.g0: ;tail w3j
2 ;size of area
0,0,0,0
1<23+c3-c0 ;entry point on the first segment
4<18+13<12+13<6+13 ;real proc, value m3,m2,m1
13<18+13<12+13<6 ;value j3,j2,j1; integer j1,j2,j3,m1,m2,m3
4<12+c1-c0 ;code proc, start of external list
2<12+4 ;two code segments, 4 own bytes
g1: ;tail w3l
1<23+4 ;mode=bs
0,0,0,0
1<23+c2-c0 ;entry point
4<18+13<12+13<6+13 ;real proc, value cs3,cs2,cs1
13<18+13<12+13<6 ;value l3,l2,l1; integer l1,l2,l3,cs1,cs2,cs3
4<12+c1-c0 ;code proc, start of externallist
2<12+4 ;two code segments, 4 own bytes
n. ;load insertproc
;e.e. ;end block, end fpnames\f
▶EOF◀