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__5 = 5;
19
20 /* ----------------------------------------------------------------------- */
21 /* UEIQNP / UEIQID / UEIQCP / UEIQVL / UEISVL */
22 /* ----------------------------------------------------------------------- */
23 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
24 /* ----------------------------------------------------------------------- */
ueiqnp_0_(int n__,integer * ncp,char * cp,integer * idx,integer * ipara,integer * in,ftnlen cp_len)25 /* Subroutine */ int ueiqnp_0_(int n__, integer *ncp, char *cp, integer *idx,
26 integer *ipara, integer *in, ftnlen cp_len)
27 {
28 /* Initialized data */
29
30 static char cparas[8*5] = "IPAT " "NLEV " "ITPAT " "ICOLOR1 "
31 "ICOLOR2 ";
32 static integer ix[5] = { 1201,12,999,15,94 };
33 static char cparal[40*5] = "DEFAULT_SHADE_PATTERN "
34 "****NLEV " "AUTO_SHADE_PATTERN "
35 " " "SHADE_COLOR_MIN "
36 "SHADE_COLOR_MAX ";
37 static logical lfirst = TRUE_;
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;
49 extern integer lenc_(char *, ftnlen);
50 static char cmsg[80];
51 extern logical lchreq_(char *, char *, ftnlen, ftnlen);
52 extern /* Subroutine */ int msgdmp_(char *, char *, char *, ftnlen,
53 ftnlen, ftnlen), rliget_(char *, integer *, integer *, ftnlen),
54 rtiget_(char *, char *, integer *, integer *, ftnlen, ftnlen);
55
56 /* / SHORT NAME / */
57 switch(n__) {
58 case 1: goto L_ueiqid;
59 case 2: goto L_ueiqcp;
60 case 3: goto L_ueiqcl;
61 case 4: goto L_ueiqvl;
62 case 5: goto L_ueisvl;
63 case 6: goto L_ueiqin;
64 }
65
66 /* / LONG NAME / */
67 *ncp = 5;
68 return 0;
69 /* ----------------------------------------------------------------------- */
70
71 L_ueiqid:
72 for (n = 1; n <= 5; ++n) {
73 if (lchreq_(cp, cparas + (n - 1 << 3), cp_len, (ftnlen)8) || lchreq_(
74 cp, cparal + (n - 1) * 40, cp_len, (ftnlen)40)) {
75 *idx = n;
76 return 0;
77 }
78 /* L10: */
79 }
80 /* Writing concatenation */
81 i__1[0] = 11, a__1[0] = "PARAMETER '";
82 i__1[1] = lenc_(cp, cp_len), a__1[1] = cp;
83 i__1[2] = 17, a__1[2] = "' IS NOT DEFINED.";
84 s_cat(cmsg, a__1, i__1, &c__3, (ftnlen)80);
85 msgdmp_("E", "UEIQID", cmsg, (ftnlen)1, (ftnlen)6, (ftnlen)80);
86 return 0;
87 /* ----------------------------------------------------------------------- */
88
89 L_ueiqcp:
90 if (1 <= *idx && *idx <= 5) {
91 s_copy(cp, cparas + (*idx - 1 << 3), cp_len, (ftnlen)8);
92 } else {
93 msgdmp_("E", "UEIQCP", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
94 ftnlen)20);
95 }
96 return 0;
97 /* ----------------------------------------------------------------------- */
98
99 L_ueiqcl:
100 if (1 <= *idx && *idx <= 5) {
101 s_copy(cp, cparal + (*idx - 1) * 40, cp_len, (ftnlen)40);
102 } else {
103 msgdmp_("E", "UEIQCL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
104 ftnlen)20);
105 }
106 return 0;
107 /* ----------------------------------------------------------------------- */
108
109 L_ueiqvl:
110 if (lfirst) {
111 rtiget_("UE", cparas, ix, &c__5, (ftnlen)2, (ftnlen)8);
112 rliget_(cparal, ix, &c__5, (ftnlen)40);
113 lfirst = FALSE_;
114 }
115 if (1 <= *idx && *idx <= 5) {
116 *ipara = ix[*idx - 1];
117 } else {
118 msgdmp_("E", "UEIQVL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
119 ftnlen)20);
120 }
121 return 0;
122 /* ----------------------------------------------------------------------- */
123
124 L_ueisvl:
125 if (lfirst) {
126 rtiget_("UE", cparas, ix, &c__5, (ftnlen)2, (ftnlen)8);
127 rliget_(cparal, ix, &c__5, (ftnlen)40);
128 lfirst = FALSE_;
129 }
130 if (1 <= *idx && *idx <= 5) {
131 ix[*idx - 1] = *ipara;
132 } else {
133 msgdmp_("E", "UEISVL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
134 ftnlen)20);
135 }
136 return 0;
137 /* ----------------------------------------------------------------------- */
138
139 L_ueiqin:
140 for (n = 1; n <= 5; ++n) {
141 if (lchreq_(cp, cparas + (n - 1 << 3), cp_len, (ftnlen)8) || lchreq_(
142 cp, cparal + (n - 1) * 40, cp_len, (ftnlen)40)) {
143 *in = n;
144 return 0;
145 }
146 /* L20: */
147 }
148 *in = 0;
149 return 0;
150 } /* ueiqnp_ */
151
ueiqnp_(integer * ncp)152 /* Subroutine */ int ueiqnp_(integer *ncp)
153 {
154 return ueiqnp_0_(0, ncp, (char *)0, (integer *)0, (integer *)0, (integer *
155 )0, (ftnint)0);
156 }
157
ueiqid_(char * cp,integer * idx,ftnlen cp_len)158 /* Subroutine */ int ueiqid_(char *cp, integer *idx, ftnlen cp_len)
159 {
160 return ueiqnp_0_(1, (integer *)0, cp, idx, (integer *)0, (integer *)0,
161 cp_len);
162 }
163
ueiqcp_(integer * idx,char * cp,ftnlen cp_len)164 /* Subroutine */ int ueiqcp_(integer *idx, char *cp, ftnlen cp_len)
165 {
166 return ueiqnp_0_(2, (integer *)0, cp, idx, (integer *)0, (integer *)0,
167 cp_len);
168 }
169
ueiqcl_(integer * idx,char * cp,ftnlen cp_len)170 /* Subroutine */ int ueiqcl_(integer *idx, char *cp, ftnlen cp_len)
171 {
172 return ueiqnp_0_(3, (integer *)0, cp, idx, (integer *)0, (integer *)0,
173 cp_len);
174 }
175
ueiqvl_(integer * idx,integer * ipara)176 /* Subroutine */ int ueiqvl_(integer *idx, integer *ipara)
177 {
178 return ueiqnp_0_(4, (integer *)0, (char *)0, idx, ipara, (integer *)0, (
179 ftnint)0);
180 }
181
ueisvl_(integer * idx,integer * ipara)182 /* Subroutine */ int ueisvl_(integer *idx, integer *ipara)
183 {
184 return ueiqnp_0_(5, (integer *)0, (char *)0, idx, ipara, (integer *)0, (
185 ftnint)0);
186 }
187
ueiqin_(char * cp,integer * in,ftnlen cp_len)188 /* Subroutine */ int ueiqin_(char *cp, integer *in, ftnlen cp_len)
189 {
190 return ueiqnp_0_(6, (integer *)0, cp, (integer *)0, (integer *)0, in,
191 cp_len);
192 }
193
194