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__2 = 2;
19
20 /* ----------------------------------------------------------------------- */
21 /* UZCQNP */
22 /* ----------------------------------------------------------------------- */
23 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
24 /* ----------------------------------------------------------------------- */
uzcqnp_0_(int n__,integer * ncp,char * cp,integer * idx,char * cval,integer * in,integer * iu,ftnlen cp_len,ftnlen cval_len)25 /* Subroutine */ int uzcqnp_0_(int n__, integer *ncp, char *cp, integer *idx,
26 char *cval, integer *in, integer *iu, ftnlen cp_len, ftnlen cval_len)
27 {
28 /* Initialized data */
29
30 static char cparas[8*2] = "CXFMT " "CYFMT ";
31 static char cx[80*2] = "B "
32 " " "B "
33 " ";
34 static char cparal[40*2] = "****CXFMT "
35 "****CYFMT ";
36 static logical lfirst = TRUE_;
37
38 /* System generated locals */
39 address a__1[3];
40 integer i__1[3];
41
42 /* Builtin functions */
43 /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
44 s_copy(char *, char *, ftnlen, ftnlen);
45 integer s_wsue(cilist *), do_uio(integer *, char *, ftnlen), e_wsue(void),
46 s_rsue(cilist *), e_rsue(void);
47
48 /* Local variables */
49 static integer n, ios;
50 extern integer lenc_(char *, ftnlen);
51 static char cmsg[80];
52 extern logical lchreq_(char *, char *, ftnlen, ftnlen);
53 extern /* Subroutine */ int rlcget_(char *, char *, integer *, ftnlen,
54 ftnlen), msgdmp_(char *, char *, char *, ftnlen, ftnlen, ftnlen),
55 rtcget_(char *, char *, char *, integer *, ftnlen, ftnlen, ftnlen)
56 ;
57
58 /* Fortran I/O blocks */
59 static cilist io___8 = { 1, 0, 0, 0, 0 };
60 static cilist io___9 = { 1, 0, 1, 0, 0 };
61
62
63 /* / SHORT NAME / */
64 switch(n__) {
65 case 1: goto L_uzcqid;
66 case 2: goto L_uzcqcp;
67 case 3: goto L_uzcqcl;
68 case 4: goto L_uzcqvl;
69 case 5: goto L_uzcsvl;
70 case 6: goto L_uzcqin;
71 case 7: goto L_uzcsav;
72 case 8: goto L_uzcrst;
73 }
74
75 /* / LONG NAME / */
76 *ncp = 2;
77 return 0;
78 /* ----------------------------------------------------------------------- */
79
80 L_uzcqid:
81 for (n = 1; n <= 2; ++n) {
82 if (lchreq_(cp, cparas + (n - 1 << 3), cp_len, (ftnlen)8) || lchreq_(
83 cp, cparal + (n - 1) * 40, cp_len, (ftnlen)40)) {
84 *idx = n;
85 return 0;
86 }
87 /* L10: */
88 }
89 /* Writing concatenation */
90 i__1[0] = 11, a__1[0] = "PARAMETER \"";
91 i__1[1] = lenc_(cp, cp_len), a__1[1] = cp;
92 i__1[2] = 17, a__1[2] = "\" IS NOT DEFINED.";
93 s_cat(cmsg, a__1, i__1, &c__3, (ftnlen)80);
94 msgdmp_("E", "UZCQID", cmsg, (ftnlen)1, (ftnlen)6, (ftnlen)80);
95 return 0;
96 /* ----------------------------------------------------------------------- */
97
98 L_uzcqcp:
99 if (1 <= *idx && *idx <= 2) {
100 s_copy(cp, cparas + (*idx - 1 << 3), cp_len, (ftnlen)8);
101 } else {
102 msgdmp_("E", "UZCQCP", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
103 ftnlen)20);
104 }
105 return 0;
106 /* ----------------------------------------------------------------------- */
107
108 L_uzcqcl:
109 if (1 <= *idx && *idx <= 2) {
110 s_copy(cp, cparal + (*idx - 1) * 40, cp_len, (ftnlen)40);
111 } else {
112 msgdmp_("E", "UZCQCL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
113 ftnlen)20);
114 }
115 return 0;
116 /* ----------------------------------------------------------------------- */
117
118 L_uzcqvl:
119 if (lfirst) {
120 rtcget_("UZ", cparas, cx, &c__2, (ftnlen)2, (ftnlen)8, (ftnlen)80);
121 rlcget_(cparal, cx, &c__2, (ftnlen)40, (ftnlen)80);
122 lfirst = FALSE_;
123 }
124 if (1 <= *idx && *idx <= 2) {
125 s_copy(cval, cx + (*idx - 1) * 80, cval_len, (ftnlen)80);
126 } else {
127 msgdmp_("E", "UZCQVL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
128 ftnlen)20);
129 }
130 return 0;
131 /* ----------------------------------------------------------------------- */
132
133 L_uzcsvl:
134 if (lfirst) {
135 rtcget_("UZ", cparas, cx, &c__2, (ftnlen)2, (ftnlen)8, (ftnlen)80);
136 rlcget_(cparal, cx, &c__2, (ftnlen)40, (ftnlen)80);
137 lfirst = FALSE_;
138 }
139 if (1 <= *idx && *idx <= 2) {
140 s_copy(cx + (*idx - 1) * 80, cval, (ftnlen)80, cval_len);
141 } else {
142 msgdmp_("E", "UZCSVL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
143 ftnlen)20);
144 }
145 return 0;
146 /* ----------------------------------------------------------------------- */
147
148 L_uzcqin:
149 for (n = 1; n <= 2; ++n) {
150 if (lchreq_(cp, cparas + (n - 1 << 3), cp_len, (ftnlen)8) || lchreq_(
151 cp, cparal + (n - 1) * 40, cp_len, (ftnlen)40)) {
152 *in = n;
153 return 0;
154 }
155 /* L20: */
156 }
157 *in = 0;
158 return 0;
159 /* ----------------------------------------------------------------------- */
160
161 L_uzcsav:
162 io___8.ciunit = *iu;
163 ios = s_wsue(&io___8);
164 if (ios != 0) {
165 goto L100001;
166 }
167 ios = do_uio(&c__2, cx, (ftnlen)80);
168 if (ios != 0) {
169 goto L100001;
170 }
171 ios = e_wsue();
172 L100001:
173 if (ios != 0) {
174 msgdmp_("E", "UZCSAV", "IOSTAT IS NOT ZERO.", (ftnlen)1, (ftnlen)6, (
175 ftnlen)19);
176 }
177 return 0;
178 /* ----------------------------------------------------------------------- */
179
180 L_uzcrst:
181 io___9.ciunit = *iu;
182 ios = s_rsue(&io___9);
183 if (ios != 0) {
184 goto L100002;
185 }
186 ios = do_uio(&c__2, cx, (ftnlen)80);
187 if (ios != 0) {
188 goto L100002;
189 }
190 ios = e_rsue();
191 L100002:
192 if (ios != 0) {
193 msgdmp_("E", "UZCRST", "IOSTAT IS NOT ZERO.", (ftnlen)1, (ftnlen)6, (
194 ftnlen)19);
195 }
196 return 0;
197 } /* uzcqnp_ */
198
uzcqnp_(integer * ncp)199 /* Subroutine */ int uzcqnp_(integer *ncp)
200 {
201 return uzcqnp_0_(0, ncp, (char *)0, (integer *)0, (char *)0, (integer *)0,
202 (integer *)0, (ftnint)0, (ftnint)0);
203 }
204
uzcqid_(char * cp,integer * idx,ftnlen cp_len)205 /* Subroutine */ int uzcqid_(char *cp, integer *idx, ftnlen cp_len)
206 {
207 return uzcqnp_0_(1, (integer *)0, cp, idx, (char *)0, (integer *)0, (
208 integer *)0, cp_len, (ftnint)0);
209 }
210
uzcqcp_(integer * idx,char * cp,ftnlen cp_len)211 /* Subroutine */ int uzcqcp_(integer *idx, char *cp, ftnlen cp_len)
212 {
213 return uzcqnp_0_(2, (integer *)0, cp, idx, (char *)0, (integer *)0, (
214 integer *)0, cp_len, (ftnint)0);
215 }
216
uzcqcl_(integer * idx,char * cp,ftnlen cp_len)217 /* Subroutine */ int uzcqcl_(integer *idx, char *cp, ftnlen cp_len)
218 {
219 return uzcqnp_0_(3, (integer *)0, cp, idx, (char *)0, (integer *)0, (
220 integer *)0, cp_len, (ftnint)0);
221 }
222
uzcqvl_(integer * idx,char * cval,ftnlen cval_len)223 /* Subroutine */ int uzcqvl_(integer *idx, char *cval, ftnlen cval_len)
224 {
225 return uzcqnp_0_(4, (integer *)0, (char *)0, idx, cval, (integer *)0, (
226 integer *)0, (ftnint)0, cval_len);
227 }
228
uzcsvl_(integer * idx,char * cval,ftnlen cval_len)229 /* Subroutine */ int uzcsvl_(integer *idx, char *cval, ftnlen cval_len)
230 {
231 return uzcqnp_0_(5, (integer *)0, (char *)0, idx, cval, (integer *)0, (
232 integer *)0, (ftnint)0, cval_len);
233 }
234
uzcqin_(char * cp,integer * in,ftnlen cp_len)235 /* Subroutine */ int uzcqin_(char *cp, integer *in, ftnlen cp_len)
236 {
237 return uzcqnp_0_(6, (integer *)0, cp, (integer *)0, (char *)0, in, (
238 integer *)0, cp_len, (ftnint)0);
239 }
240
uzcsav_(integer * iu)241 /* Subroutine */ int uzcsav_(integer *iu)
242 {
243 return uzcqnp_0_(7, (integer *)0, (char *)0, (integer *)0, (char *)0, (
244 integer *)0, iu, (ftnint)0, (ftnint)0);
245 }
246
uzcrst_(integer * iu)247 /* Subroutine */ int uzcrst_(integer *iu)
248 {
249 return uzcqnp_0_(8, (integer *)0, (char *)0, (integer *)0, (char *)0, (
250 integer *)0, iu, (ftnint)0, (ftnint)0);
251 }
252
253