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 integer itr;
19 real rundef;
20 integer iundef;
21 real pi, cpr, cpd, cp;
22 } umwk1_;
23
24 #define umwk1_1 umwk1_
25
26 /* Table of constant values */
27
28 static real c_b2 = 0.f;
29
30 /* ----------------------------------------------------------------------- */
31 /* UMSPWD : WINDOW MODE */
32 /* ----------------------------------------------------------------------- */
33 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
34 /* ----------------------------------------------------------------------- */
umspwd_(void)35 /* Subroutine */ int umspwd_(void)
36 {
37 static real dx, plx, ply, plrot, uxmin, uxmax, uymin, uymax, stlat1,
38 stlat2;
39 extern /* Subroutine */ int msgdmp_(char *, char *, char *, ftnlen,
40 ftnlen, ftnlen), sgrget_(char *, real *, ftnlen), sgqmpl_(real *,
41 real *, real *), sgqwnd_(real *, real *, real *, real *), sgsmpl_(
42 real *, real *, real *), sgrset_(char *, real *, ftnlen);
43
44 sgqmpl_(&plx, &ply, &plrot);
45 if (plx != umwk1_1.rundef && ply != umwk1_1.rundef && plrot !=
46 umwk1_1.rundef) {
47 return 0;
48 }
49 sgqwnd_(&uxmin, &uxmax, &uymin, &uymax);
50 if (uxmin == umwk1_1.rundef || uxmax == umwk1_1.rundef || uymin ==
51 umwk1_1.rundef || uymax == umwk1_1.rundef) {
52 return 0;
53 }
54 dx = uxmax - uxmin;
55 if (dx <= 0.f) {
56 dx += umwk1_1.pi * 2 * umwk1_1.cpr;
57 }
58 plx = uxmin + dx / 2.f;
59 if (umwk1_1.itr >= 30) {
60 ply = (uymin + uymax) / 2.f;
61 } else {
62 ply = umwk1_1.cpd * 90.f;
63 }
64 sgsmpl_(&plx, &ply, &c_b2);
65 /* ------------------------ STANDARD LATITUDE --------------------------- */
66 sgrget_("STLAT1", &stlat1, (ftnlen)6);
67 sgrget_("STLAT2", &stlat2, (ftnlen)6);
68 if (umwk1_1.itr == 20 || umwk1_1.itr == 21 || umwk1_1.itr == 23) {
69 if (uymin != umwk1_1.rundef && uymax != umwk1_1.rundef) {
70 if (stlat1 == umwk1_1.rundef) {
71 stlat1 = (uymin + uymax) / 2.f;
72 }
73 if (stlat1 == 0.f) {
74 msgdmp_("E", "UMSPWD", "INVALID WINDOW FOR CONICAL PROJECTIO"
75 "N.", (ftnlen)1, (ftnlen)6, (ftnlen)38);
76 }
77 } else {
78 if (stlat1 == umwk1_1.rundef) {
79 stlat1 = umwk1_1.cpd * 35;
80 }
81 }
82 sgrset_("STLAT1", &stlat1, (ftnlen)6);
83 } else if (umwk1_1.itr == 22) {
84 if (uymin != umwk1_1.rundef && uymax != umwk1_1.rundef) {
85 if (stlat1 == umwk1_1.rundef) {
86 stlat1 = uymin;
87 }
88 if (stlat2 == umwk1_1.rundef) {
89 stlat2 = uymax;
90 }
91 } else {
92 if (stlat1 == umwk1_1.rundef) {
93 stlat1 = umwk1_1.cpd * 35;
94 }
95 if (stlat2 == umwk1_1.rundef) {
96 stlat2 = umwk1_1.cpd * 45;
97 }
98 }
99 sgrset_("STLAT1", &stlat1, (ftnlen)6);
100 sgrset_("STLAT2", &stlat2, (ftnlen)6);
101 }
102 return 0;
103 } /* umspwd_ */
104
105