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 /* ----------------------------------------------------------------------- */
uvbxfz_(integer * n,real * upx,real * upy1,real * upy2,integer * itype,integer * index)30 /* Subroutine */ int uvbxfz_(integer *n, real *upx, real *upy1, real *upy2,
31 integer *itype, 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 dx, ux1, ux2, uy1, uy2;
43 static logical lyc1, lyc2;
44 static char cobj[80];
45 static real uref;
46 extern /* Subroutine */ int cdblk_(char *, ftnlen);
47 static logical lmiss;
48 static real rmiss;
49 static logical lxuni;
50 static real uxmin, uxmax;
51 extern /* Subroutine */ int gllget_(char *, logical *, ftnlen);
52 static real rundef;
53 extern /* Subroutine */ int glrget_(char *, real *, ftnlen), sglget_(char
54 *, logical *, ftnlen), msgdmp_(char *, char *, char *, ftnlen,
55 ftnlen, ftnlen), sgrget_(char *, real *, ftnlen), swocls_(char *,
56 ftnlen), uurget_(char *, real *, ftnlen), szcllu_(void), uuqidv_(
57 real *, real *), swoopn_(char *, char *, ftnlen, ftnlen), szsidx_(
58 integer *), szpllu_(real *, real *), szoplu_(void), szmvlu_(real *
59 , real *), szstyp_(integer *);
60
61 /* Fortran I/O blocks */
62 static icilist io___5 = { 0, cobj, 0, "(2I8)", 80, 1 };
63
64
65 /* Parameter adjustments */
66 --upy2;
67 --upy1;
68 --upx;
69
70 /* Function Body */
71 if (*n < 1) {
72 msgdmp_("E", "UVBXFZ", "NUMBER OF POINTS IS LESS THAN 1.", (ftnlen)1,
73 (ftnlen)6, (ftnlen)32);
74 }
75 if (*itype == 0) {
76 msgdmp_("M", "UVBXFZ", "LINE TYPE IS 0 / DO NOTHING.", (ftnlen)1, (
77 ftnlen)6, (ftnlen)28);
78 return 0;
79 }
80 if (*index == 0) {
81 msgdmp_("M", "UVBXFZ", "LINE INDEX IS 0 / DO NOTHING.", (ftnlen)1, (
82 ftnlen)6, (ftnlen)29);
83 return 0;
84 }
85 if (*index < 0) {
86 msgdmp_("E", "UVBXFZ", "LINE INDEX IS LESS THAN 0.", (ftnlen)1, (
87 ftnlen)6, (ftnlen)26);
88 }
89 sglget_("LCLIP", &szbls2_1.lclip, (ftnlen)5);
90 glrget_("RUNDEF", &rundef, (ftnlen)6);
91 glrget_("RMISS", &rmiss, (ftnlen)5);
92 gllget_("LMISS", &lmiss, (ftnlen)5);
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_("UVBXFZ", cobj, (ftnlen)6, (ftnlen)80);
99 szsidx_(index);
100 szstyp_(itype);
101 lxuni = upx[1] == rundef;
102 lyc1 = upy1[1] == rundef;
103 lyc2 = upy2[1] == rundef;
104 if (lxuni) {
105 uuqidv_(&uxmin, &uxmax);
106 if (uxmin == rundef) {
107 sgrget_("UXMIN", &uxmin, (ftnlen)5);
108 }
109 if (uxmax == rundef) {
110 sgrget_("UXMAX", &uxmax, (ftnlen)5);
111 }
112 dx = (uxmax - uxmin) / *n;
113 }
114 if (lyc1 || lyc2) {
115 uurget_("UREF", &uref, (ftnlen)4);
116 }
117 i__1 = *n;
118 for (i__ = 1; i__ <= i__1; ++i__) {
119 if (lxuni) {
120 ux1 = uxmin + dx * (i__ - 1);
121 ux2 = uxmin + dx * i__;
122 } else {
123 ux1 = upx[i__];
124 ux2 = upx[i__ + 1];
125 }
126 if (lyc1) {
127 uy1 = uref;
128 } else {
129 uy1 = upy1[i__];
130 }
131 if (lyc2) {
132 uy2 = uref;
133 } else {
134 uy2 = upy2[i__];
135 }
136 if (! ((ux1 == rmiss || ux1 == rmiss || uy1 == rmiss || uy2 == rmiss)
137 && lmiss)) {
138 szoplu_();
139 szmvlu_(&ux1, &uy2);
140 szpllu_(&ux2, &uy2);
141 szpllu_(&ux2, &uy1);
142 szpllu_(&ux1, &uy1);
143 szpllu_(&ux1, &uy2);
144 szcllu_();
145 }
146 /* L20: */
147 }
148 swocls_("UVBXFZ", (ftnlen)6);
149 return 0;
150 } /* uvbxfz_ */
151
152