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__2 = 2;
18 static integer c__1 = 1;
19
20 /* ----------------------------------------------------------------------- */
21 /* UGVECT */
22 /* ----------------------------------------------------------------------- */
23 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
24 /* ----------------------------------------------------------------------- */
ugvect_(real * u,integer * mu,real * v,integer * mv,integer * nx,integer * ny)25 /* Subroutine */ int ugvect_(real *u, integer *mu, real *v, integer *mv,
26 integer *nx, integer *ny)
27 {
28 /* System generated locals */
29 integer u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
30 real r__1, r__2, r__3;
31
32 /* Builtin functions */
33 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
34 integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
35 ;
36 double sqrt(doublereal);
37
38 /* Local variables */
39 static integer i__, j;
40 static real r__, au, av, ue, ve, vx0, vy0, vx1, vx2, vy1, vy2;
41 static logical lok;
42 static char cmsg[80];
43 static logical lmsg;
44 static real vxmn, vymn, xttl, vxmx, vymx;
45 static logical lmada;
46 static integer icent, index;
47 extern real rgnle_(real *);
48 static logical lmiss, lumsg;
49 extern /* Subroutine */ int ugdut_(void);
50 static real rminu;
51 static logical lunit;
52 static integer ixint;
53 static real rmiss;
54 static integer iyint;
55 static real rmaxu, rmaxv, rminv;
56 extern real ruwgx_(integer *), ruwgy_(integer *);
57 static real xfact1, yfact1;
58 static integer itype1, itype2;
59 extern /* Subroutine */ int gllget_(char *, logical *, ftnlen);
60 static logical lsmall, lnrmal;
61 extern /* Subroutine */ int glrget_(char *, real *, ftnlen), ugiget_(char
62 *, integer *, ftnlen);
63 static logical leqrat;
64 extern /* Subroutine */ int uglget_(char *, logical *, ftnlen);
65 static real rsmall;
66 extern /* Subroutine */ int msgdmp_(char *, char *, char *, ftnlen,
67 ftnlen, ftnlen), szlacl_(void), ugrget_(char *, real *, ftnlen),
68 uwdflt_(integer *, integer *);
69 static logical lmissp;
70 extern /* Subroutine */ int szlaop_(integer *, integer *);
71 static real rsizem;
72 extern /* Subroutine */ int ugrset_(char *, real *, ftnlen), ugunit_(void)
73 , stftrf_(real *, real *, real *, real *);
74 static real rsizet;
75 extern /* Subroutine */ int uzrget_(char *, real *, ftnlen), sgqvpt_(real
76 *, real *, real *, real *);
77 static real rsizez;
78 extern /* Subroutine */ int sgpmzv_(integer *, real *, real *, integer *,
79 integer *, real *), szlazv_(real *, real *, real *, real *),
80 uzrset_(char *, real *, ftnlen);
81 static real uxunit, uyunit;
82 extern /* Subroutine */ int uxpttl_(char *, integer *, char *, real *,
83 ftnlen, ftnlen);
84
85 /* Fortran I/O blocks */
86 static icilist io___42 = { 0, cmsg+7, 0, "(1P,E10.3)", 10, 1 };
87 static icilist io___43 = { 0, cmsg+26, 0, "(1P,E10.3)", 10, 1 };
88 static icilist io___44 = { 0, cmsg+7, 0, "(1P,E10.3)", 10, 1 };
89 static icilist io___45 = { 0, cmsg+26, 0, "(1P,E10.3)", 10, 1 };
90
91
92 /* / GET INTERNAL PARAMETERS / */
93 /* Parameter adjustments */
94 u_dim1 = *mu;
95 u_offset = 1 + u_dim1;
96 u -= u_offset;
97 v_dim1 = *mv;
98 v_offset = 1 + v_dim1;
99 v -= v_offset;
100
101 /* Function Body */
102 gllget_("LMISS ", &lmiss, (ftnlen)8);
103 glrget_("RMISS ", &rmiss, (ftnlen)8);
104 ugiget_("INDEX ", &index, (ftnlen)8);
105 uglget_("LNRMAL ", &lnrmal, (ftnlen)8);
106 uglget_("LEQRAT ", &leqrat, (ftnlen)8);
107 uglget_("LMSG ", &lmsg, (ftnlen)8);
108 uglget_("LUNIT ", &lunit, (ftnlen)8);
109 uglget_("LUMSG ", &lumsg, (ftnlen)8);
110 ugiget_("ICENT ", &icent, (ftnlen)8);
111 uglget_("LMISSP ", &lmissp, (ftnlen)8);
112 ugiget_("ITYPE1 ", &itype1, (ftnlen)8);
113 uglget_("LSMALL ", &lsmall, (ftnlen)8);
114 ugrget_("RSMALL ", &rsmall, (ftnlen)8);
115 ugiget_("ITYPE2 ", &itype2, (ftnlen)8);
116 ugrget_("RSIZEM ", &rsizem, (ftnlen)8);
117 ugrget_("RSIZET ", &rsizet, (ftnlen)8);
118 ugrget_("XTTL ", &xttl, (ftnlen)8);
119 ugiget_("IXINT ", &ixint, (ftnlen)8);
120 ugiget_("IYINT ", &iyint, (ftnlen)8);
121 /* / SET GRID ATTRIBUTE IF IT HAS NOT BEEN SET YET / */
122 uwdflt_(nx, ny);
123 /* / CHECK INPUT DATA / */
124 lmada = TRUE_;
125 i__1 = *ny;
126 i__2 = iyint;
127 for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
128 i__3 = *nx;
129 i__4 = ixint;
130 for (i__ = 1; i__4 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += i__4) {
131 lok = ! (lmiss && (u[i__ + j * u_dim1] == rmiss || v[i__ + j *
132 v_dim1] == rmiss));
133 /* / CHECK MIN & MAX / */
134 if (lmada) {
135 if (lok) {
136 rmaxu = u[i__ + j * u_dim1];
137 rminu = u[i__ + j * u_dim1];
138 rmaxv = v[i__ + j * v_dim1];
139 rminv = v[i__ + j * v_dim1];
140 lmada = FALSE_;
141 }
142 } else {
143 if (lok) {
144 if (u[i__ + j * u_dim1] > rmaxu) {
145 rmaxu = u[i__ + j * u_dim1];
146 } else if (u[i__ + j * u_dim1] < rminu) {
147 rminu = u[i__ + j * u_dim1];
148 }
149 if (v[i__ + j * v_dim1] > rmaxv) {
150 rmaxv = v[i__ + j * v_dim1];
151 } else if (v[i__ + j * v_dim1] < rminv) {
152 rminv = v[i__ + j * v_dim1];
153 }
154 }
155 }
156 /* L15: */
157 }
158 /* L10: */
159 }
160 /* / WRITE MESSAGE IF MISSING OR ZERO FIELD / */
161 if (lmada || rminu == 0.f && rmaxu == 0.f && rminv == 0.f && rmaxv == 0.f)
162 {
163 if (lmada) {
164 s_copy(cmsg, "MISSING FIELD.", (ftnlen)80, (ftnlen)14);
165 } else {
166 s_copy(cmsg, "ZERO FIELD.", (ftnlen)80, (ftnlen)11);
167 }
168 msgdmp_("W", "UGVECT", cmsg, (ftnlen)1, (ftnlen)6, (ftnlen)80);
169 if (lmsg) {
170 uzrget_("RSIZEC2", &rsizez, (ftnlen)7);
171 uzrset_("RSIZEC2", &rsizet, (ftnlen)7);
172 uxpttl_("B", &c__2, " ", &xttl, (ftnlen)1, (ftnlen)2);
173 uxpttl_("B", &c__2, cmsg, &xttl, (ftnlen)1, (ftnlen)80);
174 uzrset_("RSIZEC2", &rsizez, (ftnlen)7);
175 }
176 goto L100;
177 }
178 /* / CALCULATE NORMALIZATION FACTOR / */
179 if (lnrmal) {
180 sgqvpt_(&vxmn, &vxmx, &vymn, &vymx);
181 ue = (vxmx - vxmn) / (*nx / ixint);
182 ve = (vymx - vymn) / (*ny / iyint);
183 /* Computing MAX */
184 r__2 = abs(rminu), r__3 = abs(rmaxu);
185 r__1 = ue / max(r__2,r__3);
186 au = rgnle_(&r__1);
187 /* Computing MAX */
188 r__2 = abs(rminv), r__3 = abs(rmaxv);
189 r__1 = ve / max(r__2,r__3);
190 av = rgnle_(&r__1);
191 if (leqrat) {
192 au = min(au,av);
193 av = min(au,av);
194 }
195 } else {
196 ugrget_("XFACT1 ", &xfact1, (ftnlen)8);
197 ugrget_("YFACT1 ", &yfact1, (ftnlen)8);
198 au = xfact1;
199 av = yfact1;
200 }
201 ugrset_("XFACT2 ", &au, (ftnlen)8);
202 ugrset_("YFACT2 ", &av, (ftnlen)8);
203 /* / DRAW UNIT VECTOR IF LUNIT / */
204 if (lunit) {
205 ugunit_();
206 /* / WRITE UNIT VALUE IF LMUSG / */
207 if (lumsg) {
208 ugrget_("UXUNIT ", &uxunit, (ftnlen)8);
209 ugrget_("UYUNIT ", &uyunit, (ftnlen)8);
210 s_copy(cmsg, "XUNIT =##########, YUNIT =##########", (ftnlen)80, (
211 ftnlen)36);
212 s_wsfi(&io___42);
213 do_fio(&c__1, (char *)&uxunit, (ftnlen)sizeof(real));
214 e_wsfi();
215 s_wsfi(&io___43);
216 do_fio(&c__1, (char *)&uyunit, (ftnlen)sizeof(real));
217 e_wsfi();
218 uzrget_("RSIZEC2", &rsizez, (ftnlen)7);
219 uzrset_("RSIZEC2", &rsizet, (ftnlen)7);
220 uxpttl_("B", &c__2, " ", &xttl, (ftnlen)1, (ftnlen)2);
221 uxpttl_("B", &c__2, cmsg, &xttl, (ftnlen)1, (ftnlen)80);
222 uzrset_("RSIZEC2", &rsizez, (ftnlen)7);
223 }
224 /* / DRAW TITLE FOR UNIT VECTOR / */
225 ugdut_();
226 /* / WRITE SCALING FACTOR IF LMSG / */
227 } else if (lmsg) {
228 s_copy(cmsg, "XFACT =##########, YFACT =##########", (ftnlen)80, (
229 ftnlen)36);
230 s_wsfi(&io___44);
231 do_fio(&c__1, (char *)&au, (ftnlen)sizeof(real));
232 e_wsfi();
233 s_wsfi(&io___45);
234 do_fio(&c__1, (char *)&av, (ftnlen)sizeof(real));
235 e_wsfi();
236 uzrget_("RSIZEC2", &rsizez, (ftnlen)7);
237 uzrset_("RSIZEC2", &rsizet, (ftnlen)7);
238 uxpttl_("B", &c__2, " ", &xttl, (ftnlen)1, (ftnlen)2);
239 uxpttl_("B", &c__2, cmsg, &xttl, (ftnlen)1, (ftnlen)80);
240 uzrset_("RSIZEC2", &rsizez, (ftnlen)7);
241 }
242 /* / DRAW VECTORS / */
243 szlaop_(&c__1, &index);
244 i__2 = *ny;
245 i__1 = iyint;
246 for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
247 i__4 = *nx;
248 i__3 = ixint;
249 for (i__ = 1; i__3 < 0 ? i__ >= i__4 : i__ <= i__4; i__ += i__3) {
250 lok = ! (lmiss && (u[i__ + j * u_dim1] == rmiss || v[i__ + j *
251 v_dim1] == rmiss));
252 r__1 = ruwgx_(&i__);
253 r__2 = ruwgy_(&j);
254 stftrf_(&r__1, &r__2, &vx0, &vy0);
255 if (lok) {
256 vx1 = vx0 - u[i__ + j * u_dim1] * (icent + 1) / 2.f * au;
257 vx2 = vx0 - u[i__ + j * u_dim1] * (icent - 1) / 2.f * au;
258 vy1 = vy0 - v[i__ + j * v_dim1] * (icent + 1) / 2.f * av;
259 vy2 = vy0 - v[i__ + j * v_dim1] * (icent - 1) / 2.f * av;
260 /* Computing 2nd power */
261 r__1 = vx2 - vx1;
262 /* Computing 2nd power */
263 r__2 = vy2 - vy1;
264 r__ = sqrt(r__1 * r__1 + r__2 * r__2);
265 if (lsmall && r__ <= rsmall) {
266 sgpmzv_(&c__1, &vx0, &vy0, &itype2, &index, &rsizem);
267 } else {
268 szlazv_(&vx1, &vy1, &vx2, &vy2);
269 }
270 } else {
271 if (lmissp) {
272 sgpmzv_(&c__1, &vx0, &vy0, &itype1, &index, &rsizem);
273 }
274 }
275 /* L20: */
276 }
277 /* L25: */
278 }
279 szlacl_();
280 L100:
281 return 0;
282 } /* ugvect_ */
283
284