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 static integer c__0 = 0;
20 static logical c_false = FALSE_;
21
22 /* ----------------------------------------------------------------------- */
23 /* UCYADY : PLOT DATE AXIS */
24 /* ----------------------------------------------------------------------- */
25 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
26 /* ----------------------------------------------------------------------- */
ucyady_(char * cside,integer * jd0,integer * nd,ftnlen cside_len)27 /* Subroutine */ int ucyady_(char *cside, integer *jd0, integer *nd, ftnlen
28 cside_len)
29 {
30 /* System generated locals */
31 address a__1[2];
32 integer i__1, i__2[2];
33 char ch__1[7];
34 icilist ici__1;
35
36 /* Builtin functions */
37 integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
38 ;
39 /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
40
41 /* Local variables */
42 static integer i__;
43 static char ch[2*100];
44 static integer id, nn;
45 static real uy[100];
46 static integer it0, iy0, idi, iml, moi, iti, iyi;
47 extern /* Subroutine */ int cladj_(char *, ftnlen);
48 static logical label;
49 extern /* Subroutine */ int date12_(integer *, integer *, integer *),
50 date23_(integer *, integer *, integer *, integer *);
51 static integer icent;
52 extern integer ndmon_(integer *, integer *);
53 static integer irota, irotc;
54 static logical lbtwn;
55 extern /* Subroutine */ int datef2_(integer *, integer *, integer *,
56 integer *, integer *);
57 extern integer nucday_(char *, integer *, ftnlen);
58 extern /* Subroutine */ int msgdmp_(char *, char *, char *, ftnlen,
59 ftnlen, ftnlen);
60 extern logical luychk_(char *, ftnlen);
61 extern /* Subroutine */ int uziget_(char *, integer *, ftnlen), uyplbl_(
62 char *, integer *, real *, char *, integer *, integer *, ftnlen,
63 ftnlen), uzlget_(char *, logical *, ftnlen), uziset_(char *,
64 integer *, ftnlen), uzlset_(char *, logical *, ftnlen), uypaxs_(
65 char *, integer *, ftnlen), uyptmk_(char *, integer *, real *,
66 integer *, ftnlen);
67
68 if (! luychk_(cside, (ftnlen)1)) {
69 msgdmp_("E", "UCYADY", "SIDE PARAMETER IS INVALID.", (ftnlen)1, (
70 ftnlen)6, (ftnlen)26);
71 }
72 if (*jd0 < 0) {
73 msgdmp_("E", "UCYADY", "FIRST DATE IS LESS THAN 0.", (ftnlen)1, (
74 ftnlen)6, (ftnlen)26);
75 }
76 if (*nd <= 0) {
77 msgdmp_("E", "UCYADY", "DATE LENGTH IS LESS THAN 0.", (ftnlen)1, (
78 ftnlen)6, (ftnlen)27);
79 }
80 uypaxs_(cside, &c__2, (ftnlen)1);
81 id = nucday_("Y", nd, (ftnlen)1);
82 if (id <= 0) {
83 msgdmp_("W", "UCYADY", "NO DAY-AXIS.", (ftnlen)1, (ftnlen)6, (ftnlen)
84 12);
85 return 0;
86 }
87 date12_(jd0, &iy0, &it0);
88 nn = 0;
89 i__1 = *nd;
90 for (i__ = 0; i__ <= i__1; ++i__) {
91 datef2_(&i__, &iy0, &it0, &iyi, &iti);
92 date23_(&iyi, &moi, &idi, &iti);
93 iml = ndmon_(&iyi, &moi);
94 if (idi < iml - id / 2 && idi % id == 0 || idi == iml) {
95 ++nn;
96 if (nn > 100) {
97 msgdmp_("E", "UCYADY", "WORKING AREA IS NOT ENOUGH.", (ftnlen)
98 1, (ftnlen)6, (ftnlen)27);
99 }
100 uy[nn - 1] = (real) i__;
101 ici__1.icierr = 0;
102 ici__1.icirnum = 1;
103 ici__1.icirlen = 2;
104 ici__1.iciunit = ch + (nn - 1 << 1);
105 ici__1.icifmt = "(I2)";
106 s_wsfi(&ici__1);
107 do_fio(&c__1, (char *)&idi, (ftnlen)sizeof(integer));
108 e_wsfi();
109 cladj_(ch + (nn - 1 << 1), (ftnlen)2);
110 }
111 /* L10: */
112 }
113 if (nn == 0) {
114 msgdmp_("W", "UCYADY", "THERE IS NO TICKMARK / LABEL.", (ftnlen)1, (
115 ftnlen)6, (ftnlen)29);
116 return 0;
117 }
118 /* Writing concatenation */
119 i__2[0] = 6, a__1[0] = "ICENTY";
120 i__2[1] = 1, a__1[1] = cside;
121 s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)7);
122 uziget_(ch__1, &icent, (ftnlen)7);
123 /* Writing concatenation */
124 i__2[0] = 6, a__1[0] = "IROTLY";
125 i__2[1] = 1, a__1[1] = cside;
126 s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)7);
127 uziget_(ch__1, &irota, (ftnlen)7);
128 /* Writing concatenation */
129 i__2[0] = 6, a__1[0] = "IROTCY";
130 i__2[1] = 1, a__1[1] = cside;
131 s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)7);
132 uziget_(ch__1, &irotc, (ftnlen)7);
133 uzlget_("LBTWN", &lbtwn, (ftnlen)5);
134 /* Writing concatenation */
135 i__2[0] = 6, a__1[0] = "ICENTY";
136 i__2[1] = 1, a__1[1] = cside;
137 s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)7);
138 uziset_(ch__1, &c__0, (ftnlen)7);
139 /* Writing concatenation */
140 i__2[0] = 6, a__1[0] = "IROTLY";
141 i__2[1] = 1, a__1[1] = cside;
142 s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)7);
143 uziset_(ch__1, &irotc, (ftnlen)7);
144 uzlset_("LBTWN", &c_false, (ftnlen)5);
145 uyptmk_(cside, &c__1, uy, &nn, (ftnlen)1);
146 /* Writing concatenation */
147 i__2[0] = 6, a__1[0] = "LABELY";
148 i__2[1] = 1, a__1[1] = cside;
149 s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)7);
150 uzlget_(ch__1, &label, (ftnlen)7);
151 if (label) {
152 uyplbl_(cside, &c__1, uy, ch, &c__2, &nn, (ftnlen)1, (ftnlen)2);
153 }
154 /* Writing concatenation */
155 i__2[0] = 6, a__1[0] = "ICENTY";
156 i__2[1] = 1, a__1[1] = cside;
157 s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)7);
158 uziset_(ch__1, &icent, (ftnlen)7);
159 /* Writing concatenation */
160 i__2[0] = 6, a__1[0] = "IROTLY";
161 i__2[1] = 1, a__1[1] = cside;
162 s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)7);
163 uziset_(ch__1, &irota, (ftnlen)7);
164 uzlset_("LBTWN", &lbtwn, (ftnlen)5);
165 return 0;
166 } /* ucyady_ */
167
168