|
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: 18432 (0x4800)
Types: TextFile
Names: »writephtx«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦787c125fb⟧ »adjprocfile«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦787c125fb⟧ »adjprocfile«
└─⟦this⟧
; otn ph proc * page 1 29 11 79, 15.39;
; w r i t e _ p h
; ***************
;
write_ph = set 1
write_ph = algol message.no
external
integer procedure write_ph(output, record, W, w_s, redf, st_no);
________________________________________________________________
value w_s;
zone output;
real array record, W, redf;
integer w_s;
long procedure st_no;
begin
comment
Function.
_________
Write_ph write a text representation of a photogramme-
try observation.
Record format as the obs_zn of the adjustment system,
see the ico-procedure save_ph_obs for a description.
Text format as for read_steco (gi program index 76092)
and read_mono (78068).
*
Parameters.
___________
write_ph (integer, return value). The number of
_ lines written on output.
output (zone, call and return value). Output
_ zone, open and ready for character out-
_ put.
record (real array, call value). The photogram-
_ metric record to be written.
W (real array, call value). The differences
_ between the adjusted and observed exter-
_ nal coordinates, i.e. right hand side of
_ observation equations.
w_s (integer, call value). The no of w's per
_ point, i.e.:
_ 1 - height adjustment
_ 2 - horizontal adjustment
_ 3 - 3D-adjustment
_ The typedecimal of the coordinates is
_ added after a shift of 12.
redf (real array, call value). The reduction
_ factor, used if < 1.0.
;
\f
comment otn ph proc * page 2 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
comment
st_no (long procedure, call value). Transfor-
_ mation of station index to station no.
_ The procedure has one value integer pa-
_ rameter, the station index, and one re-
_ turn long parameter. The value of the
_ procedure is the station no (The return
_ value of the long parameter is not used).
_ The procedure st_nmb of the adj-module
_ may be used.
*
;
comment
*
Externals.
__________
nl character value of New Line
prvers text date of the procedure
sp character value of space
write_geo_c geo-type output of longs
write_geo_r geo output of reals
write_ph_id photo-record identification
write_stn output of station no
*
Identification.
_______________
write_ph
WW, dec 1977,
KP, aug 1978, små blå søm,
KP, oct 1979, ret for number conventions
WW, nov 1979, output of mono obs and resi
;
\f
comment otn ph proc * page 3 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
comment
External representation of plane anblock orientations parameters.
_________________________________________________________________
In the coordinate adjustment case (i.e. job_type 2 and 3)
the rhs-module compute a 6-parameter orientation of the an-
block model. The 6 parameters are:
N0 ) External coordinates of
E0 ) the fictive point (x_m, y_m).
x_m ) The weighted mean of
y_m ) the observed model coordinates.
m The scale of the model.
a The rotation of the model (around the z-axis).
The exate meaning of this parameters can be found from the
procedure get_coord and the first lines of the sum-loop in
the photogrammetry case in the obs_zn read-loop in the rhs
module. This give the relations
DN = N - N0
DE = E - E0
x = x_obs - x_m
y = y_obs - y_m
DN = x m cos a - y m sin a
DE = x m sin a + y m cos a
where (N, E) and (x_obs, y_obs) are the external and the
model coordinate of the point in question. Combining this
equations give
N = (x_obs - x_m) m cos a - (y_obs - y_m) m sin a + N0
E = (x_obs - x_m) m sin a + (y_obs - y_m) m cos a + E0
Using (x_obs, y_obs) = (0, 0) in the above formular you
get the external coordinate of the main-point
N = - x_m m cos a + y_m m sin a + N0
E = - x_m m sin a - y_m m cos a + E0
and the model is orientated using the 4 parameters
N ) External coordinates of the main point
E ) (i.e. the point with model coordinate (0, 0)).
m The scale of the model
a The rotation of the model.
;
\f
comment otn ph proc * page 4 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
boolean field bf, obs_count_f, clock,
_ obs_kind_f, obs_type_f;
integer field intf;
real field rf, x_rot, y_rot, z_rot,
_ scale, x_m_f, y_m_f, z_m_f;
long field lf, anb_date,
_ N0, E0, H0;
integer array field iaf;
real array field x1, y1, x2, y2, rel;
integer array field stn;
boolean type_dec, c_type_dec;
integer a, char, chars, i, nls, length,
_ obs_type, q, t, oc_state;
real m_cosa, m_sina,
_ x_m, y_m, z_m,
_ f2 <* segn of second coordinate *>;
long l, exp_id,
_ N, E, H;
long array id_array(1:2);
nls := 0;
iaf := 0;
comment fixed fields of photo obs_zn record;
obs_kind_f := 5;
obs_type_f := 6;
obs_count_f := 7;
clock := 12;
a := 34;
obs_type:= record.obs_type_f extract 12;
q := record.obs_count_f extract 12;
bf := 10;
oc_state:= record.bf extract 12;
\f
comment otn ph proc * page 5 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
if record.obs_kind_f extract 12 = 6 <* anblock *>
and 1<= obs_type and obs_type <= 3 then
begin
comment variable fields in photo obs_zn;
x_m_f := a + (6 + 4 * obs_type) * q + 4;
y_m_f := x_m_f + 4;
z_m_f := y_m_f + 4;
N_0 := z_m_f + 4;
E_0 := N_0 + 4;
H_0 := E_0 + 4;
x_rot := H_0 + 4;
y_rot := x_rot + 4;
z_rot := y_rot + 4;
scale := z_rot + 4;
comment date of messurement, operator id and serial no;
id_array(1):= long record(20//4);
id_array(2):= 0;
i:= 1;
chars:= write(out_put, nl, 2,
<< zd dd dd>, record.iaf(14/2) <*mes date *>,
sp, 3, string id_array(increase(i)));
nls:= nls + 2;
write(out_put, sp, 2 + 11 + 3 + 7 - chars,
<< ddd>, record.iaf(16//2));
c_type_dec := false add (w_s shift (-12));
w_s := w_s extract 12;
\f
comment otn ph proc * page 6 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
comment exposure identifications;
l:= 0;
if ( if record.iaf(1) > scale
_ then record.iaf((scale + 10) // 2) <> 0
_ else false )
then
begin
comment write exp id;
for lf:= (scale + 4), (scale + 8) do
begin
exp_id:= record.lf;
if (lf = (scale + 4) or (
record.iaf((scale + 10)//2) <>
record.iaf((scale + 12)//2) <* date *> or
record.iaf((scale + 2)//2) shift (-7) <>
record.iaf((scale + 6)//2) shift (-7) <* route *>)) then
begin
comment write new date, route and camera constant;
write(out_put, nl, 1, << zd dd dd>,
record.iaf((if lf = (scale + 4)
_ then (scale + 10)
_ else (scale + 12)) // 2 ));
nls := nls + 1;
i := exp_id shift (-36) <* route no *>;
char:= exp_id shift (-31) extract 5 add (1 shift 6);
if ((64 < char and char < 94)
or (96 < char and char < 126)) then
write(out_put, sp, 4, <<dddd>, i, false add char, 1)
else
write(out_put, << dddd>, i, <:.:>, <<d>, char extract 6);
rf:= lf + 12 <* camera constant *>;
write(out_put, <<___ddd.ddd>, record.rf);
end new;
comment picture no and sub-no;
write(out_put, sp, 5, <<dd>, exp_id shift (-19) extract 12);
i:= exp_id extract 12;
if i > 0 then
write(out_put, <:.:>, <<d>, i);
end for lf;
end
else
begin comment no exp id in record;
write(out_put, <: <10> :>);
nls := nls + 1;
end;
\f
comment otn ph proc * page 7 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
comment write abs ori elem;
if oc_state > 0 then
begin
comment write abs orientation;
N:= record.N0;
E:= record.E0;
H:= record.H0;
comment ON TEST : :
write(out, << -d.dddddd'-d>, <:<10>write ph test output:>,
<:<10>N0, E0 :>, record.N0, record.E0,
<:<10>N, E :>, N, E,
<:<10>mcosa, msina:>, mcosa, msina,
<:<10>x<95>m, y<95>m :>, x_m, y_m);
write(out_put, <:<10>Scale : :>, << -d.dddddd'd>,
_ record.scale / '6, sp, 3,
_ <:<10>Main point: :>);
nls:= nls + 2;
type_dec:= false add 8 shift 6 add 3;
write_geo_c(out_put, N, c_type_dec);
write(out_put, sp, 3);
write_geo_c(out_put, E, c_type_dec);
if oc_state > 1 then
begin
write_geo(out_put, H, type_dec);
end oc_state > 1;
write(out_put, sp, 3,
_ <:<10>Rotation : :>);
nls:= nls + 1;
if oc_state > 1 then
begin
write_geo_c_r(out_put, record.x_rot, false add 1 shift 6);
write_geo_c_r(out_put, record.y_rot, false add 1 shift 6);
end oc_state > 1;
write_geo_r(out_put, record.z_rot, false add 1 shift 6);
end
else
begin
comment no abs orientation in record;
write(out_put, <: <10> :>);
nls:= nls + 1;
end;
\f
comment otn ph proc * page 8 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
rel:= rf := scale + 24 <* bx *>;
comment ON TEST : :
write(out, <:<10>rel, scale :>, rel, scale);
if ( if record.iaf(1) > rf
_ then abs(record.rf) > 100
_ else false )
then
begin
comment relativ orientation;
write(out_put, nl, 1, sp, 11,
<< -ddddd.ddd>,
record.rel(0), record.rel(1), record.rel(2),
<< -d.ddddddd>, nl, 1, sp, 11,
record.rel(3), record.rel(4), record.rel(5));
rf:= 24;
write(out_put, << ddd>, record.rf, sp, 3);
nls:= nls + 2;
end
else
begin
comment no relativ orientation in record;
write(out_put, <: <10> :>);
nls:= nls + 1;
end;
\f
comment otn ph proc * page 9 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
comment messurements;
bf := 7;
q := record.bf extract 12;
stn := a;
x1 := a + 2 * q;
y1 := a + 6 * q;
x2 := a + 10 * q;
y2 := a + 14 * q;
f2 := if record.clock then 1 else -1;
comment ON TEST: :
write(out, <:<10>f2 : :>, f2,
_ <:<10>clock : :>,
_ if record.clock then <: true:> else <: false:>);
for t:= 1 step 1 until q do
begin
if t mod 5 = 1 then
begin
write(out_put, nl, 2);
nls:= nls + 2;
end
else
begin
write(out_put, nl, 1);
nls:= nls + 1;
end;
comment ON TEST : :
bf <* dummy *> :=
write(out, nl, 1, << ddd>, t, << -ddd ddd>, record.stn(t)) +
write_stn(out, st_no(record.stn(t), l));
write_stn(out_put, st_no(record.stn(t), l));
write(out_put, << -ddddd.ddd>,
record.x1(t), record.y1(t) * f2);
case obs_type of
begin
;
write(out_put, << -ddddd.ddd>, record.x2(t));
write(out_put, << -ddddd.ddd>, record.x2(t), record.y2(t));
end;
write(out_put, sp, 3);
\f
comment otn ph proc * page 10 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
case w_s of
begin
begin
comment case 1: height adjustment;
write(out_put, <:<10>*:>, sp, 10 + 2 * 12,
_ << -ddddd.ddd>, W(t));
nls:= nls + 1;
comment check red fact;
if redf(t) < 1 then write(out_put, << -.dd'-dd>, redf(t));
write(out_put, <: ; :>);
end case 1;
begin
comment case 2: horizontal adjustment;
write(out_put, <:<10>*:>, sp, 10, << -ddddd.ddd>,
_ W(2*t-1), W(2*t));
nls:= nls + 1;
comment check red fakt;
if redf(t) < 1 then write(out_put, << -.dd'-dd>, redf(t));
write(out_put, <: ; :>);
end case 2;
begin
comment case 3: 3D-adjustment;
write(out_put, <:<10>*:>, sp, 10, <<__-ddddd.ddd>,
W(3*t-2), W(3*t-1), W(3*t));
if redf(t) < 1 then write(out_put, <<__-.dd'-dd>, redf(t));
write(out_put, <:__;:>);
end case 3;
end case w_s of;
end for t;
write(out_put, <:<10>__________0<10><10>:>);
nls:= nls + 3;
end
else
\f
<* otn ph proc * page 11 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 *>
if record.obs_kind_f extract 12 = 14 <* mono *> then
begin
comment fields in mono record;
boolean field sets_f, oc_state_f,
_ tpd_obs_f, sub_f, cam_tpd, rot_tpd;
integer field length, sum, exp_day, cam;
long field ident_f;
real field m_f, cc_f;
boolean array field last_f;
integer array field model_no, model_date, st_nmb;
long array field operator, ori_f;
real array field x, y;
procedure set_var_fields;
begin
integer sub, t;
sub:= record.sub_f extract 12;
t := 4 * q;
x := st_nmb + 2*q;
y := x + t;
model_no := y + t;
t := sub * 2;
model_date := model_no + t;
operator := model_date + t;
last_f := operator + 2 * t;
ori_f := last_f + (sub + 1) // 2 * 2;
cam_tpd := ori_f + 6*4 + 1;
rot_tpd := cam_tpd + 1;
end set_var_fields;
comment init of fixed mono fields;
sets_f := 9;
oc_state_f := 10;
tpd_obs_f := 11;
sub_f := 12;
ident_f := 16;
exp_day := 18;
cam := 20;
m_f := 28;
cc_f := 32;
st_nmb := 34;
\f
comment otn ph proc * page 12 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
if record.obs_kind_f extract 12 = 14 <* mono *> then
begin
boolean tpd_obs;
integer object_no, sub_no, sub, last, t, chars;
long array txt(1:2);
f2 := 1 <* T E M P G R I S *>;
chars := 0;
tpd_obs := record.tpd_obs_f;
tpd_obs := false add (8 shift 6 add 3) <* G R I S *>;
sub := record.sub_f extract 12;
object_no := 1;
txt(2) := 0;
set_var_fields;
chars:= chars + write(out_put, nl, 3)
_ + wr_ph_id(out_put, record)
_ + write(out_put, <: a :>,
_ << zd dd dd>, record.exp_day,
_ << dddd>, record.cam,
_ << -ddd.ddd>, record.cc_f);
nls:= nls + 3;
comment ON TEST: ;
if fp_mode(2) then
t:= write(out, nl, 1)
+ wr_ph_id(out, record)
+ write(out, sp, 2, q, sub, x, y, model_no, model_date, ori_f, rot_tpd);
if record.oc_state_f extract 12 > 0 then
begin
write(out_put, <:<10>Camera _ ::>);
nls:= nls + 1;
for t:= 1 step 1 until 3 do
write_geo(out_put, record.ori_f(t), <*record.cam_tpd*>
<* T E M P G R I S *> false add 8 shift 6 add 0);
write(out_put, <:<10>Rotation ::>);
nls:= nls + 1;
for t:= 4 step 1 until 6 do
write_geo_c_r(out_put, real record.ori_f(t), <*record.rot_tpd*>
<* T E M P G R I S *> false add 1 shift 6 add 2);
end;
\f
comment otn ph proc * page 13 29 11 79, 15.39
0 1 2 3 4 5 6 7 8 9 ;
for sub_no:= 1 step 1 until sub do
begin
txt(1):= record.operator(sub_no);
chars:= chars +
write(out_put, <:<10><10>M:>, <<d>, record.model_no(sub_no),
<< zd dd dd>, record.model_date(sub_no),
sp, 3, txt);
nls:= nls + 2;
last:= record.last_f(sub_no) extract 12;
t:= 0;
for object_no:= object_no, object_no + 1
while object_no <= last
and object_no <= q <*temp gris*>
do
begin
t:= t + 1;
chars:= chars +
write(out_put, nl, if t mod 5 = 0 then 2 else 1) +
write_stn(out_put, stno(record.st_nmb(object_no), l)) +
write(out_put, sp, 3) +
write_geo_r(out_put, record.x(object_no), tpd_obs) +
write(out_put, sp, 3) +
write_geo_r(out_put, f2 * record.y(object_no), tpd_obs) +
write(out_put, sp, 3, <:<10>*:>, sp, 10+3) +
write_geo_r(out_put, W(2*object_no-1), tpd_obs) +
write(out_put, sp, 3) +
write_geo_r(out_put, W(2*object_no), tpd_obs) +
(if redf(object_no) < 1
then write(out_put, sp, 3, << -.dd'-dd>,
_ redf(object_no), sp, 3)
else write(out_put, sp, 3)) +
write(out_put, <:;:>);
nls:= nls + (if t mod 5 = 0 then 3 else 2);
end for object_no;
end for sub_no;
end else system(9, record.obs_kind_f extract 12,
_ <:<10>wrphkind:>);
end write mono obs+resi
else
write(out, <:<10>***write<95>ph obs kind/type error:>,
_ record.obs_kind_f extract 12, obs_type);
prvers:= 29 11 79 15 39;
write_ph:= nls;
end write_ph;
end
if warning.yes
(mode 0.yes
message write ph not ok
lookup write_ph)
end
finis
▶EOF◀