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