1 globe: proc;
2
3
4
5
6
7 dcl (i, j, k, l, m, n) fixed bin,
8 nelts fixed bin,
9 toomany fixed bin int static init (1000),
10 ap ptr,
11 al fixed bin,
12 bchr char (al) unaligned based (ap),
13 ec fixed bin,
14 world_ptr ptr,
15 temp_ptr ptr;
16
17 dcl (fa1, fa2, fa3, fa4, fa5, fa6, fa7, fa8, fa9) float bin,
18 (cosa, cosp, cost, sina, sint, sinp) float bin,
19 (x0, y0, z0) float bin,
20 z float bin,
21 exit fixed bin init (0),
22 mode fixed bin init (1),
23 line fixed bin init (0),
24 (ix, iy) fixed bin,
25 (delx, dely) fixed bin,
26 (xprev, yprev) fixed bin,
27 icentr fixed bin init (0),
28 jcentr fixed bin init (0),
29 erase fixed bin init (0),
30 TINY fixed bin init (2),
31 rad float bin,
32 radus float bin,
33 factor float bin init (1.745329e-2),
34 frac float bin init (0.0e0);
35
36 dcl alpha float bin init (0.0e0),
37 phi float bin init (42.36058333e0),
38 theta float bin init (288.9063333e0),
39 irad fixed bin,
40 radius float bin init (1.0e0);
41
42 dcl gui_$ginit_ entry,
43 gui_$gcirc_ entry (fixed bin, fixed bin),
44 gui_$gvec_ entry (fixed bin, fixed bin, fixed bin),
45 gui_$gsps_ entry (fixed bin, fixed bin, fixed bin),
46 gui_$gdisp_ entry,
47 gui_$grmv_ entry,
48 gui_$geras_ entry;
49
50 dcl 1 worldbin based (world_ptr) aligned,
51 2 input (0:6048) fixed bin;
52
53 dcl temp fixed bin;
54
55 dcl 1 component based (temp_ptr) aligned,
56 2 x fixed bin (11) unal,
57 2 y fixed bin (11) unal,
58 2 z fixed bin (11) unal;
59
60 dcl (addr, sin, cos, abs, null) builtin;
61 dcl name condition;
62 dcl sysin file;
63
64 dcl cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin),
65 hcs_$make_ptr entry (ptr, char (*) aligned, char (*) aligned, ptr, fixed bin),
66 ioa_ ext entry options (variable),
67 com_err_ ext entry options (variable),
68 hcs_$terminate_noname ext entry (ptr, fixed bin);
69
70
71
72 temp_ptr = addr (temp);
73 call hcs_$make_ptr (null, "world.bin", "", world_ptr, ec);
74 if world_ptr = null then do;
75 er: call com_err_ (ec, "globe", "world.bin");
76 return;
77 end;
78
79 call gui_$ginit_;
80
81 inform: mode = 1;
82 call ioa_ ("The following is an example of a complete input line:");
83 call ioa_ (" phi = ^f, theta = ^f, alpha = ^f, radius = ^f;", phi, theta, alpha, radius);
84 call ioa_ ("(phi and theta are latitude and longitude of the display center, and");
85 call ioa_ (" alpha is rotation around the center. Radius 1.0 is full screen.)");
86 call ioa_ ("To find the values of parameters, type:");
87 call ioa_ (" mode = 0;");
88 call ioa_ ("To exit from the program, type:");
89 call ioa_ (" exit = 1;");
90
91 start: call ioa_ ("^/Enter input data");
92 on name (sysin) begin;
93 call ioa_ ("Illegal input.");
94 go to inform;
95 end;
96
97 get data (phi, theta, alpha, radius, mode, exit);
98
99 if exit = 1 then do;
100 call hcs_$terminate_noname (world_ptr, ec);
101 return;
102 end;
103 if mode = 0 then go to inform;
104 if erase = 0 then call gui_$geras_;
105
106 if phi < 0 then phi = 360.0e0 - phi;
107 if theta < 0 then theta = 360.0e0 - theta;
108
109 sinp = sin (phi * factor);
110 cosp = cos (phi * factor);
111 sint = sin (theta * factor);
112 cost = cos (theta * factor);
113 sina = sin (alpha * factor);
114 cosa = cos (alpha * factor);
115
116 fa1 = cost * cosa + sinp * sina * sint;
117 fa2 = -cosp * sina;
118 fa3 = cost * sina * sinp - sint * cosa;
119 fa4 = cost * sina - sint * cosa * sinp;
120 fa5 = cosp * cosa;
121 fa6 = -cost * cosa * sinp - sint * sina;
122 fa7 = sint * cosp;
123 fa8 = sinp;
124 fa9 = cost * cosp;
125 radus = radius * 512.e0;
126 irad = radus + 0.5e0;
127 line = 0;
128 rad = radus;
129
130 call gui_$gsps_ (0, irad, 0);
131 call gui_$gcirc_ (0, -irad);
132
133 call gui_$gdisp_;
134 call gui_$grmv_;
135 nelts = 0;
136 do i = 6048 to 1 by -1;
137
138 if input (i) = -1 then go to done;
139 if input (i) = 0 then go to linend;
140
141 temp = input (i);
142
143 z0 = component.z / 1.e3 - 1.0e0;
144 y0 = component.y / 1.e3 - 1.0e0;
145 x0 = component.x / 1.e3 - 1.0e0;
146
147 z = fa7 * x0 + fa8 * y0 + fa9 * z0;
148 if z < frac then go to linend;
149
150 if mode ^= 2 then go to ster;
151 rad = radus / (z + 1.0e0);
152
153 ster: ix = rad * (fa1 * x0 + fa2 * y0 + fa3 * z0);
154 iy = rad * (fa4 * x0 + fa5 * y0 + fa6 * z0);
155 ix = ix + icentr;
156 iy = iy + jcentr;
157
158 if abs (ix) > 1.e3 then go to linend;
159 if abs (iy) > 1.e3 then go to linend;
160
161 if line = 0 then go to newlin;
162
163 delx = ix - xprev;
164 dely = iy - yprev;
165
166 if abs (delx) < TINY then if abs (dely) < TINY then go to loop;
167
168 line = line + 1;
169
170 call gui_$gvec_ (delx, dely, 0);
171 nelts = nelts + 1;
172 go to more;
173
174 newlin: call gui_$gsps_ (ix, iy, 0);
175 nelts = nelts + 1;
176
177 line = 1;
178
179 more: xprev = ix;
180 yprev = iy;
181
182 go to loop;
183
184 linend: if line = 1 then do;
185 call gui_$gvec_ (1, 1, 0);
186 nelts = nelts + 1;
187 end;
188 if nelts > toomany then do;
189 call gui_$gdisp_;
190 call gui_$grmv_;
191 nelts = 0;
192 end;
193
194 line = 0;
195
196 loop: end;
197
198 done: call gui_$gsps_ (0, 512, 0);
199 call gui_$gdisp_;
200
201 call gui_$grmv_;
202
203 go to start;
204
205 end globe;