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
19 /* ----------------------------------------------------------------------- */
20 /* UEPQNP / UEPQID / UEPQCP / UEPQVL / UEPSVL */
21 /* ----------------------------------------------------------------------- */
22 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
23 /* ----------------------------------------------------------------------- */
uepqnp_0_(int n__,integer * ncp,char * cp,integer * idx,integer * itp,integer * ipara,integer * in,ftnlen cp_len)24 /* Subroutine */ int uepqnp_0_(int n__, integer *ncp, char *cp, integer *idx,
25 integer *itp, integer *ipara, integer *in, ftnlen cp_len)
26 {
27 /* Initialized data */
28
29 static char cparas[8*8] = "LTONE " "IPAT " "RLEV " "LBOUND "
30 "NLEV " "ITPAT " "ICOLOR1 " "ICOLOR2 ";
31 static integer itype[8] = { 2,1,3,2,1,1,1,1 };
32 static char cparal[40*8] = "ENABLE_AUTO_SHADE_LEVEL "
33 "DEFAULT_SHADE_PATTERN " "DEFAULT_SHADE_THRESH"
34 "OLD " "????LBOUND "
35 "****NLEV " "AUTO_SHADE_PATTERN "
36 " " "SHADE_COLOR_MIN "
37 "SHADE_COLOR_MAX ";
38
39 /* System generated locals */
40 address a__1[3];
41 integer i__1[3];
42
43 /* Builtin functions */
44 /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
45 s_copy(char *, char *, ftnlen, ftnlen);
46
47 /* Local variables */
48 static integer n, id;
49 extern integer lenc_(char *, ftnlen);
50 static char cmsg[80];
51 extern logical lchreq_(char *, char *, ftnlen, ftnlen);
52 extern /* Subroutine */ int ueiqid_(char *, integer *, ftnlen), uelqid_(
53 char *, integer *, ftnlen), msgdmp_(char *, char *, char *,
54 ftnlen, ftnlen, ftnlen), uerqid_(char *, integer *, ftnlen),
55 ueiqvl_(integer *, integer *), uelqvl_(integer *, integer *),
56 ueisvl_(integer *, integer *), uelsvl_(integer *, integer *),
57 uerqvl_(integer *, integer *), uersvl_(integer *, integer *);
58
59 /* / SHORT NAME / */
60 switch(n__) {
61 case 1: goto L_uepqid;
62 case 2: goto L_uepqcp;
63 case 3: goto L_uepqcl;
64 case 4: goto L_uepqit;
65 case 5: goto L_uepqvl;
66 case 6: goto L_uepsvl;
67 case 7: goto L_uepqin;
68 }
69
70 /* / LONG NAME / */
71 *ncp = 8;
72 return 0;
73 /* ----------------------------------------------------------------------- */
74
75 L_uepqid:
76 for (n = 1; n <= 8; ++n) {
77 if (lchreq_(cp, cparas + (n - 1 << 3), cp_len, (ftnlen)8) || lchreq_(
78 cp, cparal + (n - 1) * 40, cp_len, (ftnlen)40)) {
79 *idx = n;
80 return 0;
81 }
82 /* L10: */
83 }
84 /* Writing concatenation */
85 i__1[0] = 11, a__1[0] = "PARAMETER '";
86 i__1[1] = lenc_(cp, cp_len), a__1[1] = cp;
87 i__1[2] = 17, a__1[2] = "' IS NOT DEFINED.";
88 s_cat(cmsg, a__1, i__1, &c__3, (ftnlen)80);
89 msgdmp_("E", "UEPQID", cmsg, (ftnlen)1, (ftnlen)6, (ftnlen)80);
90 return 0;
91 /* ----------------------------------------------------------------------- */
92
93 L_uepqcp:
94 if (1 <= *idx && *idx <= 8) {
95 s_copy(cp, cparas + (*idx - 1 << 3), cp_len, (ftnlen)8);
96 } else {
97 msgdmp_("E", "UEPQCP", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
98 ftnlen)20);
99 }
100 return 0;
101 /* ----------------------------------------------------------------------- */
102
103 L_uepqcl:
104 if (1 <= *idx && *idx <= 8) {
105 s_copy(cp, cparal + (*idx - 1) * 40, cp_len, (ftnlen)40);
106 } else {
107 msgdmp_("E", "UEPQCL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
108 ftnlen)20);
109 }
110 return 0;
111 /* ----------------------------------------------------------------------- */
112
113 L_uepqit:
114 if (1 <= *idx && *idx <= 8) {
115 *itp = itype[*idx - 1];
116 } else {
117 msgdmp_("E", "UEPQIT", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
118 ftnlen)20);
119 }
120 return 0;
121 /* ----------------------------------------------------------------------- */
122
123 L_uepqvl:
124 if (1 <= *idx && *idx <= 8) {
125 if (itype[*idx - 1] == 1) {
126 ueiqid_(cparas + (*idx - 1 << 3), &id, (ftnlen)8);
127 ueiqvl_(&id, ipara);
128 } else if (itype[*idx - 1] == 2) {
129 uelqid_(cparas + (*idx - 1 << 3), &id, (ftnlen)8);
130 uelqvl_(&id, ipara);
131 } else if (itype[*idx - 1] == 3) {
132 uerqid_(cparas + (*idx - 1 << 3), &id, (ftnlen)8);
133 uerqvl_(&id, ipara);
134 }
135 } else {
136 msgdmp_("E", "UEPQVL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
137 ftnlen)20);
138 }
139 return 0;
140 /* ----------------------------------------------------------------------- */
141
142 L_uepsvl:
143 if (1 <= *idx && *idx <= 8) {
144 if (itype[*idx - 1] == 1) {
145 ueiqid_(cparas + (*idx - 1 << 3), &id, (ftnlen)8);
146 ueisvl_(&id, ipara);
147 } else if (itype[*idx - 1] == 2) {
148 uelqid_(cparas + (*idx - 1 << 3), &id, (ftnlen)8);
149 uelsvl_(&id, ipara);
150 } else if (itype[*idx - 1] == 3) {
151 uerqid_(cparas + (*idx - 1 << 3), &id, (ftnlen)8);
152 uersvl_(&id, ipara);
153 }
154 } else {
155 msgdmp_("E", "UEPSVL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
156 ftnlen)20);
157 }
158 return 0;
159 /* ----------------------------------------------------------------------- */
160
161 L_uepqin:
162 for (n = 1; n <= 8; ++n) {
163 if (lchreq_(cp, cparas + (n - 1 << 3), cp_len, (ftnlen)8) || lchreq_(
164 cp, cparal + (n - 1) * 40, cp_len, (ftnlen)40)) {
165 *in = n;
166 return 0;
167 }
168 /* L20: */
169 }
170 *in = 0;
171 return 0;
172 } /* uepqnp_ */
173
uepqnp_(integer * ncp)174 /* Subroutine */ int uepqnp_(integer *ncp)
175 {
176 return uepqnp_0_(0, ncp, (char *)0, (integer *)0, (integer *)0, (integer *
177 )0, (integer *)0, (ftnint)0);
178 }
179
uepqid_(char * cp,integer * idx,ftnlen cp_len)180 /* Subroutine */ int uepqid_(char *cp, integer *idx, ftnlen cp_len)
181 {
182 return uepqnp_0_(1, (integer *)0, cp, idx, (integer *)0, (integer *)0, (
183 integer *)0, cp_len);
184 }
185
uepqcp_(integer * idx,char * cp,ftnlen cp_len)186 /* Subroutine */ int uepqcp_(integer *idx, char *cp, ftnlen cp_len)
187 {
188 return uepqnp_0_(2, (integer *)0, cp, idx, (integer *)0, (integer *)0, (
189 integer *)0, cp_len);
190 }
191
uepqcl_(integer * idx,char * cp,ftnlen cp_len)192 /* Subroutine */ int uepqcl_(integer *idx, char *cp, ftnlen cp_len)
193 {
194 return uepqnp_0_(3, (integer *)0, cp, idx, (integer *)0, (integer *)0, (
195 integer *)0, cp_len);
196 }
197
uepqit_(integer * idx,integer * itp)198 /* Subroutine */ int uepqit_(integer *idx, integer *itp)
199 {
200 return uepqnp_0_(4, (integer *)0, (char *)0, idx, itp, (integer *)0, (
201 integer *)0, (ftnint)0);
202 }
203
uepqvl_(integer * idx,integer * ipara)204 /* Subroutine */ int uepqvl_(integer *idx, integer *ipara)
205 {
206 return uepqnp_0_(5, (integer *)0, (char *)0, idx, (integer *)0, ipara, (
207 integer *)0, (ftnint)0);
208 }
209
uepsvl_(integer * idx,integer * ipara)210 /* Subroutine */ int uepsvl_(integer *idx, integer *ipara)
211 {
212 return uepqnp_0_(6, (integer *)0, (char *)0, idx, (integer *)0, ipara, (
213 integer *)0, (ftnint)0);
214 }
215
uepqin_(char * cp,integer * in,ftnlen cp_len)216 /* Subroutine */ int uepqin_(char *cp, integer *in, ftnlen cp_len)
217 {
218 return uepqnp_0_(7, (integer *)0, cp, (integer *)0, (integer *)0, (
219 integer *)0, in, cp_len);
220 }
221
222