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 /* ----------------------------------------------------------------------- */
16 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
17 /* ----------------------------------------------------------------------- */
slsttl_0_(int n__,char * cttl,char * cside,real * px,real * py,real * ht,integer * nt,ftnlen cttl_len,ftnlen cside_len)18 /* Subroutine */ int slsttl_0_(int n__, char *cttl, char *cside, real *px,
19 real *py, real *ht, integer *nt, ftnlen cttl_len, ftnlen cside_len)
20 {
21 /* Initialized data */
22
23 static logical lset[5] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_ };
24
25 /* Builtin functions */
26 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
27
28 /* Local variables */
29 static integer i__, lc;
30 static char cs[1];
31 static real htz[5], pxz[5], pyz[5];
32 extern integer lenc_(char *, ftnlen);
33 static integer index;
34 static char cttlw[100], cttlz[100*5];
35 extern logical lchreq_(char *, char *, ftnlen, ftnlen);
36 static char csidez[1*5];
37 extern /* Subroutine */ int sgiget_(char *, integer *, ftnlen), sglget_(
38 char *, logical *, ftnlen), msgdmp_(char *, char *, char *,
39 ftnlen, ftnlen, ftnlen);
40 static logical ltitle;
41 extern /* Subroutine */ int sltlcv_(char *, char *, integer *, ftnlen,
42 ftnlen), slzttl_(char *, char *, real *, real *, real *, integer *
43 , ftnlen, ftnlen);
44
45 switch(n__) {
46 case 1: goto L_sldttl;
47 case 2: goto L_slpttl;
48 }
49
50 *(unsigned char *)cs = *(unsigned char *)cside;
51 if (! (lchreq_(cs, "T", (ftnlen)1, (ftnlen)1) || lchreq_(cs, "B", (ftnlen)
52 1, (ftnlen)1))) {
53 msgdmp_("E", "SLSTTL", "SIDE PARAMETER IS INVALID.", (ftnlen)1, (
54 ftnlen)6, (ftnlen)26);
55 }
56 if (! (-1.f <= *px && *px <= 1.f && -1.f <= *py && *py <= 1.f)) {
57 msgdmp_("E", "SLSTTL", "POSITION PARAMETER IS INVALID.", (ftnlen)1, (
58 ftnlen)6, (ftnlen)30);
59 }
60 if (! (*ht >= 0.f)) {
61 msgdmp_("E", "SLSTTL", "TEXT HEIGHT IS LESS THAN ZERO.", (ftnlen)1, (
62 ftnlen)6, (ftnlen)30);
63 }
64 if (! (1 <= *nt && *nt <= 5)) {
65 msgdmp_("E", "SLSTTL", "TITLE NUMBER IS OUT OF RANGE.", (ftnlen)1, (
66 ftnlen)6, (ftnlen)29);
67 }
68 lset[*nt - 1] = TRUE_;
69 s_copy(cttlz + (*nt - 1) * 100, cttl, (ftnlen)100, lenc_(cttl, cttl_len));
70 *(unsigned char *)&csidez[*nt - 1] = *(unsigned char *)cs;
71 pxz[*nt - 1] = *px;
72 pyz[*nt - 1] = *py;
73 htz[*nt - 1] = *ht;
74 return 0;
75 /* ----------------------------------------------------------------------- */
76
77 L_sldttl:
78 if (! (1 <= *nt && *nt <= 5)) {
79 msgdmp_("E", "SLDTTL", "TITLE NUMBER IS OUT OF RANGE.", (ftnlen)1, (
80 ftnlen)6, (ftnlen)29);
81 }
82 lset[*nt - 1] = FALSE_;
83 return 0;
84 /* ----------------------------------------------------------------------- */
85
86 L_slpttl:
87 sgiget_("INDEX", &index, (ftnlen)5);
88 sglget_("LTITLE", <itle, (ftnlen)6);
89 if (! ltitle) {
90 return 0;
91 }
92 for (i__ = 1; i__ <= 5; ++i__) {
93 if (lset[i__ - 1]) {
94 sltlcv_(cttlz + (i__ - 1) * 100, cttlw, &lc, (ftnlen)100, (ftnlen)
95 100);
96 slzttl_(csidez + (i__ - 1), cttlw, &pxz[i__ - 1], &pyz[i__ - 1], &
97 htz[i__ - 1], &index, (ftnlen)1, lc);
98 }
99 /* L10: */
100 }
101 return 0;
102 } /* slsttl_ */
103
slsttl_(char * cttl,char * cside,real * px,real * py,real * ht,integer * nt,ftnlen cttl_len,ftnlen cside_len)104 /* Subroutine */ int slsttl_(char *cttl, char *cside, real *px, real *py,
105 real *ht, integer *nt, ftnlen cttl_len, ftnlen cside_len)
106 {
107 return slsttl_0_(0, cttl, cside, px, py, ht, nt, cttl_len, cside_len);
108 }
109
sldttl_(integer * nt)110 /* Subroutine */ int sldttl_(integer *nt)
111 {
112 return slsttl_0_(1, (char *)0, (char *)0, (real *)0, (real *)0, (real *)0,
113 nt, (ftnint)0, (ftnint)0);
114 }
115
slpttl_(void)116 /* Subroutine */ int slpttl_(void)
117 {
118 return slsttl_0_(2, (char *)0, (char *)0, (real *)0, (real *)0, (real *)0,
119 (integer *)0, (ftnint)0, (ftnint)0);
120 }
121
122