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 /* DRAW MAP (GEOGRAPHIC LINES) */
22 /* ----------------------------------------------------------------------- */
23 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
24 /* ----------------------------------------------------------------------- */
umpmap_(char * cdsn,ftnlen cdsn_len)25 /* Subroutine */ int umpmap_(char *cdsn, ftnlen cdsn_len)
26 {
27 /* System generated locals */
28 address a__1[2];
29 integer i__1[2], i__2;
30 real r__1;
31 olist o__1;
32 cllist cl__1;
33 alist al__1;
34
35 /* Builtin functions */
36 integer s_cmp(char *, char *, ftnlen, ftnlen);
37 /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
38 integer f_open(olist *), f_rew(alist *), s_rsue(cilist *), do_uio(integer
39 *, char *, ftnlen), e_rsue(void), f_clos(cllist *);
40
41 /* Local variables */
42 static integer i__, n, n0, nm, iu;
43 static real ux0, ux1, uy0, uy1;
44 static integer ios, itr, igid;
45 extern integer lenc_(char *, ftnlen);
46 static char cmsg[80];
47 static real xlat[8192], xlon[8192];
48 static integer npts, index;
49 static char cdsnx[80];
50 static logical llast;
51 static integer itype;
52 extern /* Subroutine */ int msgdmp_(char *, char *, char *, ftnlen,
53 ftnlen, ftnlen), umiget_(char *, integer *, ftnlen);
54 extern integer iufopn_(void);
55 static real xlatsg[8192];
56 extern /* Subroutine */ int sgqwnd_(real *, real *, real *, real *),
57 umqfnm_(char *, char *, ftnlen, ftnlen);
58 static real xlatmn;
59 extern /* Subroutine */ int szplcl_(void);
60 static real xlonsg[8192], xlonmn, xlatmx;
61 extern /* Subroutine */ int sgqtrn_(integer *);
62 static real xlonmx;
63 extern /* Subroutine */ int szplop_(integer *, integer *), szplzu_(
64 integer *, real *, real *);
65 static logical litrone;
66
67 /* Fortran I/O blocks */
68 static cilist io___13 = { 1, 0, 1, 0, 0 };
69
70
71 litrone = FALSE_;
72 /* / GET INTERNAL PARAMETERS / */
73 umiget_("INDEXOUT", &index, (ftnlen)8);
74 umiget_("ITYPEOUT", &itype, (ftnlen)8);
75 sgqwnd_(&ux0, &ux1, &uy0, &uy1);
76 sgqtrn_(&itr);
77 if (itr == 1) {
78 litrone = TRUE_;
79 } else if (1 < itr && itr < 10) {
80 msgdmp_("E", "UMPMAP", "INVALID TRANSFORMATION NUMBER.", (ftnlen)1, (
81 ftnlen)6, (ftnlen)30);
82 }
83 /* / INQUIRE OUTLINE FILE / */
84 umqfnm_(cdsn, cdsnx, cdsn_len, (ftnlen)80);
85 if (s_cmp(cdsnx, " ", (ftnlen)80, (ftnlen)1) == 0) {
86 /* Writing concatenation */
87 i__1[0] = 15, a__1[0] = "OUTLINE FILE = ";
88 i__1[1] = lenc_(cdsn, cdsn_len), a__1[1] = cdsn;
89 s_cat(cmsg, a__1, i__1, &c__2, (ftnlen)80);
90 msgdmp_("M", "UMPMAP", cmsg, (ftnlen)1, (ftnlen)6, (ftnlen)80);
91 msgdmp_("E", "UMPMAP", "OUTLINE FILE DOES NOT EXIST.", (ftnlen)1, (
92 ftnlen)6, (ftnlen)28);
93 }
94 /* / OPEN OUTLINE FILE / */
95 iu = iufopn_();
96 o__1.oerr = 0;
97 o__1.ounit = iu;
98 o__1.ofnmlen = 80;
99 o__1.ofnm = cdsnx;
100 o__1.orl = 0;
101 o__1.osta = "OLD";
102 o__1.oacc = 0;
103 o__1.ofm = "UNFORMATTED";
104 o__1.oblnk = 0;
105 f_open(&o__1);
106 al__1.aerr = 0;
107 al__1.aunit = iu;
108 f_rew(&al__1);
109 /* / READ OUTLINE DATA AND PLOT / */
110 szplop_(&itype, &index);
111 L10:
112 io___13.ciunit = iu;
113 ios = s_rsue(&io___13);
114 if (ios != 0) {
115 goto L100001;
116 }
117 ios = do_uio(&c__1, (char *)&npts, (ftnlen)sizeof(integer));
118 if (ios != 0) {
119 goto L100001;
120 }
121 ios = do_uio(&c__1, (char *)&igid, (ftnlen)sizeof(integer));
122 if (ios != 0) {
123 goto L100001;
124 }
125 ios = do_uio(&c__1, (char *)&xlatmx, (ftnlen)sizeof(real));
126 if (ios != 0) {
127 goto L100001;
128 }
129 ios = do_uio(&c__1, (char *)&xlatmn, (ftnlen)sizeof(real));
130 if (ios != 0) {
131 goto L100001;
132 }
133 ios = do_uio(&c__1, (char *)&xlonmx, (ftnlen)sizeof(real));
134 if (ios != 0) {
135 goto L100001;
136 }
137 ios = do_uio(&c__1, (char *)&xlonmn, (ftnlen)sizeof(real));
138 if (ios != 0) {
139 goto L100001;
140 }
141 i__2 = npts / 2;
142 for (i__ = 1; i__ <= i__2; ++i__) {
143 ios = do_uio(&c__1, (char *)&xlat[i__ - 1], (ftnlen)sizeof(real));
144 if (ios != 0) {
145 goto L100001;
146 }
147 ios = do_uio(&c__1, (char *)&xlon[i__ - 1], (ftnlen)sizeof(real));
148 if (ios != 0) {
149 goto L100001;
150 }
151 }
152 ios = e_rsue();
153 L100001:
154 if (ios == 0) {
155 if (npts >= 2) {
156 if (litrone) {
157 i__2 = npts / 2;
158 for (n = 1; n <= i__2; ++n) {
159 if (ux0 > xlon[n - 1]) {
160 xlon[n - 1] += 360.f;
161 }
162 if (ux1 < xlon[n - 1]) {
163 xlon[n - 1] += -360.f;
164 }
165 /* L15: */
166 }
167 n0 = 1;
168 llast = FALSE_;
169 L20:
170 i__2 = npts / 2;
171 for (n = n0 + 1; n <= i__2; ++n) {
172 if ((r__1 = xlon[n - 1] - xlon[n - 2], abs(r__1)) > 300.f)
173 {
174 goto L30;
175 }
176 /* L25: */
177 }
178 L30:
179 nm = n;
180 if (nm > npts / 2) {
181 llast = TRUE_;
182 nm = npts / 2;
183 }
184 i__2 = nm - n0 + 1;
185 for (n = 1; n <= i__2; ++n) {
186 xlatsg[n - 1] = xlat[n + n0 - 2];
187 /* L35: */
188 }
189 i__2 = nm - n0;
190 for (n = 1; n <= i__2; ++n) {
191 xlonsg[n - 1] = xlon[n + n0 - 2];
192 /* L40: */
193 }
194 if (llast) {
195 xlonsg[nm - n0] = xlon[nm - 1];
196 } else {
197 if (xlon[nm - 1] > xlon[nm - 2]) {
198 xlonsg[nm - n0] = xlon[nm - 1] - 360.f;
199 xlon[nm - 2] += 360.f;
200 } else {
201 xlonsg[nm - n0] = xlon[nm - 1] + 360.f;
202 xlon[nm - 2] += -360.f;
203 }
204 }
205 i__2 = nm - n0 + 1;
206 szplzu_(&i__2, xlonsg, xlatsg);
207 n0 = nm - 1;
208 if (nm == npts / 2) {
209 goto L45;
210 }
211 goto L20;
212 } else {
213 i__2 = npts / 2;
214 szplzu_(&i__2, xlon, xlat);
215 }
216 L45:
217 ;
218 }
219 }
220 if (ios == 0) {
221 goto L10;
222 }
223 /* L50: */
224 szplcl_();
225 cl__1.cerr = 0;
226 cl__1.cunit = iu;
227 cl__1.csta = 0;
228 f_clos(&cl__1);
229 return 0;
230 } /* umpmap_ */
231
232