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 /* Table of constant values */
24
25 static integer c__1 = 1;
26
27 /* ----------------------------------------------------------------------- */
28 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
29 /* ----------------------------------------------------------------------- */
uhbxlz_(integer * n,real * upx,real * upy,integer * itype,integer * index)30 /* Subroutine */ int uhbxlz_(integer *n, real *upx, real *upy, integer *itype,
31 integer *index)
32 {
33 /* System generated locals */
34 integer i__1;
35
36 /* Builtin functions */
37 integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
38 ;
39
40 /* Local variables */
41 static integer i__;
42 static real dy, uy1, uy2;
43 static char cobj[80];
44 extern /* Subroutine */ int cdblk_(char *, ftnlen);
45 static logical lflag, lmiss;
46 static real rmiss;
47 static logical lyuni;
48 static real uymin, uymax;
49 extern /* Subroutine */ int gllget_(char *, logical *, ftnlen);
50 static real rundef;
51 extern /* Subroutine */ int glrget_(char *, real *, ftnlen), sglget_(char
52 *, logical *, ftnlen), msgdmp_(char *, char *, char *, ftnlen,
53 ftnlen, ftnlen), sgrget_(char *, real *, ftnlen), swocls_(char *,
54 ftnlen), uuqidv_(real *, real *), szcllu_(void), swoopn_(char *,
55 char *, ftnlen, ftnlen), szslti_(integer *, integer *), szpllu_(
56 real *, real *), szoplu_(void), szmvlu_(real *, real *);
57
58 /* Fortran I/O blocks */
59 static icilist io___5 = { 0, cobj, 0, "(2I8)", 80, 1 };
60
61
62 /* Parameter adjustments */
63 --upy;
64 --upx;
65
66 /* Function Body */
67 if (*n < 2) {
68 msgdmp_("E", "UHBOXL", "NUMBER OF POINTS IS LESS THAN 2.", (ftnlen)1,
69 (ftnlen)6, (ftnlen)32);
70 }
71 if (*itype == 0) {
72 msgdmp_("M", "UHBOXL", "LINE TYPE IS 0 / DO NOTHING.", (ftnlen)1, (
73 ftnlen)6, (ftnlen)28);
74 return 0;
75 }
76 if (*index == 0) {
77 msgdmp_("M", "UHBOXL", "LINE INDEX IS 0 / DO NOTHING.", (ftnlen)1, (
78 ftnlen)6, (ftnlen)29);
79 return 0;
80 }
81 if (*index < 0) {
82 msgdmp_("E", "UHBOXL", "LINE INDEX IS LESS THAN 0.", (ftnlen)1, (
83 ftnlen)6, (ftnlen)26);
84 }
85 sglget_("LCLIP", &szbls2_1.lclip, (ftnlen)5);
86 glrget_("RUNDEF", &rundef, (ftnlen)6);
87 glrget_("RMISS", &rmiss, (ftnlen)5);
88 gllget_("LMISS", &lmiss, (ftnlen)5);
89 if (upx[1] == rundef) {
90 msgdmp_("E", "UHBXLZ", "RUNDEF CAN NOT BE UESED FOR UPX.", (ftnlen)1,
91 (ftnlen)6, (ftnlen)32);
92 }
93 s_wsfi(&io___5);
94 do_fio(&c__1, (char *)&(*itype), (ftnlen)sizeof(integer));
95 do_fio(&c__1, (char *)&(*index), (ftnlen)sizeof(integer));
96 e_wsfi();
97 cdblk_(cobj, (ftnlen)80);
98 swoopn_("UHBXLZ", cobj, (ftnlen)6, (ftnlen)80);
99 szslti_(itype, index);
100 szoplu_();
101 lyuni = upy[1] == rundef;
102 if (lyuni) {
103 uuqidv_(&uymin, &uymax);
104 if (uymin == rundef) {
105 sgrget_("UYMIN", &uymin, (ftnlen)5);
106 }
107 if (uymax == rundef) {
108 sgrget_("UYMAX", &uymax, (ftnlen)5);
109 }
110 dy = (uymax - uymin) / *n;
111 }
112 szoplu_();
113 lflag = FALSE_;
114 i__1 = *n;
115 for (i__ = 1; i__ <= i__1; ++i__) {
116 if (lyuni) {
117 uy1 = uymin + dy * (i__ - 1);
118 uy2 = uymin + dy * i__;
119 } else {
120 uy1 = upy[i__];
121 uy2 = upy[i__ + 1];
122 }
123 if ((upx[i__] == rmiss || uy1 == rmiss || uy2 == rmiss) && lmiss) {
124 lflag = FALSE_;
125 } else {
126 if (lflag) {
127 szpllu_(&upx[i__], &uy1);
128 szpllu_(&upx[i__], &uy2);
129 } else {
130 szmvlu_(&upx[i__], &uy1);
131 szpllu_(&upx[i__], &uy2);
132 lflag = TRUE_;
133 }
134 }
135 /* L20: */
136 }
137 szcllu_();
138 swocls_("UHBXLZ", (ftnlen)6);
139 return 0;
140 } /* uhbxlz_ */
141
142