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 static integer c__2 = 2;
19 static logical c_true = TRUE_;
20 static logical c_false = FALSE_;
21
22 /* ----------------------------------------------------------------------- */
23 /* UYPLBL : PLOT LABELS */
24 /* ----------------------------------------------------------------------- */
25 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
26 /* ----------------------------------------------------------------------- */
uyplbl_(char * cside,integer * islct,real * uy,char * ch,integer * nc,integer * n,ftnlen cside_len,ftnlen ch_len)27 /* Subroutine */ int uyplbl_(char *cside, integer *islct, real *uy, char *ch,
28 integer *nc, integer *n, ftnlen cside_len, ftnlen ch_len)
29 {
30 /* System generated locals */
31 address a__1[2];
32 integer i__1[2], i__2;
33 char ch__1[6], ch__2[7];
34
35 /* Builtin functions */
36 integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
37 ;
38 /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
39 integer i_sign(integer *, integer *);
40
41 /* Local variables */
42 static integer i__, ic;
43 static real pad, rlc;
44 static integer lcw;
45 static real wxch, wych, uxmn, uymn, posx, uxmx, uymx;
46 static integer iflag, icent, ncmax, index;
47 static char cslct[1];
48 static integer irota, jrota;
49 static real roffy;
50 static logical lbtwn;
51 static real roffz, rsize, rbtwn;
52 extern logical lchreq_(char *, char *, ftnlen, ftnlen);
53 extern /* Subroutine */ int msgdmp_(char *, char *, char *, ftnlen,
54 ftnlen, ftnlen), uyplba_(real *, char *, integer *, integer *,
55 real *, real *, real *, integer *, integer *, integer *, ftnlen),
56 uyplbb_(real *, char *, integer *, integer *, real *, real *,
57 real *, integer *, integer *, integer *, real *, logical *,
58 logical *, ftnlen);
59 extern logical luychk_(char *, ftnlen);
60 extern /* Subroutine */ int sgqwnd_(real *, real *, real *, real *),
61 uziget_(char *, integer *, ftnlen), uzlget_(char *, logical *,
62 ftnlen), uzrget_(char *, real *, ftnlen), uzrset_(char *, real *,
63 ftnlen), szqtxw_(char *, integer *, real *, real *, ftnlen);
64
65 /* Fortran I/O blocks */
66 static icilist io___2 = { 0, cslct, 0, "(I1)", 1, 1 };
67
68
69 /* Parameter adjustments */
70 ch -= ch_len;
71 --uy;
72
73 /* Function Body */
74 if (! luychk_(cside, (ftnlen)1)) {
75 msgdmp_("E", "UYPLBL", "SIDE PARAMETER IS INVALID.", (ftnlen)1, (
76 ftnlen)6, (ftnlen)26);
77 }
78 if (! (0 <= *islct && *islct <= 2)) {
79 msgdmp_("E", "UYPLBL", "'ISLCT' IS INVALID.", (ftnlen)1, (ftnlen)6, (
80 ftnlen)19);
81 }
82 if (*nc <= 0) {
83 msgdmp_("E", "UYPLBL", "CHARACTER LENGTH IS LESS THAN OR EQUAL TO ZE"
84 "RO.", (ftnlen)1, (ftnlen)6, (ftnlen)47);
85 }
86 if (*n <= 0) {
87 msgdmp_("E", "UYPLBL", "NUMBER OF POINTS IS INVALID.", (ftnlen)1, (
88 ftnlen)6, (ftnlen)28);
89 }
90 s_wsfi(&io___2);
91 do_fio(&c__1, (char *)&(*islct), (ftnlen)sizeof(integer));
92 e_wsfi();
93 /* Writing concatenation */
94 i__1[0] = 5, a__1[0] = "ROFFY";
95 i__1[1] = 1, a__1[1] = cside;
96 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)6);
97 uzrget_(ch__1, &roffy, (ftnlen)6);
98 /* Writing concatenation */
99 i__1[0] = 6, a__1[0] = "RSIZEL";
100 i__1[1] = 1, a__1[1] = cslct;
101 s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)7);
102 uzrget_(ch__2, &rsize, (ftnlen)7);
103 /* Writing concatenation */
104 i__1[0] = 6, a__1[0] = "ICENTY";
105 i__1[1] = 1, a__1[1] = cside;
106 s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)7);
107 uziget_(ch__2, &icent, (ftnlen)7);
108 /* Writing concatenation */
109 i__1[0] = 6, a__1[0] = "IROTLY";
110 i__1[1] = 1, a__1[1] = cside;
111 s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)7);
112 uziget_(ch__2, &irota, (ftnlen)7);
113 /* Writing concatenation */
114 i__1[0] = 6, a__1[0] = "INDEXL";
115 i__1[1] = 1, a__1[1] = cslct;
116 s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)7);
117 uziget_(ch__2, &index, (ftnlen)7);
118 uzrget_("PAD1", &pad, (ftnlen)4);
119 uzlget_("LBTWN", &lbtwn, (ftnlen)5);
120 if (lbtwn) {
121 uzrget_("RBTWN", &rbtwn, (ftnlen)5);
122 ncmax = *n - 1;
123 } else {
124 ncmax = *n;
125 }
126 if (! lchreq_(cside, "U", (ftnlen)1, (ftnlen)1)) {
127 sgqwnd_(&uxmn, &uxmx, &uymn, &uymx);
128 if (lchreq_(cside, "L", (ftnlen)1, (ftnlen)1)) {
129 posx = uxmn;
130 iflag = -1;
131 } else {
132 posx = uxmx;
133 iflag = 1;
134 }
135 } else {
136 uzrget_("UXUSER", &posx, (ftnlen)6);
137 uziget_("IFLAG", &iflag, (ftnlen)5);
138 iflag = i_sign(&c__1, &iflag);
139 }
140 jrota = (irota + 3) % 4 - 2;
141 if (jrota == -2) {
142 jrota = 0;
143 }
144 rlc = 1.f;
145 i__2 = ncmax;
146 for (i__ = 1; i__ <= i__2; ++i__) {
147 szqtxw_(ch + i__ * ch_len, &lcw, &wxch, &wych, ch_len);
148 if (jrota == 0 && wych > rlc) {
149 rlc = wych;
150 } else if (jrota != 0 && wxch > rlc) {
151 rlc = wxch;
152 }
153 /* L10: */
154 }
155 ic = jrota * icent * iflag;
156 roffz = roffy + rsize * (pad + rlc * (ic + 1) * .5f) * iflag;
157 roffy += rsize * (pad + rlc) * iflag;
158 if (lbtwn) {
159 uyplbb_(&uy[1], ch + ch_len, nc, n, &posx, &roffz, &rsize, &irota, &
160 icent, &index, &rbtwn, &c_true, &c_false, ch_len);
161 } else {
162 uyplba_(&uy[1], ch + ch_len, nc, n, &posx, &roffz, &rsize, &irota, &
163 icent, &index, ch_len);
164 }
165 /* Writing concatenation */
166 i__1[0] = 5, a__1[0] = "ROFFY";
167 i__1[1] = 1, a__1[1] = cside;
168 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)6);
169 uzrset_(ch__1, &roffy, (ftnlen)6);
170 return 0;
171 } /* uyplbl_ */
172
173