|
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: 7680 (0x1e00)
Types: TextFile
Names: »elis4«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦this⟧ »elis4«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »elis4«
begin
real array field raf;
real procedure h1(z) ;
value z ; real z ;
begin
real b1,b2 ;
if z=-2.15 then b1:=0.8496786712 else
if z=-6.65 then b1:=-0.8496786712 else
b1:=0.6377458471*(1/(0.5625+(4.4+z)**2)-0.177777778)*
ln(abs((6.65+z)/(2.15+z)))+
2.124196678*(4.4+z)/(0.5625+(4.4+z)**2) ;
if z=-7 then b2:=1.274518007 else
if z=-10 then b2:=-1.274518007 else
b2:=0.4251639*(1/(0.25+(8.5+z)**2)-0.4)*ln(abs((10+z)/(7+z)))+
2.124196678*(8.5+z)/(0.25+(8.5+z)**2) ;
h1:=b1+b2 ;
end ;
real procedure rez(x,d1,d2,z1,z2) ;
value x,d1,d2,z1,z2 ; real x,d1,d2,z1,z2 ;
begin
real h1,h2,theta,h3 ;
h1:=((z1*z1-z2*z2)*x*x-d1**2+d2**2) ;
h2:=2*(z1*z2*x*x-d1*d2) ;
h3:=h1*h1+h2*h2 ;
theta:=arg(h1,h2) ;
if theta<0 then theta:=(theta+2*pi)/2 else theta:=theta/2 ;
rez:=x*(z1*cos(theta)+z2*sin(theta))/sqrt(sqrt(h3)) ;
slut1:
end ;
real procedure red(x,d1,d2,z1,z2) ;
value x,d1,d2,z1,z2 ; real x,d1,d2,z1,z2 ;
begin
real h1,h2,theta,h3 ;
h1:=((z1*z1-z2*z2)*x*x-d1**2+d2**2) ;
h2:=2*(z1*z2*x*x-d1*d2) ;
h3:=h1*h1+h2*h2 ;
theta:=arg(h1,h2) ;
if theta<0 then theta:=(theta+2*pi)/2 else theta:=theta/2 ;
red:=(d1*cos(theta)+d2*sin(theta))/(sqrt(sqrt(h3))) ;
slut2:
end ;
real procedure alfa(x) ;
value x ; real x ;
begin
real z ; z:=abs(x) ;
if z<=2.15 or z>=10 then alfa:=0
else
if z<6.65 then alfa:=sign(x)*0.63774595*
(1/((z-4.4)*(z-4.4)+0.5625)-0.177777778)
else
if z<=7 then alfa:=0
else
alfa:=sign(x)*0.42516392*
(1/((z-8.5)*(z-8.5)+0.25)-0.4) ;
end ;
integer i,j,k,l1,l2,l3,co,m ; real t,a,hj,d1hj,d2hj,a1,a2,a3,a4,res,hres ;
array int(-2304:4608),d1(0:2304),d2(0:2304),z1(0:2304),z2(0:2304)
,hj1(0:4608),ada(0:2304),rezm(0:2304),redm(0:2304),alf(49:235),kff(0:6)
,help(0:2304) ;
zone zo(1152,1,stderror) ;
t:=0.37332 ; a:=100/2304 ; co:=2304 ;
k:=1 ;
kff(0):=(41/140)*a ; kff(1):=(216/140)*a ; kff(2):=(27/140)*a ;
kff(3):=(272/140)*a ; kff(4):=kff(2) ; kff(5):=kff(1) ;
kff(6):=2*kff(0) ;
ada(0):=0 ;
for j:=1 step 1 until 1152 do ada(j):=adapint(50,70,h1(a*j+hj)-h1(hj-a*j)
,hj,1.0'-3)+adapint(70,90,h1(a*j+hj)-h1(hj-a*j),hj,1.0'-3)
+adapint(90,110,h1(a*j+hj)-h1(hj-a*j),hj,1.0'-3) ;
for j:=49 step 6 until 229 do
for m:=1 step 1 until 6 do
begin
alf(j+m):=kff(m)*alfa((j+m)*a) ;
end ;
raf:= -4;
for i:=-co step 1 until 4608 do
int(i):=h1(i*a) ;
for j:=0 step 1 until 4608 do
begin
if j<2304 then hj1(j):=exp(j*a/t)+1
else
hj1(j):=1.0'100 ;
end ;
if k=1 then
begin
open(zo,4,<:gs3733:>,0) ;
inrec(zo,1152) ;
for j:=1 step 1 until 1152 do d1(j-1):=zo(j) ;
inrec(zo,1152) ;
for j:=1 step 1 until 1152 do d1(j+1151):=zo(j) ;
d1(2304):=d1(2303) ;
inrec(zo,1152) ;
for j:=1 step 1 until 1152 do d2(j-1):=zo(j) ;
inrec(zo,1152) ;
for j:=1 step 1 until 1152 do d2(j+1151):=zo(j) ;
d2(2304):=d2(2303) ;
inrec(zo,1152) ;
for j:=1 step 1 until 1152 do z1(j-1):=zo(j) ;
inrec(zo,1152) ;
for j:=1 step 1 until 1152 do z1(j+1151):=zo(j) ;
z1(2304):=z1(2303) ;
inrec(zo,1152) ;
for j:=1 step 1 until 1152 do z2(j-1):=zo(j) ;
inrec(zo,1152) ;
for j:=1 step 1 until 1152 do z2(j+1151):=zo(j) ;
z2(2304):=z2(2303) ;
close(zo,true) ;
end
else
begin
d1(0):= d2(0):= z2(0):= 0;
tofrom(d2,d2.raf,4*co);
tofrom(z2,z2.raf,4*co);
for i:=0 step 1 until co do
begin
if i<300 then
begin
d1(i):=2.68 ; z1(i):=2 ;
end
else
z1(i):=1 ; d1(i):=0 ;
end ;
end ;
a1:=(d1(30)*z1(30)+d2(30)*z2(30))/(z1(30)**2+z2(30)**2) ;
a2:=1.25/a1 ;
for i:=0 step 1 until co do
begin
d1(i):=a2*d1(i) ; d2(i):=a2*d2(i) ;
end ;
for i:=1 step 1 until 6 do
begin
for j:=0 step 1 until co do
begin
if j=0 then a1:=1.0'-2 else a1:=a*j ;
rezm(j):=rez(a1,d1(j),d2(j),z1(j),z2(j)) ;
redm(j):=red(a1,d1(j),d2(j),z1(j),z2(j)) ;
end ;
for k:=0 step 6 until co-6 do
for m:=1 step 1 until 6 do
begin
help(k+m):=kff(m)*redm(k+m) ;
end ;
for j:=0 step 1 until co do
begin
res:=0 ;
for k:=0 step 6 until co-6 do
for m:=1 step 1 until 6 do
begin
l3:=k+m ;
l1:=l3+j ; l2:=l3-j ;a2:=int(l1)+int(l2) ; a4:=hj1(l3) ;
if l1>co then a3:=int(-co) else a3:=int(-l1) ;
res:=res+(a2-
(0.11*(a4-2)+int(-l2)+a3+a2)/(a4))*help(l3) ;
end ;
d1(j):=res-kff(0)*(int(co+j)+int(co-j)-0.11)*redm(co) ;
res:=0 ;
for k:=49 step 6 until 229 do
for m:=1 step 1 until 6 do
begin
l3:=k+m ;
l1:=j+l3 ; l2:=l3-j ;
if l1>co then a1:=redm(co) else a1:=redm(l1) ;
if l2>=0 then
a2:=hj1(l2) else a2:=(1/(hj1(-l2)-1))+1 ;
if -l2<0 then a3:=-redm(l2) else a3:=redm(-l2) ;
res:=res+((a1+a3)/(hj1(l3)-2)+a1/(hj1(l1))+a3/(a2))*alf(l3) ;
end ;
d2(j):=pi*res ;
end ;
for k:=0 step 6 until co-6 do
for m:=1 step 1 until 6 do
begin
help(k+m):=kff(m)*rezm(k+m) ;
end ;
res:=0 ;
for k:=0 step 6 until co-6 do
for m:=1 step 1 until 6 do
begin
l3:=k+m ;
a1:=l3*a+1.0'-2 ; a2:=l3*a-1.0'-2 ;
res:=res+(h1(a1)-h1(a2)-
(h1(-a1)-h1(-a2)+h1(a1)-
h1(a2))/hj1(l3))*help(l3) ;
end ;
a4:=1.0'-2 ;
hres:=kff(0)*(h1(a4)-h1(-a4))*rezm(0) ;
z1(0):=1-1.0'2*(res+hres) ;
for j:=0 step 1 until co do
begin
if j=0 then goto nexte ;
if j>=1153 then
begin
z1(j):=1 ; goto nexte ;
end ;
res:=0 ;
for k:=0 step 6 until 1146 do
for m:=1 step 1 until 6 do
begin
l3:=k+m ;
l1:=l3+j ; l2:=l3-j ; a3:=int(l1)-int(l2) ;
if l1>co then a4:=int(-co) else a4:=int(-l1) ;
res:=res+(a3-
(a4-int(-l2)+a3)/(hj1(l3)))*help(l3) ;
end ;
hres:=kff(0)*((int(j)-int(-j))*rezm(0)-
(int(1152+j)-int(1152-j))*rezm(1152)) ;
z1(j):=1-((res+hres+ada(j))/(j*a)) ;
nexte:res:=0 ;
for k:=49 step 6 until 229 do
for m:=1 step 1 until 6 do
begin
l3:=k+m ;
l1:=l3+j ; l2:=l3-j ;
if l2>=0 then a1:=hj1(l2) else a1:=(1/(hj1(-l2)-1))+1 ;
if l1>co then a2:=rezm(co) else a2:=rezm(l1) ;
res:=res+((
rezm(abs(l2))+a2)/(hj1(l3)-2)
+rezm(abs(l2))/(a1)+a2/(hj1(l1)))*alf(l3) ;
end ;
if j=0 then z2(0):=1.0'2*pi*res else
z2(j):=(pi/(j*a))*res ;
end ;
write(out,<:<10>:>,z1(0),z2(0),d1(0),d2(0),<:<10>:>) ;
for j:=0 step 1 until co do
begin
if j<250 or j>2295 then
begin
hj:=z1(j)**2+z2(j)**2 ;
write(out,<:<10>:>,a*j,z1(j),z2(j),
(d1(j)*z1(j)+d2(j)*z2(j))/hj,
(d2(j)*z1(j)-d1(j)*z2(j))/hj) ;
end ;
end ;
a1:=(d1(30)*z1(30)+d2(30)*z2(30))/(z1(30)**2+z2(30)**2) ;
if a1<=1.37 then goto slut ;
end ;
slut:
begin
open(zo,4,<:gs3733:>,0) ;
outrec(zo,1152) ;
for i:=1 step 1 until 1152 do zo(i):=d1(i-1) ;
outrec(zo,1152) ;
for i:=1 step 1 until 1152 do zo(i):=d1(i+1151) ;
outrec(zo,1152) ;
for i:=1 step 1 until 1152 do zo(i):=d2(i-1) ;
outrec(zo,1152) ;
for i:=1 step 1 until 1152 do zo(i):=d2(i+1151) ;
outrec(zo,1152) ;
for i:=1 step 1 until 1152 do zo(i):=z1(i-1) ;
outrec(zo,1152) ;
for i:=1 step 1 until 1152 do zo(i):=z1(i+1151) ;
outrec(zo,1152) ;
for i:=1 step 1 until 1152 do zo(i):=z2(i-1) ;
outrec(zo,1152) ;
for i:=1 step 1 until 1152 do zo(i):=z2(i+1151) ;
close(zo,true) ;
end ;
end ;
end ;
end ;
▶EOF◀