|
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: 6144 (0x1800)
Types: TextFile
Names: »elis1«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦this⟧ »elis1«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »elis1«
begin
real array field raf;
real procedure simp1(f) ;
array f ;
begin
integer i2 ; real res ;
res:=0 ;
for i2:=0 step 6 until 1146 do
begin
res:=res+216*(f(i2+1)+f(i2+5))+27*(f(i2+2)+f(i2+4))+
272*f(i2+3)+82*f(i2+6) ;
end ;
simp1:=(50/(1152*140))*(res+41*(f(0)-f(1152))) ;
end ;
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 ; real t,a,hj,d1hj,d2hj,a1,a2,a3,a4 ;
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:231),
help(0:1152),help1(0:1152) ;
zone zo(1152,1,stderror) ;
t:=0.5759 ; a:=50/1152 ; co:=1152 ;
k:=1 ;
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 231 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 ;
help(0):=0 ;
tofrom(help,help.raf,4*co) ;
if k=1 then
begin
open(zo,4,<:gs5800:>,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
for k:=0 step 1 until co do
begin
l1:=k+j ; l2:=k-j ;a2:=int(l1)+int(l2) ; a4:=hj1(k) ;
if l1>co then a3:=int(-co) else a3:=int(-l1) ;
z2(k):=(a2-0.11*((a4-2)/(a4))-
(int(-l2)+a3+a2)/(a4))*redm(k) ;
end ;
d1(j):=simp1(z2) ;
for k:=49 step 1 until 231 do
begin
l1:=j+k ; l2:=k-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) ;
help(k):=((a1+a3)/(hj1(k)-2)+a1/(hj1(l1))+a3/(a2))*alf(k) ;
end ;
d2(j):=pi*simp1(help) ;
end ;
for k:=0 step 1 until co do
begin
a1:=k*a+1.0'-3 ; a2:=k*a-1.0'-3 ;
help1(k):=(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))*rezm(k) ;
end ;
z1(0):=1-1.0'3*simp1(help1) ;
for j:=0 step 1 until co do
begin
if j=0 then goto nexte ;
for k:=0 step 1 until co do
begin
l1:=k+j ; l2:=k-j ; a3:=int(l1)-int(l2) ;
if l1>co then a4:=int(-co) else a4:=int(-l1) ;
help1(k):=(a3-
(a4-int(-l2)+a3)/(hj1(k)))*rezm(k) ;
end ;
z1(j):=1-((simp1(help1)+ada(j))/(j*a)) ;
nexte:for k:=49 step 1 until 231 do
begin
l1:=k+j ; l2:=k-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) ;
help(k):=((
rezm(abs(l2))+a2)/(hj1(k)-2)
+rezm(abs(l2))/(a1)+a2/(hj1(l1)))*alf(k) ;
end ;
if j=0 then z2(0):=1.0'3*pi*simp1(help) else
z2(j):=(pi/(j*a))*simp1(help) ;
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◀