|
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: 6912 (0x1b00)
Types: TextFile
Names: »elis2«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦this⟧ »elis2«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »elis2«
begin
real array field raf;
real procedure h1(z) ;
value z ; real z ;
begin
if z=-2.15 then h1:=0.8496786712 else
if z=-6.65 then h1:=-0.8496786712 else
h1:=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) ;
end ;
real procedure h2(z) ;
value z ; real z ;
begin
if z=-7 then h2:=1.274518007 else
if z=-10 then h2:=-1.274518007 else
h2:=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) ;
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,co,m ; real t,a,hj,d1hj,d2hj,a1,a2,a3,a4,res,hres ;
array int(-1152:2304),d1(0:1152),d2(0:1152),z1(0:1152),z2(0:1152)
,hj1(0:2304),ada(0:1152),rezm(0:1152),redm(0:1152),alf(49:235),kff(0:6) ;
zone zo(1152,1,stderror) ;
t:=0.3733 ; a:=50/1152 ; co:=1152 ;
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 co do ada(j):=adapint(50,70,h1(a*j+hj)-h1(hj-a*j)
+h2(a*j+hj)-h2(hj-a*j),
hj,1.0'-3)+adapint(70,90,h1(a*j+hj)+h2(a*j+hj)-h1(hj-a*j)-h2(hj-a*j),hj,1.0'-3) ;
for j:=49 step 1 until 235 do alf(j):=alfa(j*a) ;
raf:= -4;
for i:=-co step 1 until 2304 do
int(i):=h1(i*a)+h2(i*a) ;
for j:=0 step 1 until 2304 do hj1(j):=exp(j*a/t)+1 ;
if k=1 then
begin
open(zo,4,<:gs4265:>,0) ;
inrec(zo,co) ;
for j:=1 step 1 until co do d1(j):=1.15*zo(j) ;
inrec(zo,co) ;
for j:=1 step 1 until co do d2(j):=zo(j) ;
inrec(zo,co) ;
for j:=1 step 1 until co do z1(j):=zo(j) ;
inrec(zo,co) ;
for j:=1 step 1 until co do z2(j):=zo(j) ;
close(zo,true) ;
d1(0):=d1(1) ; z1(0):=z1(1) ; d2(0):=d2(1) ; z2(0):=z2(1) ;
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 ;
for i:=1 step 1 until 1 do
begin
for j:=0 step 1 until co do
begin
if j=0 then a1:=1.0'-3 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 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
l1:=k+m+j ; l2:=k+m-j ;a2:=int(l1)+int(l2) ; a4:=hj1(k+m) ;
if l1>co then a3:=int(-co) else a3:=int(-l1) ;
res:=res+kff(m)*(a2-0.11*((a4-2)/(a4))-
(int(-l2)+a3+a2)/(a4))*redm(k+m) ;
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
l1:=j+k+m ; l2:=k+m-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+kff(m)*((a1+a3)/(hj1(k+m)-2)+a1/(hj1(l1))+a3/(a2))*alf(k+m) ;
end ;
d2(j):=pi*res ;
end ;
res:=0 ;
for k:=0 step 6 until co-6 do
for m:=1 step 1 until 6 do
begin
a1:=(k+m)*a+1.0'-3 ; a2:=(k+m)*a-1.0'-3 ;
res:=res+kff(m)*(h1(a1)+h2(a1)-h1(a2)-h2(a2)-
(h1(-a1)+h2(-a1)-h1(-a2)-h2(-a2)+h1(a1)+h2(a1)-
h1(a2)-h2(a2))/hj1(k+m))*rezm(k+m) ;
end ;
a4:=1.0'-3 ;
hres:=kff(0)*(h1(a4)+h2(a4)-h1(-a4)-h2(-a4))*rezm(0) ;
z1(0):=1-1.0'3*(res+hres) ;
for j:=0 step 1 until co do
begin
if j=0 then goto nexte ;
res:=0 ;
for k:=0 step 6 until co-6 do
for m:=1 step 1 until 6 do
begin
l1:=k+m+j ; l2:=k+m-j ; a3:=int(l1)-int(l2) ;
if l1>co then a4:=int(-co) else a4:=int(-l1) ;
res:=res+kff(m)*(a3-
(a4-int(-l2)+a3)/(hj1(k+m)))*rezm(k+m) ;
end ;
hres:=kff(0)*((int(j)-int(-j))*rezm(0)-
(int(co+j)-int(co-j))*rezm(co)) ;
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
l1:=k+m+j ; l2:=k+m-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+kff(m)*((
rezm(abs(l2))+a2)/(hj1(k+m)-2)
+rezm(abs(l2))/(a1)+a2/(hj1(l1)))*alf(k+m) ;
end ;
if j=0 then z2(0):=1.0'3*pi*res else
z2(j):=(pi/(j*a))*res ;
end ;
for j:=0 step 1 until co do
begin
if j<250 or j>1145 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 ;
end ;
begin
open(zo,4,<:elisdata:>,0) ;
outrec(zo,co) ;
for i:=1 step 1 until co do zo(i):=d1(i) ;
outrec(zo,co) ;
for i:=1 step 1 until co do zo(i):=d2(i) ;
outrec(zo,co) ;
for i:=1 step 1 until co do zo(i):=z1(i) ;
outrec(zo,co) ;
for i:=1 step 1 until co do zo(i):=z2(i) ;
close(zo,true) ;
end ;
end ;
end ;
end ;
▶EOF◀