|
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: 27648 (0x6c00)
Types: TextFile
Names: »algrotfrekv«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦7e928b248⟧ »algbib«
└─⟦this⟧
;gosav
lookup rotfrekvens
if ok.no
(rotfrekvens=set 85
permanent rotfrekvens.17
rotfrekvens=algol index.no list.no xref.no)
\f
CALCULATION OF MICROWAVE FREQUENCIES,
RELATIVE INTENSITIES (or STARK-COEFFICIENTS)
AND QUADRUPOLE SPLITTINGS. 1-2-1980, GOS.
begin
comment Quadrupole splittings can be calculated only for a
single nucleus with I=1. As input is given:
1) A heading in one line with delimiters < >.
The line will appear on top of every output
page and must not exceed 72 characters.
2) An integer m with up to four digits for options
according to the following rules:
m=1000 causes a centrifugal distortion correction
of the frequencies to be made.
m= 100 results in a calculation of Stark coefficients.
Is m<>100 relative intensities are calculated.
m= 10 causes - provided m<>100 - that quadrupole
splittings are calculated.
m= 1 or 2 causes at the end a sorting of the
lines according to increasing frequency.
If m=2 the sorted frequency list is transformed
into an input list for precalcultion by ROTFIT.
The list is stored on disc (key 15) with the
name <:savelist:>.
m= 3 or 4 have the same effects as 1 or 2, but
output of unsorted transitions is suppressed.
A combination of these options may be obtained
by an appropriate sum of the integers.
3) The maximal computation time in minutes.
If time<0 then the temperature can be specified.
4) Three rotational constants (MHz.) in arbitrary order.
5) If m=1000 : Six centrifugal distortion constants (kHz).
6) Smallest J-value for the calculations.
7) Largest J-value for calculation of Q-lines (< 80).
8) Largest J-value for calculation of P- or R-lines.
9) The frequency limits, two numbers in arbitrary order.
10) The smallest rel. intensity (or Stark coef.*J**2)
of lines included in the output.
11) An integer between 1 and Jmax giving the maximal
change, dKmax, of K-quantum numbers referring
to the nearest symmetric top limit.
12) The three dipole moment components along the prin-
cipal axes in the order a,b,c.
13) If m=10 : Quadrupole coupling constants of the axes
in the order aa, bb, cc (MHz).
14) If m<>100 : With only a single nonvanishing dipole
moment component the molecule is regarded to
possess a symmetry axis. Two numbers are then
reqired for the statistical weights of symmetric
and antisymmetric levels respectively;
integer i,j,k,l,m,n,p,q,J,Jmin,space,side,overgange;
real temp, starttime, stoptime, time, cpu, Qr, Qrj, Qra;
zone L(128*2, 2, stderror), res(128,1,stderror);
integer array Ltail, Wtail(1:10);
boolean ha,hb,centrifugal,quadrupol,intensitet,sorter,
savesort,output,closeres,nl;
array hoved(1:12);
procedure nylinie;
begin
l:= l+1; write(res,<:<10>:>);
if l>58 then begin
integer i;
side:= side+1; i:= 1; write(res,<:<12>:>,nl, 3,
string hoved(increase(i)), false add 32, space,
<<dd>,side, nl,2); l:= 3
end end nylinie;
procedure overskrift;
begin
write(res,<:
transition frequency :>);
if intensitet then write(res,<:inten-:>)
else write(res,<:Stark-coefficients:>);
if quadrupol then write(res,<: 3 strongest eqQ-comp.:>);
write(res,<:
:>);
if intensitet then write(res,<:sity :>)
else write(res,<: A B:>);
if quadrupol then write(res,<: F=J-1 F=J F=J+1:>);
write(res,<:
------------------------------------:>);
if intensitet then write(res,<:------:>)
else write(res,<:-----------------------:>);
if quadrupol then write(res,<:--------------------------:>);
l:= l+3
end overskrift;
for i:=1 step 1 until 10 do Wtail(i):= Ltail(i):= 0;
closeres:= outmedium(res);
comment Her begynder selve programmet. Det første der sker,
er indlæsningen og ordning af inputparametrene;
space:= 39 - readhead(in,hoved,1); read(in,m);
centrifugal:= m//1000=1; m:= m mod 1000;
intensitet:= m//100<>1; m:= m mod 100;
quadrupol:= m//10=1; m:= if intensitet then m mod 10 else 0;
sorter:= m>0; output:= m<3; savesort:= m=2 or m=4;
k:= if centrifugal then 6 else 1; nl:= false add 10;
begin
real Fmin, Fmax, Lmin, Lscale, spor, A, C;
integer JJ, JQmax, JPRmax, dKmax, symx;
boolean Jlige, oblat, Qlinier, PRlinier;
array Rot, ki, my(1:3), D(1:k), vægt(1:2);
integer array KATALOG(1:3,1:8), MATRIX, TAU(1:8);
procedure P(x,y); real x,y;
begin real u, v; boolean b;
b:=x<y; u:=if b then y else x; v:=if b then x else y;
x:=u; y:=v
end P;
cpu:= systime(1,0,starttime);
read(in,stoptime);
if stoptime<0 then read(in,temp) else temp:= 300;
stoptime:= abs stoptime;
read(in,Rot); if centrifugal then read(in,D);
read(in,Jmin, JQmax, JPRmax, Fmin, Fmax, Lmin, dKmax, my);
Qra:= 1; for i:= 1,2,3 do Qra:= Qra*Rot(i);
Qra:= sqrt(pi/Qra*(temp*20836.48)**3);
stoptime:= stoptime*60;
if quadrupol then read(in,ki);
quadrupol:= quadrupol and intensitet;
if JQmax>80 then JQmax:= 80; if JPRmax>80 then JPRmax:= 80;
P(Rot(1),Rot(2)); P(Rot(1),Rot(3)); P(Rot(2),Rot(3));
P(Fmax,Fmin);
Qlinier:= JQmax>=Jmin and JQmax>0;
PRlinier:= JPRmax>0 and Jmin=0;
comment Indlæsning og ordning af inputparametrene er nu
delvis tilendebragt. De størrelser, som programmet
herefter regner med, trykkes;
if -, intensitet then space:= space+18;
if quadrupol then space:= space+27;
if space < 6 then space:= 6; side:= 0; l:= 70; nylinie;
write(res,<:Calculation with FREQUENCY PROGRAM of 11-5-1977.
Rotational Constants in MHz::>);
write(res,<<-ddd ddd.ddd>,Rot(1),Rot(2),Rot(3));
if centrifugal then begin
procedure output(a); value a; real a;
begin k:= entier abs a;
spor:= real(if k< 10 then <<-d.ddddd0> else
if k<1000 then <<-ddd.ddd0> else <<-ddddd.d0>);
write(res,<: = :>, string spor , a ,<: :>) end;
write(res,<:
Centrifugal Distortion Constants in kHz::>);
for i:=1 step 1 until 3 do begin write(res,<:
tau-:>, case i of (<:aaaa:>,<:bbbb:>,<:cccc:>));
output(D(i));
write(res, case i of (<:tau-aabb + 2*tau-abab:>,
<:tau-bbcc + 2*tau-bcbc:>,<:tau-ccaa + 2*tau-caca:>));
output(D(i+3))
end; l:= l+4 end;
write(res,<:
Limits for J : Jmin = :>,<<dd>,Jmin,
<: JQmax = :>,JQmax,<: JPRmax = :>,JPRmax,<:
Limits for F : Fmin =:>,<<-ddd ddd>,
Fmin,<: Fmax =:>, Fmax);
if intensitet then begin
write(res,<:
Dipol Components ::>); j:= 0;
for i:=1,2,3 do begin
write(res, case i of (<: myA =:>,<: myB =:>,<: myC =:>),
<<ddd.dd>,my(i));
if my(i)<>0 then begin j:= j+1; symx:= i+1 end
end;
if j=1 then begin read(in,vægt);
if vægt(1)<>vægt(2) then begin write(res,<:
Statistical Weights: Sym. level: :>,<<ddd>,vægt(1),
<:, Antisym. level: :>,vægt(2));
spor:= vægt(1)+vægt(2);
vægt(1):= vægt(1)/spor; vægt(2):= 1-vægt(1);
l:= l+1
end end else vægt(1):=vægt(2):=1;
write(res,<:
Smallest Rel. Intensity (T=:>,
if temp<10 then <<d.d> else <<ddd>,temp,<: K)::>,<<dddd>,Lmin);
end else begin
write(res,<:
Transition Types: :>);
if my(1)>0 then write(res,<:myA:>);
if my(2)>0 then begin
if my(1)>0 then write(res,<:,:>);
write(res,<:myB:>) end;
if my(3)>0 then begin
if my(1)>0 or my(2)>0 then write(res,<:,:>);
write(res,<:myC:>) end;
write(res,<:
Smallest Stark-coefficient*J*J ::>,<<_d'-dd>,Lmin);
end;
write(res,<: Largest delta-K : :>,<<dd>,dKmax);
if quadrupol then begin
write(res,<:
Quadrupol Couplings Constants in MHz::>,
<<-ddd.ddd>,ki(1),ki(2),ki(3));
l:= l+1 end;
A:= C:= 0;
for i:=1,2,3 do begin
A:= A+Rot(i); my(i):= my(i)**2; if my(i)>C then C:= my(i)
end;
Lscale:= exp(-6+A*4.7993'-5/temp)*temp/C;
nylinie; nylinie; overskrift;
l:= l+6; comment l er en linietæller.
Nu opbygges et katalog over de tilladte overgange.
Dette bygger paa følgende:
Tromlen er delt i to afsnit svarende til J lige og J ulige.
Paa hvert afsnit lagres reducerede energiniveauer samt matrix-
elementer for de fire muligheder ee, eo, oe og oo i den nævnte
rækkefølge.
I ferritlageret oprettes et array (MATRIX) med 8 elementer,
som for de 8 mulige tilfælde (type 1 til 4 for J lige og type 5
til 8 for J ulige) angiver matrixtypen E+, E-, O+ og O- numme-
reret 1 til 4 i den nævnte rækkefølge. Indholdet af MATRIX
bliver derfor:
for kappa>0: 1 4 2 3 2 3 1 4 (IIIr representation)
for kappa<0: 1 2 3 4 2 1 4 3 ( Ir - - )
Kataloget over de tilladte overgange har 3 rækker og 8 søjler
og indeholder information om udvalgsreglerne svarende til de 3
dipolretninger myA, myB og myC. Disse udvalgsregler kan opstil-
les ifølgende skema:
myA ee=>eo oe=>oo eo=>ee oo=>oe
myB ee=>oo oe=>eo oo=>ee eo=>oe
myC ee=>oe eo=>oo oe=>ee oo=>eo
De 8 søjler i kataloget parres sammen to og to, og informationen
om de tilladte overgange gives da i form af heltal, idet ee=1,
eo=2, oe=3 og oo=4. Katalogmatricen bliver da:
1 2 3 4 2 1 4 3
1 4 3 2 4 1 2 3
1 3 2 4 3 1 4 2
Disse tal kan bruges til valg af de til overgangene svarende
tromlesegmenter;
oblat:= Rot(2)*2>(Rot(1)+Rot(3));
if centrifugal then begin
integer x,y,z; real a,b,c; array T(1:6);
if oblat then begin
x:= 1; y:= 2; z:= 3;
for i:=1 step 1 until 6 do T(i):= D(i) end
else begin
x:= 2; y:= 3; z:= 1;
for i:=1,2 do begin T(i):= D(i+1); T(i+3):= D(i+4) end;
T(3):= D(1); T(6):= D(4) end;
c:= 1/(Rot(x)-Rot(y));
a:= (Rot(y)-Rot(z))*c;
b:= (Rot(z)-Rot(x))*c;
c:= (T(1)+T(2)-2*T(4))/4000;
Rot(x):= Rot(x) + a*c;
Rot(y):= Rot(y) + b*c;
Rot(z):= Rot(z) + c; c:= -1/8000;
D(1):= (T(1)+T(2))*c;
D(2):= (T(4)+T(5)+T(6))*(c+c) - D(1)*3;
D(3):= (T(1)+T(2)+T(3)-T(4)-T(5)-T(6))*(c+c);
D(4):= (T(1)-T(2))*c*0.5;
D(5):= (T(1)*b-T(2)*a+T(4)*(a-b)-T(5)+T(6))*c
end;
C:= Rot(3); A:= Rot(1);
for i:=1 step 1 until 8 do TAU(i):= case i of (4,3,1,2,1,2,4,3);
if oblat then begin
Rot(3):= (A-Rot(2))*0.25;
Rot(2):= (A+Rot(2))*0.5;
Rot(1):= C-Rot(2);
for i:=1 step 1 until 8 do
MATRIX(i):= case i of (1,4,2,3,2,3,1,4)
end else begin
Rot(3):= (Rot(2)-C)*0.25;
Rot(2):= (Rot(2)+C)*0.5;
Rot(1):= A-Rot(2);
for i:=1 step 1 until 8 do
MATRIX(i):= case i of (1,2,3,4,2,1,4,3)
end;
for i:=1 step 1 until 8 do begin
KATALOG(1,i):= case i of (1,2,3,4,2,1,4,3);
KATALOG(2,i):= case i of (1,4,3,2,4,1,2,3);
KATALOG(3,i):= case i of (1,3,2,4,3,1,4,2) end;
overgange:= 0; Qr:= 1;
J:= Jmin;
Jlige:= J=J//2*2;
begin zone dummy(128,1,stderror);
open(dummy,4,<:rotmat:>,0); Wtail(1):= 8;
monitor(40,dummy,0,Wtail); monitor(50,dummy,15,Wtail);
if J=0 then begin outrec(dummy,128);
for i:=1,43,85 do dummy(i):= 0;
close(dummy,true); J:= 1; Jlige:= false
end end;
if sorter then begin
open(L,4,<:rotline:>,0); Ltail(1):= 50;
monitor(40,L,0,Ltail); outrec(L,128) end;
if -,intensitet then begin
open(L,4,<:starkmat:>,0); Ltail(1):= 100;
if monitor(40,L,0,Ltail)>0 then begin nylinie;
write(res,<:
***starkmat reserved:>);
goto stop end else outrec(L,128)
end;
monitor(50,L,15,Ltail);
comment De indledende beregninger er nu tilendebragt, og de
egentlige frekvens- eller energiberegninger kan påbegyndes.
Disse beregninger foregaar i to faser. I fase 1 beregnes
først elementerne i de 4 E-matricer svarende til ee, eo, oe
og oo. Energierne beregnes som egenværdier i disse matricer og
lagres i et W-array. Dette transporteres til slut til plade-
lageret. Naar alle fire matricer er behandlet, beregnes fejlen
paa hamiltonmatricens spor;
systime(1,starttime,time);
FASE1:
begin
real F, G, G1, H, H1, p;
integer type,K,K2,N,s,matrix;
zone alfa(128*2,2,stderror);
array a,b(0:42);
Qrj:= spor:= 0; JJ:= J*(J+1);
F:= Rot(2)*JJ; G:= Rot(1); H:= Rot(3);
open(alfa,4,<:rotmat:>,0);
if -,Jlige then setposition(alfa,0,4);
if centrifugal then begin
F:= F - D(1)*JJ*JJ; G1:= -D(3);
G:= G - D(2)*JJ; H1:= -D(5);
H:= H - D(4)*JJ + H1 + H1
end else G1:= H1:= 0;
for type:=1 step 1 until 4 do begin
s:= if Jlige then type else (type+4);
matrix:= MATRIX(s);
K:= if matrix=1 then -2 else if matrix=2 then 0 else -1;
p:= if matrix=1 then 2 else 1; N:= (J-K)//2;
outrec(alfa,128);
if N>0 then begin
comment Nu beregnes matrixelementerne;
for j:=1 step 1 until N do begin
K:= K+2; K2:= K*K;
a(j):= alfa(j):= F+ (G+G1*K2)*K2;
if j<>N then b(j):= alfa(42+j):=
-(H+ H1*(K2+K+K))*sqrt(p*(J-K)*(J-K-1)*(J+K+1)*(J+K+2));
p:= 1
end j;
if matrix>2 then
alfa(1):= a(1):= a(1)+(if matrix=3 then -1 else 1)*(H-H1)*JJ;
alfa(42+N):= b(N):= 0;
comment Den aktuelle E-matrix er nu beregnet, idet diagonal-
elementerne står i a og sidediagonalelementerne i de første n-1
pladser af b. Egenværdierne beregnes ved QL transformation,
og ordnes efter aftagende størrelse;
begin
real f,g,h,bt,c,s,q;
bt:= f:= 0;
for k:= 1 step 1 until N do begin
h:= 3'-11*(abs a(k) + abs b(k));
if bt<h then bt:= h;
if abs b(k)<=bt then goto root;
comment form shift;
nextit:
p:= (a(k+1)-a(k))/(2*b(k)); q:= sqrt(p*p+1);
h:= a(k)-b(k)/(if p<0 then p-q else p+q);
for i:=k step 1 until N do a(i):= a(i)-h;
f:= f+h;
comment QL transformation;
p:= a(N); c:= 1; s:= 0;
for i:=N-1 step -1 until k do begin
g:= c*b(i); h:= c*p;
if abs p>=abs b(i) then begin
c:= b(i)/p; q:= sqrt(c*c+1);
b(i+1):= s*p*q; s:= c/q; c:= 1/q
end else begin
c:= p/b(i); q:= sqrt(c*c+1);
b(i+1):= s*b(i)*q; s:= 1/q; c:= c/q
end;
p:= c*a(i)-s*g;
a(i+1):= h+s*(c*g+s*a(i));
end i;
b(k):= s*p; a(k):= c*p;
if abs b(k)>bt then goto nextit;
root:
p:= a(k)+f; spor:= spor+p; i:= k;
for i:= i-1 while i>0 and p>a(i) do a(i+1):= a(i);
a(i+1):= p
end k end;
p:= vægt(if type=1 or type=symx then 1 else 2)*(J+J+1);
for i:=1 step 1 until N do begin
Qrj:= Qrj+exp(-a(i)*4.7993'-5/temp)*p; alfa(84+i):= a(i)
end end end tælling paa de fire typer.
Alle energier svarende til den aktuelle J-værdi er nu
beregnet og deres sum staar i spor. Fejlen paa denne sum
(hidrørende fra afrundingsfejl ved egenværdiberegningen) kan
nu beregnes;
Qr:= Qr+Qrj; close(alfa,true);
spor:= abs(spor - (J+J+1)*(F+JJ*(G/3+(3*JJ-1)*G1/15)))
end FASE1;
comment I fase 2 foretages beregning og trykning af de over-
gange, der opfylder de af inputparametrene givne betingelser;
FASE2:
begin
integer type1,type2,d1,d2,q1,q2,matr1,matr2,
tau1,tau2,k1,k2,J1,J2,N,N1,N2,K;
boolean Q, ingen;
zone W1, W2(128,1,stderror);
open(W1,4,<:rotmat:>,0); open(W2,4,<:rotmat:>,0); J2:= J*J;
for j:=1,2,3 do
if my(j)>0 then begin
if output then begin
if l>=58 then begin write(res,nl,2); l:= l+2 end;
nylinie; if l<>3 then nylinie;
write(res,case j of (<:myA:>,<:myB:>,<:myC:>),<:-lines:>);
end;
comment Størrelsen j tæller de tre forskellige typer myA, myB
og myC. Hver gang j skifter værdi, trykkes som en slags over-
skrift hvilken type de følgende linier tilhører. For hver type
trykkes først PR-overgange, og derefter - med ekstra linieaf-
stand - Q-overgange. Saafremt der ikke findes linier, der op-
fylder de krav,der er stillet gennem inputparametrene, trykkes
ordet ingen efter den lige omtalte overskrift. Naar alle lini-
er hørende til den aktuelle værdi af J er trykt, trykkes fejlen
på summen af egenværdierne for denne J-værdi;
ingen:= true;
Q:= -,PRlinier and Qlinier;
if Jlige then begin d1:= 0; d2:= 4 end
else begin d1:= 4; d2:= 0 end;
QLINIER:
if Q and-,ingen and output then nylinie;
if Q or PRlinier then
for k:=1,3,5,7 do begin
J1:= if Q then J else J-1;
type1:= KATALOG(j,k); q1:= type1+ (if Q then d1 else d2);
type2:= KATALOG(j,k+1); q2:= type2+ d1;
matr1:= MATRIX(q1); matr2:= MATRIX(q2);
tau1 := TAU(q1)+J1; tau2 := TAU(q2)+J;
k1:= if matr1=1 then -2 else if matr1=2 then 0 else -1;
k2:= if matr2=1 then -2 else if matr2=2 then 0 else -1;
N1:= (J1-k1)//2; N2:= (J-k2)//2;
if N1>=0 and N2>=0 then begin
real f,g,LJM;
setposition(W1,0,q1-1); setposition(W2,0,q2-1);
inrec(W1,128); inrec(W2,128);
comment Energierne svarende til en af de tre typer bestemt
ved j og en af de tilladte overgange bestemt ved k befin-
der sig nu iferritlageret i hhv. W2 og W1.
Alle kombinationer af differenser (f) af energiniveauer
dannes, og de der opfylder inputspecifikationerne, trykkes.
Først beregnes dog den K-uafhængige liniestyrkefaktor (LJM);
LJM:= if Q then (J+J+1)/(4*JJ) else 1/(4*J);
for q1:=1 step 1 until N1 do
for q2:=1 step 1 until N2 do begin
n:= if oblat then q1-q2 else N1-q1-N2+q2;
if abs(n+n+k1-k2)<=dKmax then begin
f:= W2(q2+84) - W1(q1+84); g:= abs f;
if g>=Fmin and g<=Fmax then begin
real norm1, norm2, A, B;
array S1(1:N1), S2(1:N2);
procedure egenvektor(E,N,W,S,norm);
value E,N;
real E,norm; integer N; array S; zone W;
begin
integer i,j; real x,y; array a,b(1:N);
j:= 1;
for i:=1 step 1 until N do begin
a(i):= W(i)-E; b(i):= W(42+i);
if abs(a(i))<abs(a(j)) then j:=i end;
if b(1)<>0 then begin
S(1):= S(N):= norm:= 1;
if 1<j then S(2):= -a(1)/b(1);
i:= 1;
for i:=i+1 while i<j do
S(i+1):= -(S(i)*a(i)+S(i-1)*b(i-1))/b(i);
y:= 1/S(j);
for i:=j-1 step -1 until 1 do begin
S(i):= x:= S(i)*y; norm:= norm+x*x end;
if j<N then S(N-1):= -a(N)/b(N-1);
i:= N;
for i:=i-1 while i>j do
S(i-1):= -(S(i)*a(i)+S(i+1)*b(i))/b(i-1);
y:= 1/S(j);
for i:=j+1 step 1 until N do begin
S(i):= x:= S(i)*y; norm:= norm+x*x end;
S(j):= 1; norm:= 1/norm
end else begin
for i:=1 step 1 until N do S(i):= 0;
S(j):= norm:= 1
end end egenvektor;
egenvektor(W1(q1+84),N1,W1,S1,norm1);
egenvektor(W2(q2+84),N2,W2,S2,norm2);
comment De aktuelle egenvektorer er nu tilstede, og linie-
styrken kan beregnes. Den K-afhængige liniestyrkefaktor (A)
beregnes først for my-z overgange;
A:= 0;
if (-,oblat and j=1)or(oblat and j=3) then begin
if Q then begin
m:= if matr1=1 then 1 else 0;
n:= if matr2=1 then 1 else 0;
N:= N1-m;
K:= if m=1 or n=1 then 0 else -1;
for i:=1 step 1 until N do begin
K:= K+2; A:= A+ S1(i+m)*S2(i+n)*K
end end Q-linie
else begin
N:= if N1>N2 then N2 else N1; K:= k1;
for i:=1 step 1 until N do begin
K:= K+2; A:= A+ S1(i)*S2(i)*sqrt(J2-K*K)
end end R-linie;
A:= A+A
end my-z overgang
Nu beregnes liniestyrkefaktoren for my-x overgang(m= -1)
eller my-y overgang(m= 1).
else begin
m:= if (-,oblat and j=3)or(oblat and j=2) then 1 else -1;
hb:= matr1=1 or matr2=2; q:= if Q then 1 else -1;
K:= k1; p:= if K=-2 then 2 else 1; n:= if hb then 0 else 1;
N:= N2-n; if N>N1 then N:= N1;
for i:=1 step 1 until N do begin
K:= K+2; A:= A+ S1(i)*S2(i+n)*sqrt(p*(J-q*K)*(J+K+1)); p:= 1
end første sum;
K:= k2+1; p:= if K=-1 then 2 else 1; n:= if hb then 1 else 0;
N:= N1-n; if N>N2 then N:= N2; B:= 0;
for i:=1 step 1 until N do begin
K:= K+2; B:= B+ S1(i+n)*S2(i)*sqrt(p*(J+q*K)*(J-K+1)); p:= 1
end anden sum;
A:= A+ q*m*B
end my-y og my-x overgang;
A:= A*A*norm1*norm2;
comment Liniestyrken er A*LJM, og den relative intensitet eller
Stark-koefficienterne kan beregnes. Er intensiteten eller en af
Starkkoefficienterne større end den i input givne Lmin, udskri-
ves frekvensen og den eventuelle quadrupolsplitning beregnes.
Skal der til slut foretages en liniesortering , tromlelagres
de beregnede størrelser;
hb:=false;
if intensitet then begin
if f>0 then begin
B:= W1(q1+84); p:= type1 end
else begin
B:= W2(q2+84); p:= type2 end;
m:= if j=1 and p=2 or j=2 and p=4
or j=3 and p=3 or p=1 then 1 else 2;
A:= A*LJM*exp(-B*4.7993'-5/temp)*my(j)*vægt(m)*g
*(1-exp(-g*4.7993'-5/temp))*Lscale; hb:= A>Lmin
end beregning af rel. intensitet(A) ved 25 Celciusgr.
else begin
hb:= A*100>g*JJ; if hb or A>g*JJ*Lmin then begin
A:= if Q then A/(JJ*JJ) else A/(J2*(J+J+1)*(J+J-1));
B:= 0; m:= tau1 - 4*q1; n:= tau2 - 4*q2;
B:= B add J1 shift 8 add ((J1+1+m)//2) shift 8
add ((J1+1-m)//2) shift 8 add J shift 8
add ((J +1+n)//2) shift 8 add ((J +1-n)//2);
p:= overgange mod 42 * 3;
L(p+1):= B; L(p+2):= f; L(p+3):= A; B:= 0;
if p+3=126 then outrec(L,128);
overgange:= overgange+1;
if -,hb then begin A:= B:= A/(4*g); hb:= true end
end end beregning af Stark-koefficienter(A,B);
N:= if quadrupol then 4 else 3;
if hb then begin array M(1:N);
ingen:= false; if output then nylinie; hb:= f<0; M(2):= 0;
if hb then goto anden;
første: n:= tau1-4*q1;
if output then write(res,<<ddd>,J1,(J1+1+n)//2,(J1+1-n)//2,<: :>);
M(2):= M(2) shift 12 add J1 shift 12 add (n extract 12);
if hb then goto frekv;
anden: n:= tau2-4*q2;
if output then write(res,<<ddd>, J, (J+1+n)//2, (J+1-n)//2,<: :>);
M(2):= M(2) shift 12 add J shift 12 add (n extract 12);
if hb then goto første;
frekv:
if output then write(res,<<_ddd ddd.dd>,g);
if intensitet then begin
if output then write(res,<<__dd ddd>,A) end
else begin
if B<>0 then write(res,<: :>);
write(res,<<___d.ddd ddd'-d>,A)
end;
if quadrupol then begin
real eqQ1, eqQ2, a,b,c;
procedure EQQ(J,matrix,k,N,S,norm,eqQ);
value J,matrix,k,N,norm;
real norm,eqQ; integer J,matrix,k,N; array S;
begin
integer JJ,K,i; real PA,PB,PC,s,p;
K:= k; p:= if K=-2 then 2 else 1;
PA:= PB:= 0; JJ:= J*(J+1); PC:= JJ//2*S(1);
PC:= if matrix=3 then -PC else if matrix=4 then PC else 0;
for i:=1 step 1 until N do begin
K:= K+2; s:= S(i);
PA:= PA+K*K*s*s; PB:= PB+PC*s;
if i<>N then PC:= -sqrt(p*(J-K)*(J-K-1)*(J+K+1)*(J+K+2))*s;
p:= 1 end i;
PA:= PA*norm; s:= PB*norm;
PB:= (JJ-PA+s)*0.5; PC:= (JJ-PA-s)*0.5;
if oblat then begin s:= PA; PA:= PB; PB:= PC; PC:= s end;
eqQ:= (PA*ki(1)+PB*ki(2)+PC*ki(3))*0.5;
end EQQ;
EQQ(J1,matr1,k1,N1,S1,norm1,eqQ1);
EQQ(J,matr2,k2,N2,S2,norm2,eqQ2);
if hb then begin eqQ1:= -eqQ1; eqQ2:= -eqQ2 end;
a:= (if J1=0 then 0 else -eqQ1/(J1*(2*J1-1))) + eqQ2/(J*(2*J-1));
b:= (if J1=0 then 0 else eqQ1/(J1*(J1+1))) - eqQ2/JJ;
c:= -eqQ1/((J1+1)*(2*J1+3)) + eqQ2/((J+1)*(2*J+3));
if output then begin
write(res,<: :>); write(res,<<-ddd.ddd>,a,b,c) end;
if sorter then begin i:= 65536;
n:= round(a*1000); if n<0 then n:= n+i;
p:= round(b*1000); if p<0 then p:= p+i;
q:= round(c*1000); if q<0 then q:= q+i;
M(4):= 0.0 shift 6 add n shift 16 add p shift 16 add q
end end quadrupol;
if sorter then begin
M(1):= g; M(3):= 4.1623125'-19*A/Lscale;
q:= 128//N; p:= overgange mod q; hb:= p+1 = q; p:= p*N;
for i:=1 step 1 until N do L(i+p):= M(i);
if hb then outrec(L,128)
end;
if intensitet then overgange:= overgange + 1
end end udskrift af linie
end end tælling af alle kombinationer(q1,q2)
end W1-W2 blok;
if k=7 then begin
Q:= Qlinier;
PRlinier:= false;
goto QLINIER
end;
if Q and k=3 then goto LINIESLUT
end tælling paa overgangstyper(k);
LINIESLUT:
PRlinier:= J<=JPRmax and J>Jmin;
if ingen and output then write(res,<:: none:>)
end tælling af my-typer(j);
if output then begin
l:= l+3;
write(res,nl,2,<:Qr, dQr and Trace error for J = :>,<<dd>,J,<: : :>,
<< d.ddd'd>,Qr,Qrj,<<ddd.ddd>,spor,nl,1,<: Time, cpu: :>,
(systime(1,starttime,A)-cpu)/60,<: real::>,A/60);
end;
comment Trykningen svarende til den aktuelle værdi af J er nu
forbi. Fase 2 afsluttes med en fremtælling af J og et hop forfra,
hvis beregningerne ønskes udført ogsaa for den nye J-værdi;
J:= J+1; Jlige:= -,Jlige;
hb:= 2*spor-time < stoptime and Qrj>Qr*'-4; time:= spor;
Qlinier:= J<=JQmax;
PRlinier:= J<=JPRmax;
if hb and (Qlinier or PRlinier) then goto FASE1;
end FASE2;
if -,intensitet then
L(overgange mod 42*3 + 1):= 0.0 add J shift 16;
if output then
write(res,nl,2,<:Total number of transitions:>,
<<dddd>, overgange)
end BEREGNINGSBLOK;
begin zone dummy(128,1,stderror);
open(dummy,4,<:rotmat:>,0); monitor(48,dummy,0,Wtail) end;
comment Til slut sorteres linierne efter voksende frekvens;
m:= if quadrupol then 4 else 3;
if overgange=0 then
write(res,nl,2,<:No lines between J = :>,<<dd>,
Jmin,<: and J = :>,J-1)
else if sorter then begin
integer min, max, tau, k1, k2, dk1, dk2; real Q,R,S,Smax;
integer array N(1:overgange); array F(1:overgange);
zone save(if savesort then 128 else 1,1,stderror);
if savesort then begin
open(save,4,<:savelist:>,0); Wtail(1):= overgange*27//768+1;
monitor(40,save,0,Wtail); monitor(50,save,15,Wtail)
end;
q:= 128//m; n:= (overgange-1)//q;
if n>=0 then begin
setposition(L,0,0); p:= q end else p:= 0;
min:= max:= N(1):= 1; Smax:= 0;
Q:= if Qr>Qra then Qr else Qra;
for k:=1 step 1 until overgange do begin
if p=q then begin inrec(L,128); p:= 0 end;
F(k):= R:= L(p*m+1); S:= L(p*m+3)/Q;
if S>Smax then Smax:= S; p:= p+1; j:= max;
for i:= min,N(i) while i<>min do
if F(i)<=R then j:= i else i:= max;
if j=max then begin
if R>=F(max) then max:= k else
if R< F(min) then min:= k end;
N(k):= N(j); N(j):= k
end k;
Smax:= 10**entier(ln(Smax)/ln10);
if output then begin
write(res,<:<10>Time after sorting, cpu: :>,<<dd.ddd>,
(systime(1,starttime,time)-cpu)/60,<: real: :>,time/60);
side:= 0; l:= 70; nylinie; overskrift
end; nylinie;
for i:=min,N(i) while i<>min do begin
p:= (i-1)//q; if n<>p then begin
n:= p; setposition(L,0,n); inrec(L,128) end;
p:= (i-1) mod q * m; nylinie;
R:= L(p+2);
for j:=-24,0 do begin
J := R shift (j-12) extract 12;
tau:= R shift j extract 12;
if tau>=2048 then tau:= tau-4096;
if j=0 then begin dk1:=k1; dk2:= k2 end;
k1:= (J+1+tau)//2; k2:= (J+1-tau)//2;
write(res,<<ddd>,J,k1,k2,<: :>);
if savesort then write(save,<<ddd>,J,k1,k2)
end;
R:= L(p+3)/(Q*Smax);
write(res,<<_ddd ddd.dd>, L(p+1),<<__d.dddd>,R);
if savesort then begin
dk1:= abs(dk1-k1); dk2:= abs(dk2-k2);
dk1:= if dk1//2*2=dk1 then 0 else 1;
dk2:= if dk2//2*2=dk2 then 0 else 1;
j:= if dk1=0 and dk2=1 then 1 else
if dk1=1 and dk2=0 then 3 else 2;
write(save,<<dd>,j,<<_ddddd>,R*'4,<:<10>:>)
end;
if quadrupol then begin
R:= L(p+4); max:= 32768; write(res,<: :>);
for j:=-32 step 16 until 0 do begin
k:= R shift j extract 16;
write(res,<<-ddd.ddd>,
(if k<max then k else k-max-max)*0.001)
end
end quadrupol
end i;
write(res,nl,2,<:Partition func., sum and approx.::>,
<< d.ddd'd>,Qr,Qra,nl,1,<:Intensity * :>,<<d'-dd>,Smax,
<: = Integrated Int.(cm**2 MHz) per molecule.
NB: The greater of the two estimates of Q used.:>);
if savesort then begin
write(save,<:-1<10><25>:>); close(save,true)
end end sorter;
write(res,nl,2,<:Total time, cpu:>,<<dd.ddd>,
(systime(1,starttime,time)-cpu)/60,<: real: :>,time/60);
if sorter then monitor(48,L,0,Ltail) else begin
getposition(L,i,j); Ltail(1):= j+1;
monitor(44,L,0,Ltail); close(L,true) end;
stop:
write(res,<:<10>:>,<:<12>:>,<:<25>:>); close(res,closeres)
end
▶EOF◀