|
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: »chargesc1«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦this⟧ »chargesc1«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦this⟧ »chargesc1«
comment:
DETTE PROGRAM UDREGNER LADNING REL FOR BLY ;
begin
real procedure simp(l,k,j,f) ;
value l,k,j ; integer k,j ; real l ; array f ;
begin
integer i ; real x,y,res ; res:=0 ;
x:=l/(3*k) ; y:=4*x ;
for i:=(j+1) step 2 until (j+k-1) do
begin
res:=res+y*f(i) ;
end ;
res:=res+(f(j)+f(j+k))*x ; y:=2*x ;
for i:=(j+2) step 2 until (j+k-2) do
begin
res:=res+y*f(i) ;
end ;
simp:=res ;
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,h3,theta ;
h1:=((z1**2-z2**2)*(x**2)-d1**2+d2**2) ;
h2:=2*(z1*z2*x*x-d1*d2) ;
h3:=h1**2+h2**2 ;
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)) ;
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,h3,theta ;
h1:=((z1**2-z2**2)*(x**2)-d1**2+d2**2) ;
h2:=2*(z1*z2*(x**2)-d1*d2) ;
h3:=h1**2+h2**2 ;
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)) ;
end ;
real procedure rn2(x,d1,d2,z1,z2) ;
value x,d1,d2,z1,z2 ; real x,d1,d2,z1,z2 ;
begin
real h1,h2,h3,theta ;
h1:=((z1**2-z2**2)*(x**2)-d1**2+d2**2) ;
h2:=2*(z1*z2*(x**2)-d1*d2) ;
h3:=h1**2+h2**2 ;
theta:=arg(h1,h2) ;
if theta<0 then theta:=(theta+2*pi)/2 else theta:=theta/2 ;
rn2:=-(d2*cos(theta)-d1*sin(theta))/sqrt(sqrt(h3)) ;
end ;
real procedure alf(x,y) ;
value x,y ; real x,y ;
begin
real z1,z2 ; z1:=abs(x) ; z2:=abs(y) ;
if z1<=2.15 or z1>=10 then alf:=0 else
if z1<6.65 then alf:=0.63774595*
(1/((z1-4.4)*(z1-4.4)+0.5625)-0.1777777778)/sinh(z2/2)
else
if z1<=7 then alf:=0 else
alf:=0.42516392*
(1/((z1-8.5)*(z1-8.5)+0.25)-0.4)/sinh(z2/2) ;
end ;
real procedure fer(x) ;
value x ; real x ;
begin
fer:=1/(exp(x)+1) ;
end ;
real procedure cosh(x) ;
value x ; real x ;
begin
real a ; a:=exp(x) ; cosh:=(a+1/a)/2 ;
end ;
integer i,j,k,n,l ; real t,gr,tauf,q,q1,dt ;
array e1(0:510),e(0:510),
x1(0:511),iz(1:510),ifi(1:510),n1(1:510),n2(1:510),
r2(1:510),nsqr(0:510) ;
zone zo(512,1,stderror),zo1(1152,1,stderror);
read(in,t,gr);
n:=510 ; dt:=13.4/t ;
k:=entier(gr*t*1152/50)+2 ;
nsqr(0):=0 ;
for i:=0 step 1 until n do
begin
e(i):=i*gr*t/n ; e1(i):=e(i)/t ;
end ;
begin
array rz(1:n),rfi(1:n),e2(1:k),m(1:k),y(1:k),a(0:4) ;
a(0):=3 ; e2(1):=0.01 ;
for i:=2 step 1 until k do e2(i):=(i-1)*50/1152 ;
begin
integer ti;
integer array ia(1:20);
zone z(10,1,stderror);
ti:= t*'5;
if ti mod 10=0 then ti:= ti//10;
open(z,0,<:zzzzz:>,0);
write(z,<<d>,<:gs:>,ti,false,10);
getzone6(z,ia);
ia(12):= 1; ia(14):= ia(19); ia(16):= 40;
setzone6(z,ia);
open(zo1,4,z,0)
end;
inrec(zo1,1152) ;
for i:=1 step 1 until k do y(i):=zo1(i) ;
spln3(a,e2,y,m,k) ;
for i:=1 step 1 until n do rfi(i):=spln3val(e(i),e2,y,m,k) ;
inrec(zo1,1152) ;
inrec(zo1,1152) ;
for i:=1 step 1 until k do y(i):=zo1(i) ;
spln3(a,e2,y,m,k) ;
for i:=1 step 1 until n do ifi(i):=spln3val(e(i),e2,y,m,k) ;
inrec(zo1,1152) ;
inrec(zo1,1152) ;
for i:=1 step 1 until k do y(i):=zo1(i) ;
spln3(a,e2,y,m,k) ;
for i:=1 step 1 until n do rz(i):=spln3val(e(i),e2,y,m,k) ;
inrec(zo1,1152) ;
inrec(zo1,1152) ;
for i:=1 step 1 until k do y(i):=zo1(i) ;
spln3(a,e2,y,m,k) ;
for i:=1 step 1 until n do iz(i):=spln3val(e(i),e2,y,m,k) ;
close(zo1,true) ;
for i:=1 step 1 until n do
begin
n1(i):=rez(e(i),rfi(i),ifi(i),rz(i),iz(i)) ;
n2(i):=rn2(e(i),rfi(i),ifi(i),rz(i),iz(i)) ;
r2(i):=red(e(i),rfi(i),ifi(i),rz(i),iz(i)) ;
nsqr(i):=n1(i)*n1(i)-r2(i)*r2(i) ;
end ;
end ;
for tauf:=0 do
begin
array dr(0:510),f(0:510) ;
q:=0 ;
f(0):=dr(0):=0 ;
for i:=1 step 1 until n do
begin
f(i):=n1(i)*iz(i)*e1(i)-r2(i)*(ifi(i)/t)+nsqr(i)*tauf*0.0331726/t ;
dr(i):=-nsqr(i)*(fer(e1(i)-dt)-fer(e1(i)+dt))*cosh(e1(i)/2)/
(f(i)*dt) ;
end ;
open(zo,4,<:min99:>,0) ;
for i:=0 step 1 until n do
begin
outrec(zo,512) ;
if i=0 then
begin
cleararray(zo) ; goto nexte ;
end ;
for j:=1 step 2 until (n-1) do
begin
zo(j+1):=-2*e1(1)*pi*nsqr(i)*nsqr(j)*(1+n2(i)*n2(j)/(n1(i)*n1(j)))*
(alf(e(j)-e(i),e1(j)-e1(i))+alf(e(j)+e(i),e1(j)+e1(i)))/(3*f(i)) ;
end ;
for j:=2 step 2 until (n-2) do
begin
zo(j+1):=-e1(1)*pi*nsqr(i)*nsqr(j)*(1+n2(i)*n2(j)/(n1(i)*n1(j)))*
(alf(e(j)-e(i),e1(j)-e1(i))+alf(e(j)+e(i),e1(j)+e1(i)))/(3*f(i)) ;
end ;
zo(1):=0 ;
zo(n+1):=-e1(1)*pi*nsqr(i)*nsqr(n)*(1+n2(i)*n2(n)/(n1(i)*n1(n)))*
(alf(e(n)-e(i),e1(n)-e1(i))+alf(e(n)+e(i),e1(n)+e1(i)))/(6*f(i)) ;
nexte:zo(i+1):=1+zo(i+1) ; zo(512):=0 ;
dr(i):=dr(i)/zo(i+1) ;
for j:=1 step 1 until (n+1) do
begin
zo(j):=zo(j)/zo(i+1) ;
end ;
zo(i+1):=0 ;
end ;
cleararray(x1) ;
write(out,<:<12>:>) ;
for i:=1 step 1 until 100 do
begin
array x2(0:511),x3(0:511) ;
l:=i ;
setposition(zo,0,0) ;
for j:=0 step 1 until n do
begin
inrec(zo,512) ;
x2(j):=dr(j)-prik(512,zo,x1) ;
x3(j):=nsqr(j)*x2(j)/cosh(e1(j)/2) ;
x1(j):=x2(j) ;
end ;
q1:=simp(gr,n,0,x3)/(2*t) ;
write(out,<<dddd>,l,<<-d.dddd'-dd>,t/0.6222,<: :>,q1,<:<10>:>) ;
if abs(abs(q/q1)-1)<0.0001 then goto slut ;
q:=q1 ;
end ;
slut:close(zo,true) ;
write(out,<<dddd>,<:<10><10>totale antal punkter=:>,n) ;
write(out,<<-d.dddd'-dd>,
<: temperatur=:>,t/0.6222,<: tauf=:>,tauf,
<:<10><10> TAUK*=:>,-q1,<: RATIO=:>,19.19114/(-q1),
<: antal itterationer=:>,l,<:<10><10>:>,<: int gr=:>,gr,<:<10><10>:>) ;
for j:=0 step 1 until n do
write(out,<<-d.dddd'-dd>,-x1(j),
if j mod 5=0 then <:<10>:> else <: :>) ;
end ;
end ;
end ;
end ;
end ;
▶EOF◀