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 /* Table of constant values */
16
17 static real c_b2 = 1e-5f;
18
19 /* ----------------------------------------------------------------------- */
20 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
21 /* ----------------------------------------------------------------------- */
szsgcl_0_(int n__,real * tx0,real * ty0,real * tx1,real * ty1,real * tx,real * ty)22 /* Subroutine */ int szsgcl_0_(int n__, real *tx0, real *ty0, real *tx1, real
23 *ty1, real *tx, real *ty)
24 {
25 /* System generated locals */
26 real r__1, r__2, r__3, r__4;
27
28 /* Builtin functions */
29 double tan(doublereal), cos(doublereal), sin(doublereal), atan2(
30 doublereal, doublereal), r_sign(real *, real *), atan(doublereal),
31 acos(doublereal);
32
33 /* Local variables */
34 static real pi, tt, cs0, cs1, dx1, xla, xlm, txx, tyy, tan0, tan1;
35 static logical lmer;
36 extern real rfpi_(void);
37 static real alpha;
38 extern logical lreqa_(real *, real *, real *);
39 extern real szxmod_(real *);
40
41 switch(n__) {
42 case 1: goto L_szqgcy;
43 case 2: goto L_szqgcx;
44 }
45
46 pi = rfpi_();
47 txx = *tx0;
48 tyy = *ty0;
49 r__1 = abs(*ty0);
50 r__2 = pi / 2;
51 r__3 = abs(*ty1);
52 r__4 = pi / 2;
53 if (lreqa_(&r__1, &r__2, &c_b2) || lreqa_(&r__3, &r__4, &c_b2)) {
54 lmer = TRUE_;
55 } else {
56 tan0 = tan(*ty0);
57 tan1 = tan(*ty1);
58 if (tan0 == 0.f && tan1 == 0.f) {
59 xla = 0.f;
60 } else {
61 xla = atan2(tan1 * cos(*tx0) - tan0 * cos(*tx1), tan0 * sin(*tx1)
62 - tan1 * sin(*tx0));
63 }
64 r__1 = *tx1 - *tx0;
65 dx1 = szxmod_(&r__1);
66 r__1 = *tx0 + dx1 / 2 - xla;
67 xlm = szxmod_(&r__1);
68 cs0 = cos(*tx0 - xla);
69 cs1 = cos(*tx1 - xla);
70 if (abs(cs0) >= abs(cs1)) {
71 alpha = tan0 / cs0;
72 lmer = FALSE_;
73 } else if (abs(cs1) != 0.f) {
74 alpha = tan1 / cs1;
75 lmer = FALSE_;
76 } else {
77 lmer = TRUE_;
78 }
79 }
80 if (lmer) {
81 r__1 = pi / 2;
82 r__2 = *ty0 + *ty1;
83 tyy = r_sign(&r__1, &r__2);
84 }
85 return 0;
86 /* ----------------------------------------------------------------------- */
87
88 L_szqgcy:
89 if (lmer) {
90 *ty = tyy;
91 } else {
92 *ty = atan(alpha * cos(*tx - xla));
93 }
94 return 0;
95 /* ----------------------------------------------------------------------- */
96
97 L_szqgcx:
98 if (lmer) {
99 *tx = txx;
100 } else {
101 if (alpha == 0.f) {
102 *tx = txx;
103 } else {
104 tt = tan(*ty) / alpha;
105 if (abs(tt) >= 1.f) {
106 *tx = r_sign(&pi, &xlm) + xla;
107 } else {
108 r__1 = acos(tt);
109 *tx = r_sign(&r__1, &xlm) + xla;
110 }
111 }
112 }
113 return 0;
114 } /* szsgcl_ */
115
szsgcl_(real * tx0,real * ty0,real * tx1,real * ty1)116 /* Subroutine */ int szsgcl_(real *tx0, real *ty0, real *tx1, real *ty1)
117 {
118 return szsgcl_0_(0, tx0, ty0, tx1, ty1, (real *)0, (real *)0);
119 }
120
szqgcy_(real * tx,real * ty)121 /* Subroutine */ int szqgcy_(real *tx, real *ty)
122 {
123 return szsgcl_0_(1, (real *)0, (real *)0, (real *)0, (real *)0, tx, ty);
124 }
125
szqgcx_(real * ty,real * tx)126 /* Subroutine */ int szqgcx_(real *ty, real *tx)
127 {
128 return szsgcl_0_(2, (real *)0, (real *)0, (real *)0, (real *)0, tx, ty);
129 }
130
131