DataMuseum.dk

top - metrics - download

    Length: 4608 (0x1200)
    Types: TextFile
    Names: »heatrels«

└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ.  Detaljer om "HC8000" projekt.
    └─⟦0364f57e3⟧ 
        └─⟦this⟧ »heatrels« 
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
    └─⟦b2ec5d50f⟧ 
        └─⟦this⟧ »heatrels« 

TextFile

comment:
        DETTE PROGRAM UDREGNER VARMELEDNINGEN 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 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,tauf,q,q1 ;
  array e1(0:510),e(0:510),
  x3(0:511),iz(1:510),ifi(1:510),n1(1:510),n2(1:510),
  r2(1:510),nsqr(0:510) ;
  zone zo1(1152,1,stderror); 
  n:=510 ; t:=0.18666 ;
  k:=entier(40*t*1152/50)+2 ;
  nsqr(0):=0 ;
  for i:=0 step 1 until n do 
  begin
    e(i):=i*40*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 ;
    open(zo1,4,<:gs18666:>,0) ;
    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,0.1,1.0,5.0,100.0,10000 do
  begin
    array dr(0:510),f(0:510) ;
    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):=-(e1(i)*nsqr(i))/(f(i)*cosh(e1(i)/2)) ;
    end ;
    for j:=0 step 1 until n do
    begin
      x3(j):=e1(j)*nsqr(j)*dr(j)/cosh(e1(j)/2) ;
    end ;
    q1:=0.0759908877*simp(40,n,0,x3) ;
    write(out,<<dddd>,l,<<-d.dddd'-dd>,t/0.6222,<:  :>,q1,<:<10>:>) ;
    write(out,<<dddd>,<:<10><10>totale antal punkter=:>,n) ;
    write(out,<<-d.dddd'-dd>,
    <:  temperatur=:>,t/0.6222,<:  tauf=:>,tauf,
    <:<10><10>  T*TAUk=:>,-q1,<:<10><10>:>) ;
    for j:=0 step 1 until n do
    write(out,<<-d.dddd'-dd>,-x3(j)*cosh(e1(j)/2),
    if j mod 5=0 then <:<10>:> else <:   :>) ;
  end ;
end ;
end ;
end ;
end ;
▶EOF◀