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 integer c__3 = 3;
18 static integer c__1 = 1;
19
20 /* ----------------------------------------------------------------------- */
21 /* UERQNP / UERQID / UERQCP / UERQVL / UERSVL */
22 /* ----------------------------------------------------------------------- */
23 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
24 /* ----------------------------------------------------------------------- */
uerqnp_0_(int n__,integer * ncp,char * cp,integer * idx,real * rpara,integer * in,ftnlen cp_len)25 /* Subroutine */ int uerqnp_0_(int n__, integer *ncp, char *cp, integer *idx,
26 real *rpara, integer *in, ftnlen cp_len)
27 {
28 /* Initialized data */
29
30 static char cparas[8*1] = "RLEV ";
31 static real rx[1] = { 0.f };
32 static char cparal[40*1] = "DEFAULT_SHADE_THRESHOLD ";
33 static logical lfirst = TRUE_;
34
35 /* System generated locals */
36 address a__1[3];
37 integer i__1[3];
38
39 /* Builtin functions */
40 /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
41 s_copy(char *, char *, ftnlen, ftnlen);
42
43 /* Local variables */
44 static integer n;
45 extern integer lenc_(char *, ftnlen);
46 static char cmsg[80];
47 extern logical lchreq_(char *, char *, ftnlen, ftnlen);
48 extern /* Subroutine */ int msgdmp_(char *, char *, char *, ftnlen,
49 ftnlen, ftnlen), rlrget_(char *, real *, integer *, ftnlen),
50 rtrget_(char *, char *, real *, integer *, ftnlen, ftnlen);
51
52 /* / SHORT NAME / */
53 switch(n__) {
54 case 1: goto L_uerqid;
55 case 2: goto L_uerqcp;
56 case 3: goto L_uerqcl;
57 case 4: goto L_uerqvl;
58 case 5: goto L_uersvl;
59 case 6: goto L_uerqin;
60 }
61
62 /* / LONG NAME / */
63 *ncp = 1;
64 return 0;
65 /* ----------------------------------------------------------------------- */
66
67 L_uerqid:
68 for (n = 1; n <= 1; ++n) {
69 if (lchreq_(cp, cparas + (n - 1 << 3), cp_len, (ftnlen)8) || lchreq_(
70 cp, cparal + (n - 1) * 40, cp_len, (ftnlen)40)) {
71 *idx = n;
72 return 0;
73 }
74 /* L10: */
75 }
76 /* Writing concatenation */
77 i__1[0] = 11, a__1[0] = "PARAMETER '";
78 i__1[1] = lenc_(cp, cp_len), a__1[1] = cp;
79 i__1[2] = 17, a__1[2] = "' IS NOT DEFINED.";
80 s_cat(cmsg, a__1, i__1, &c__3, (ftnlen)80);
81 msgdmp_("E", "UERQID", cmsg, (ftnlen)1, (ftnlen)6, (ftnlen)80);
82 return 0;
83 /* ----------------------------------------------------------------------- */
84
85 L_uerqcp:
86 if (1 <= *idx && *idx <= 1) {
87 s_copy(cp, cparas + (*idx - 1 << 3), cp_len, (ftnlen)8);
88 } else {
89 msgdmp_("E", "UERQCP", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
90 ftnlen)20);
91 }
92 return 0;
93 /* ----------------------------------------------------------------------- */
94
95 L_uerqcl:
96 if (1 <= *idx && *idx <= 1) {
97 s_copy(cp, cparal + (*idx - 1) * 40, cp_len, (ftnlen)40);
98 } else {
99 msgdmp_("E", "UERQCL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
100 ftnlen)20);
101 }
102 return 0;
103 /* ----------------------------------------------------------------------- */
104
105 L_uerqvl:
106 if (lfirst) {
107 rtrget_("UE", cparas, rx, &c__1, (ftnlen)2, (ftnlen)8);
108 rlrget_(cparal, rx, &c__1, (ftnlen)40);
109 lfirst = FALSE_;
110 }
111 if (1 <= *idx && *idx <= 1) {
112 *rpara = rx[*idx - 1];
113 } else {
114 msgdmp_("E", "UERQVL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
115 ftnlen)20);
116 }
117 return 0;
118 /* ----------------------------------------------------------------------- */
119
120 L_uersvl:
121 if (lfirst) {
122 rtrget_("UE", cparas, rx, &c__1, (ftnlen)2, (ftnlen)8);
123 rlrget_(cparal, rx, &c__1, (ftnlen)40);
124 lfirst = FALSE_;
125 }
126 if (1 <= *idx && *idx <= 1) {
127 rx[*idx - 1] = *rpara;
128 } else {
129 msgdmp_("E", "UERSVL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
130 ftnlen)20);
131 }
132 return 0;
133 /* ----------------------------------------------------------------------- */
134
135 L_uerqin:
136 for (n = 1; n <= 1; ++n) {
137 if (lchreq_(cp, cparas + (n - 1 << 3), cp_len, (ftnlen)8) || lchreq_(
138 cp, cparal + (n - 1) * 40, cp_len, (ftnlen)40)) {
139 *in = n;
140 return 0;
141 }
142 /* L20: */
143 }
144 *in = 0;
145 return 0;
146 } /* uerqnp_ */
147
uerqnp_(integer * ncp)148 /* Subroutine */ int uerqnp_(integer *ncp)
149 {
150 return uerqnp_0_(0, ncp, (char *)0, (integer *)0, (real *)0, (integer *)0,
151 (ftnint)0);
152 }
153
uerqid_(char * cp,integer * idx,ftnlen cp_len)154 /* Subroutine */ int uerqid_(char *cp, integer *idx, ftnlen cp_len)
155 {
156 return uerqnp_0_(1, (integer *)0, cp, idx, (real *)0, (integer *)0,
157 cp_len);
158 }
159
uerqcp_(integer * idx,char * cp,ftnlen cp_len)160 /* Subroutine */ int uerqcp_(integer *idx, char *cp, ftnlen cp_len)
161 {
162 return uerqnp_0_(2, (integer *)0, cp, idx, (real *)0, (integer *)0,
163 cp_len);
164 }
165
uerqcl_(integer * idx,char * cp,ftnlen cp_len)166 /* Subroutine */ int uerqcl_(integer *idx, char *cp, ftnlen cp_len)
167 {
168 return uerqnp_0_(3, (integer *)0, cp, idx, (real *)0, (integer *)0,
169 cp_len);
170 }
171
uerqvl_(integer * idx,real * rpara)172 /* Subroutine */ int uerqvl_(integer *idx, real *rpara)
173 {
174 return uerqnp_0_(4, (integer *)0, (char *)0, idx, rpara, (integer *)0, (
175 ftnint)0);
176 }
177
uersvl_(integer * idx,real * rpara)178 /* Subroutine */ int uersvl_(integer *idx, real *rpara)
179 {
180 return uerqnp_0_(5, (integer *)0, (char *)0, idx, rpara, (integer *)0, (
181 ftnint)0);
182 }
183
uerqin_(char * cp,integer * in,ftnlen cp_len)184 /* Subroutine */ int uerqin_(char *cp, integer *in, ftnlen cp_len)
185 {
186 return uerqnp_0_(6, (integer *)0, cp, (integer *)0, (real *)0, in, cp_len)
187 ;
188 }
189
190