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 /* Common Block Declarations */
16
17 struct {
18 logical lclip;
19 } szbls2_;
20
21 #define szbls2_1 szbls2_
22
23 struct {
24 logical lclipt;
25 } szbtx3_;
26
27 #define szbtx3_1 szbtx3_
28
29 /* Table of constant values */
30
31 static integer c__1 = 1;
32
33 /* ----------------------------------------------------------------------- */
34 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
35 /* ----------------------------------------------------------------------- */
uverbz_(integer * n,real * upx,real * upy1,real * upy2,integer * itype,integer * index,real * rsize)36 /* Subroutine */ int uverbz_(integer *n, real *upx, real *upy1, real *upy2,
37 integer *itype, integer *index, real *rsize)
38 {
39 /* System generated locals */
40 integer i__1;
41 real r__1;
42
43 /* Builtin functions */
44 integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
45 ;
46
47 /* Local variables */
48 static integer i__;
49 static real dx, vy1, vy2, uxx, vxx;
50 static char cobj[80];
51 extern /* Subroutine */ int cdblk_(char *, ftnlen);
52 static logical lmiss;
53 static real rmiss;
54 static logical lxuni;
55 static real uxmin, uxmax;
56 extern /* Subroutine */ int gllget_(char *, logical *, ftnlen);
57 static real rundef;
58 extern /* Subroutine */ int glrget_(char *, real *, ftnlen), sglget_(char
59 *, logical *, ftnlen), msgdmp_(char *, char *, char *, ftnlen,
60 ftnlen, ftnlen), sgrget_(char *, real *, ftnlen), stftrf_(real *,
61 real *, real *, real *), swocls_(char *, ftnlen), uuqidv_(real *,
62 real *), szcllv_(void), szsidx_(integer *), swoopn_(char *, char *
63 , ftnlen, ftnlen), szclsv_(void), szpllv_(real *, real *),
64 szoplv_(void), szmvlv_(real *, real *), szplsv_(real *, real *),
65 szopsv_(void), szmvsv_(real *, real *), szstyp_(integer *);
66
67 /* Fortran I/O blocks */
68 static icilist io___5 = { 0, cobj, 0, "(2I8,F8.5)", 80, 1 };
69
70
71 /* Parameter adjustments */
72 --upy2;
73 --upy1;
74 --upx;
75
76 /* Function Body */
77 if (*n < 1) {
78 msgdmp_("E", "UVERBZ", "NUMBER OF POINTS IS LESS THAN 1.", (ftnlen)1,
79 (ftnlen)6, (ftnlen)32);
80 }
81 if (*itype == 0) {
82 msgdmp_("M", "UVERBZ", "LINE TYPE IS 0 / DO NOTHING.", (ftnlen)1, (
83 ftnlen)6, (ftnlen)28);
84 return 0;
85 }
86 if (*index == 0) {
87 msgdmp_("M", "UVERBZ", "LINE INDEX IS 0 / DO NOTHING.", (ftnlen)1, (
88 ftnlen)6, (ftnlen)29);
89 return 0;
90 }
91 if (*index < 0) {
92 msgdmp_("E", "UVERBZ", "LINE INDEX IS LESS THAN 0.", (ftnlen)1, (
93 ftnlen)6, (ftnlen)26);
94 }
95 if (*rsize == 0.f) {
96 msgdmp_("M", "UVERBZ", "MARKER SIZE IS 0 / DO NOTHING.", (ftnlen)1, (
97 ftnlen)6, (ftnlen)30);
98 return 0;
99 }
100 if (*rsize < 0.f) {
101 msgdmp_("E", "UVERBZ", "MARKER SIZE IS LESS THAN ZERO.", (ftnlen)1, (
102 ftnlen)6, (ftnlen)30);
103 }
104 sglget_("LCLIP", &szbls2_1.lclip, (ftnlen)5);
105 szbtx3_1.lclipt = szbls2_1.lclip;
106 glrget_("RUNDEF", &rundef, (ftnlen)6);
107 glrget_("RMISS", &rmiss, (ftnlen)5);
108 gllget_("LMISS", &lmiss, (ftnlen)5);
109 if (upy1[1] == rundef || upy2[1] == rundef) {
110 msgdmp_("E", "UVERBZ", "RUNDEF CAN NOT BE UESED FOR UPY1 OR UPY2", (
111 ftnlen)1, (ftnlen)6, (ftnlen)40);
112 }
113 s_wsfi(&io___5);
114 do_fio(&c__1, (char *)&(*itype), (ftnlen)sizeof(integer));
115 do_fio(&c__1, (char *)&(*index), (ftnlen)sizeof(integer));
116 do_fio(&c__1, (char *)&(*rsize), (ftnlen)sizeof(real));
117 e_wsfi();
118 cdblk_(cobj, (ftnlen)80);
119 swoopn_("UVERBZ", cobj, (ftnlen)6, (ftnlen)80);
120 szsidx_(index);
121 szstyp_(itype);
122 lxuni = upx[1] == rundef;
123 if (lxuni) {
124 uuqidv_(&uxmin, &uxmax);
125 if (uxmin == rundef) {
126 sgrget_("UXMIN", &uxmin, (ftnlen)5);
127 }
128 if (uxmax == rundef) {
129 sgrget_("UXMAX", &uxmax, (ftnlen)5);
130 }
131 dx = (uxmax - uxmin) / (*n - 1);
132 }
133 i__1 = *n;
134 for (i__ = 1; i__ <= i__1; ++i__) {
135 if (lxuni) {
136 uxx = uxmin + dx * (i__ - 1);
137 } else {
138 uxx = upx[i__];
139 }
140 if (! ((uxx == rmiss || upy1[i__] == rmiss || upy2[i__] == rmiss) &&
141 lmiss)) {
142 stftrf_(&uxx, &upy1[i__], &vxx, &vy1);
143 stftrf_(&uxx, &upy2[i__], &vxx, &vy2);
144 szoplv_();
145 szmvlv_(&vxx, &vy1);
146 szpllv_(&vxx, &vy2);
147 szcllv_();
148 szopsv_();
149 r__1 = vxx - *rsize / 2.f;
150 szmvsv_(&r__1, &vy2);
151 r__1 = vxx + *rsize / 2.f;
152 szplsv_(&r__1, &vy2);
153 r__1 = vxx - *rsize / 2.f;
154 szmvsv_(&r__1, &vy1);
155 r__1 = vxx + *rsize / 2.f;
156 szplsv_(&r__1, &vy1);
157 szclsv_();
158 }
159 /* L20: */
160 }
161 swocls_("UVERBZ", (ftnlen)6);
162 return 0;
163 } /* uverbz_ */
164
165