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__1 = 1;
18
19 /* ----------------------------------------------------------------------- */
20 /* UMPGET / UMPSET / UMPSTX */
21 /* ----------------------------------------------------------------------- */
22 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
23 /* ----------------------------------------------------------------------- */
umpget_0_(int n__,char * cp,integer * ipara,ftnlen cp_len)24 /* Subroutine */ int umpget_0_(int n__, char *cp, integer *ipara, ftnlen
25 cp_len)
26 {
27 static char cl[40];
28 static integer ip;
29 static char cx[8];
30 static integer it, idx;
31 extern /* Subroutine */ int rliget_(char *, integer *, integer *, ftnlen),
32 umiqid_(char *, integer *, ftnlen), rllget_(char *, integer *,
33 integer *, ftnlen), umlqid_(char *, integer *, ftnlen), rtiget_(
34 char *, char *, integer *, integer *, ftnlen, ftnlen), umpqid_(
35 char *, integer *, ftnlen), rlrget_(char *, integer *, integer *,
36 ftnlen), umpqcl_(integer *, char *, ftnlen), rtlget_(char *, char
37 *, integer *, integer *, ftnlen, ftnlen), umrqid_(char *, integer
38 *, ftnlen), umpqcp_(integer *, char *, ftnlen), rtrget_(char *,
39 char *, integer *, integer *, ftnlen, ftnlen), umpqit_(integer *,
40 integer *), umisvl_(integer *, integer *), umlsvl_(integer *,
41 integer *), umpqvl_(integer *, integer *), umpsvl_(integer *,
42 integer *), umrsvl_(integer *, integer *);
43
44 switch(n__) {
45 case 1: goto L_umpset;
46 case 2: goto L_umpstx;
47 }
48
49 umpqid_(cp, &idx, cp_len);
50 umpqvl_(&idx, ipara);
51 return 0;
52 /* ----------------------------------------------------------------------- */
53
54 L_umpset:
55 umpqid_(cp, &idx, cp_len);
56 umpsvl_(&idx, ipara);
57 return 0;
58 /* ----------------------------------------------------------------------- */
59
60 L_umpstx:
61 ip = *ipara;
62 umpqid_(cp, &idx, cp_len);
63 umpqit_(&idx, &it);
64 umpqcp_(&idx, cx, (ftnlen)8);
65 umpqcl_(&idx, cl, (ftnlen)40);
66 if (it == 1) {
67 rtiget_("UM", cx, &ip, &c__1, (ftnlen)2, (ftnlen)8);
68 rliget_(cl, &ip, &c__1, (ftnlen)40);
69 umiqid_(cp, &idx, cp_len);
70 umisvl_(&idx, &ip);
71 } else if (it == 2) {
72 rtlget_("UM", cx, &ip, &c__1, (ftnlen)2, (ftnlen)8);
73 rllget_(cl, &ip, &c__1, (ftnlen)40);
74 umlqid_(cp, &idx, cp_len);
75 umlsvl_(&idx, &ip);
76 } else if (it == 3) {
77 rtrget_("UM", cx, &ip, &c__1, (ftnlen)2, (ftnlen)8);
78 rlrget_(cl, &ip, &c__1, (ftnlen)40);
79 umrqid_(cp, &idx, cp_len);
80 umrsvl_(&idx, &ip);
81 }
82 return 0;
83 } /* umpget_ */
84
umpget_(char * cp,integer * ipara,ftnlen cp_len)85 /* Subroutine */ int umpget_(char *cp, integer *ipara, ftnlen cp_len)
86 {
87 return umpget_0_(0, cp, ipara, cp_len);
88 }
89
umpset_(char * cp,integer * ipara,ftnlen cp_len)90 /* Subroutine */ int umpset_(char *cp, integer *ipara, ftnlen cp_len)
91 {
92 return umpget_0_(1, cp, ipara, cp_len);
93 }
94
umpstx_(char * cp,integer * ipara,ftnlen cp_len)95 /* Subroutine */ int umpstx_(char *cp, integer *ipara, ftnlen cp_len)
96 {
97 return umpget_0_(2, cp, ipara, cp_len);
98 }
99
100