1 /* -- translated by f2c (version 20100827).
2 You must link the resulting object file with libf2c:
3 on Microsoft Windows system, link with libf2c.lib;
4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm
5 or, if you install libf2c.a in a standard place, with -lf2c -lm
6 -- in that order, at the end of the command line, as in
7 cc *.o -lf2c -lm
8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
9
10 http://www.netlib.org/f2c/libf2c.zip
11 */
12
13 #include "libtinyf2c.h"
14
15 /* Common Block Declarations */
16
17 struct {
18 logical lchaz;
19 } szbls3_;
20
21 #define szbls3_1 szbls3_
22
23 /* Table of constant values */
24
25 static real c_b35 = 180.f;
26 static integer c__0 = 0;
27
28 /* ----------------------------------------------------------------------- */
29 /* PLOT ROUTINE ON VC (ENCODING TEXT) */
30 /* ----------------------------------------------------------------------- */
31 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
32 /* ----------------------------------------------------------------------- */
szoplc_0_(int n__,real * vx,real * vy,char * ch,real * h__,ftnlen ch_len)33 /* Subroutine */ int szoplc_0_(int n__, real *vx, real *vy, char *ch, real *
34 h__, ftnlen ch_len)
35 {
36 /* Initialized data */
37
38 static logical lcset = FALSE_;
39
40 /* System generated locals */
41 integer i__1;
42 real r__1, r__2;
43
44 /* Builtin functions */
45 double sqrt(doublereal), atan2(doublereal, doublereal), r_mod(real *,
46 real *);
47 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
48
49 /* Local variables */
50 static integer n;
51 static real r__, fc;
52 static integer nc;
53 static real fl, wc, xi, hz, wl;
54 static integer nt;
55 static real xl, xw, xl0, vx0, vy0, vx1, vy1, fwc;
56 static char chz[80];
57 static real cwl, xlc;
58 static integer ith;
59 static real vxc, vyc, vxt[400], vyt[400];
60 extern real rr2d_(real *);
61 extern integer lenc_(char *, ftnlen);
62 static real ffct;
63 static integer nchz;
64 static real wxch, wych;
65 static integer irot;
66 static logical lrot, lchar, lbuff;
67 static integer nbuff;
68 static real rbuff;
69 static integer index;
70 static logical lcput, lcurv;
71 static real rcurv;
72 extern /* Subroutine */ int sgiget_(char *, integer *, ftnlen), sglget_(
73 char *, logical *, ftnlen), msgdmp_(char *, char *, char *,
74 ftnlen, ftnlen, ftnlen), sgrget_(char *, real *, ftnlen), szclld_(
75 void);
76 static integer indexy, indexz;
77 extern /* Subroutine */ int szplld_(real *, real *), szopld_(void),
78 szmvld_(real *, real *), szqidx_(integer *), szsidx_(integer *),
79 sztxcl_(void), sztxop_(real *, integer *, integer *, integer *),
80 szqtxw_(char *, integer *, real *, real *, ftnlen), sztxzv_(real *
81 , real *, char *, ftnlen);
82
83 switch(n__) {
84 case 1: goto L_szmvlc;
85 case 2: goto L_szpllc;
86 case 3: goto L_szcllc;
87 case 4: goto L_szschz;
88 case 5: goto L_szqchz;
89 case 6: goto L_szcrst;
90 }
91
92 /* / OPEN DASH LINE & CHARACTER SEGMENT / */
93 lchar = szbls3_1.lchaz && lcset;
94 if (lchar) {
95 sglget_("LROT", &lrot, (ftnlen)4);
96 sgiget_("IROT", &irot, (ftnlen)4);
97 sgrget_("FWC", &fwc, (ftnlen)3);
98 sgrget_("CWL", &cwl, (ftnlen)3);
99 sgrget_("FFCT", &ffct, (ftnlen)4);
100 sgiget_("INDEXC", &index, (ftnlen)6);
101 sglget_("LBUFF", &lbuff, (ftnlen)5);
102 sgiget_("NBUFF", &nbuff, (ftnlen)5);
103 sgrget_("RBUFF", &rbuff, (ftnlen)5);
104 sglget_("LCURV", &lcurv, (ftnlen)5);
105 sgrget_("RCURV", &rcurv, (ftnlen)5);
106 if (! (fwc >= 1.f)) {
107 msgdmp_("E", "SZOPLC", "PARAMETER 'FWC' IS LESS THAN 1.", (ftnlen)
108 1, (ftnlen)6, (ftnlen)31);
109 }
110 if (! (cwl > 0.f)) {
111 msgdmp_("E", "SZOPLC", "PARAMETER 'CWL' IS LESS THAN 0.", (ftnlen)
112 1, (ftnlen)6, (ftnlen)31);
113 }
114 if (! (0.f < ffct && ffct < 1.f)) {
115 msgdmp_("E", "SZOPLC", "PARAMETER 'FFCT' IS NOT IN THE RANGE OF "
116 "(0,1).", (ftnlen)1, (ftnlen)6, (ftnlen)46);
117 }
118 if (! (1 <= nbuff && nbuff <= 400)) {
119 msgdmp_("E", "SZOPLC", "PARAMETER 'NBUFF' IS NOT IN THE RANGE OF"
120 " (1,MAXTMP).", (ftnlen)1, (ftnlen)6, (ftnlen)52);
121 }
122 if (! (0.f < rbuff && rbuff < 1.f)) {
123 msgdmp_("E", "SZOPLC", "PARAMETER 'RBUFF' IS NOT IN THE RANGE OF"
124 " (0,1).", (ftnlen)1, (ftnlen)6, (ftnlen)47);
125 }
126 if (! (0.f < rcurv && rcurv < fwc)) {
127 msgdmp_("E", "SZOPLC", "PARAMETER 'RCURV' IS NOT IN THE RANGE OF"
128 " (0,FWC).", (ftnlen)1, (ftnlen)6, (ftnlen)49);
129 }
130 szqtxw_(chz, &nchz, &wxch, &wych, (ftnlen)80);
131 fc = wxch * fwc;
132 fl = cwl;
133 wc = hz * fc;
134 wl = hz * fl;
135 xw = wl + wc;
136 xi = wl * ffct;
137 }
138 if (lbuff) {
139 nt = 0;
140 }
141 szopld_();
142 return 0;
143 /* ----------------------------------------------------------------------- */
144
145 L_szmvlc:
146 /* / PEN-UP MOVE / */
147 if (lbuff && nt != 0) {
148 i__1 = nt;
149 for (n = 1; n <= i__1; ++n) {
150 szplld_(&vxt[n - 1], &vyt[n - 1]);
151 /* L5: */
152 }
153 nt = 0;
154 }
155 szmvld_(vx, vy);
156 vx0 = *vx;
157 vy0 = *vy;
158 xl0 = xi;
159 return 0;
160 /* ----------------------------------------------------------------------- */
161
162 L_szpllc:
163 /* / PEN-DOWN MOVE / */
164 if (! lchar) {
165 /* / THERE IS NO TEXT IN THE CYCLE / */
166 szplld_(vx, vy);
167 } else {
168 /* / THERE EXISTS A TEXT IN THE CYCLE / */
169 L10:
170 /* Computing 2nd power */
171 r__1 = *vx - vx0;
172 /* Computing 2nd power */
173 r__2 = *vy - vy0;
174 r__ = sqrt(r__1 * r__1 + r__2 * r__2);
175 if (r__ == 0.f) {
176 return 0;
177 }
178 xl = xl0 + r__;
179 if (xl < wl) {
180 /* / CURRENET POSITION IS IN THE LINE PART / */
181 szplld_(vx, vy);
182 vx0 = *vx;
183 vy0 = *vy;
184 xl0 = xl;
185 } else if (xl < xw) {
186 /* / CURRENT POSITION IS IN THE CHARCTER PART / */
187 if (xl0 < wl) {
188 /* / LAST POSITION WAS IN THE LINE PART / */
189 vx1 = vx0 + (*vx - vx0) * (wl - xl0) / r__;
190 vy1 = vy0 + (*vy - vy0) * (wl - xl0) / r__;
191 szplld_(&vx1, &vy1);
192 }
193 vx0 = *vx;
194 vy0 = *vy;
195 xl0 = xl;
196 if (lbuff) {
197 /* / BUFFERRING / */
198 ++nt;
199 vxt[nt - 1] = *vx;
200 vyt[nt - 1] = *vy;
201 if (nt == nbuff) {
202 i__1 = nt;
203 for (n = 1; n <= i__1; ++n) {
204 szplld_(&vxt[n - 1], &vyt[n - 1]);
205 /* L15: */
206 }
207 xl0 = wl * rbuff;
208 nt = 0;
209 }
210 }
211 } else {
212 /* / CURRENT POSITION IS IN THE NEXT CYCLE / */
213 if (xl0 < wl) {
214 /* / LAST POSITION WAS IN THE LINE PART / */
215 vx1 = vx0 + (*vx - vx0) * (wl - xl0) / r__;
216 vy1 = vy0 + (*vy - vy0) * (wl - xl0) / r__;
217 szplld_(&vx1, &vy1);
218 }
219 /* / POSITION OF TEXT / */
220 vx0 += (*vx - vx0) * (xw - xl0) / r__;
221 vy0 += (*vy - vy0) * (xw - xl0) / r__;
222 vxc = (vx0 + vx1) / 2;
223 vyc = (vy0 + vy1) / 2;
224 lcput = TRUE_;
225 if (lbuff && lcurv) {
226 /* / CHECK CURVATURE (RUN PATH) / */
227 /* Computing 2nd power */
228 r__1 = vx1 - vx0;
229 /* Computing 2nd power */
230 r__2 = vy1 - vy0;
231 xlc = sqrt(r__1 * r__1 + r__2 * r__2);
232 if (xlc <= hz * wxch * rcurv) {
233 i__1 = nt;
234 for (n = 1; n <= i__1; ++n) {
235 szplld_(&vxt[n - 1], &vyt[n - 1]);
236 /* L20: */
237 }
238 xl0 = wl * rbuff;
239 nt = 0;
240 szplld_(vx, vy);
241 vx0 = *vx;
242 vy0 = *vy;
243 lcput = FALSE_;
244 }
245 }
246 if (lcput) {
247 /* / ROTATION OPTION / */
248 if (lrot) {
249 ith = irot;
250 } else {
251 r__2 = atan2(vy0 - vy1, vx0 - vx1);
252 r__1 = rr2d_(&r__2) + 270;
253 ith = r_mod(&r__1, &c_b35) - 90;
254 }
255 /* / WRITE TEXT / */
256 szqidx_(&indexz);
257 if (index == 0) {
258 indexy = indexz;
259 } else {
260 indexy = index;
261 }
262 szclld_();
263 /* CALL SGTXZV(VXC,VYC,CHZ,HZ,ITH,0,INDEXY) */
264 sztxop_(&hz, &ith, &c__0, &indexy);
265 sztxzv_(&vxc, &vyc, chz, (ftnlen)80);
266 sztxcl_();
267 szsidx_(&indexz);
268 szopld_();
269 szmvld_(&vx0, &vy0);
270 xl0 = 0.f;
271 nt = 0;
272 }
273 }
274 if (! (xl < xw)) {
275 goto L10;
276 }
277 }
278 return 0;
279 /* ----------------------------------------------------------------------- */
280
281 L_szcllc:
282 /* / CLOSE DASHCHAR SEGMENT / */
283 if (lbuff && nt != 0) {
284 i__1 = nt;
285 for (n = 1; n <= i__1; ++n) {
286 szplld_(&vxt[n - 1], &vyt[n - 1]);
287 /* L25: */
288 }
289 }
290 szclld_();
291 return 0;
292 /* ----------------------------------------------------------------------- */
293
294 L_szschz:
295 nc = lenc_(ch, ch_len);
296 s_copy(chz, ch, (ftnlen)80, nc);
297 hz = *h__;
298 lcset = TRUE_;
299 return 0;
300 /* ----------------------------------------------------------------------- */
301
302 L_szqchz:
303 if (! lcset) {
304 msgdmp_("E", "SZQCHZ", "TEXT HAS NOT BEEN SET YET.", (ftnlen)1, (
305 ftnlen)6, (ftnlen)26);
306 }
307 s_copy(ch, chz, ch_len, (ftnlen)80);
308 *h__ = hz;
309 return 0;
310 /* ----------------------------------------------------------------------- */
311
312 L_szcrst:
313 lcset = FALSE_;
314 return 0;
315 } /* szoplc_ */
316
szoplc_(void)317 /* Subroutine */ int szoplc_(void)
318 {
319 return szoplc_0_(0, (real *)0, (real *)0, (char *)0, (real *)0, (ftnint)0)
320 ;
321 }
322
szmvlc_(real * vx,real * vy)323 /* Subroutine */ int szmvlc_(real *vx, real *vy)
324 {
325 return szoplc_0_(1, vx, vy, (char *)0, (real *)0, (ftnint)0);
326 }
327
szpllc_(real * vx,real * vy)328 /* Subroutine */ int szpllc_(real *vx, real *vy)
329 {
330 return szoplc_0_(2, vx, vy, (char *)0, (real *)0, (ftnint)0);
331 }
332
szcllc_(void)333 /* Subroutine */ int szcllc_(void)
334 {
335 return szoplc_0_(3, (real *)0, (real *)0, (char *)0, (real *)0, (ftnint)0)
336 ;
337 }
338
szschz_(char * ch,real * h__,ftnlen ch_len)339 /* Subroutine */ int szschz_(char *ch, real *h__, ftnlen ch_len)
340 {
341 return szoplc_0_(4, (real *)0, (real *)0, ch, h__, ch_len);
342 }
343
szqchz_(char * ch,real * h__,ftnlen ch_len)344 /* Subroutine */ int szqchz_(char *ch, real *h__, ftnlen ch_len)
345 {
346 return szoplc_0_(5, (real *)0, (real *)0, ch, h__, ch_len);
347 }
348
szcrst_(void)349 /* Subroutine */ int szcrst_(void)
350 {
351 return szoplc_0_(6, (real *)0, (real *)0, (char *)0, (real *)0, (ftnint)0)
352 ;
353 }
354
355