1 /* dcl-5.3.2/src/math1/syslib/msgdmp.f -- translated by f2c (version 20020621).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include "libtinyf2c.h"
7
8 /* Table of constant values */
9
10 static integer c__6 = 6;
11 static integer c__4 = 4;
12
13 /* ----------------------------------------------------------------------- */
14 /* MSGDMP */
15 /* ----------------------------------------------------------------------- */
16 /* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
17 /* ----------------------------------------------------------------------- */
msgdmp_dclorig(char * clev,char * csub,char * cmsg,int clev_len,int csub_len,int cmsg_len)18 /* Subroutine */ int msgdmp_dclorig(char *clev, char *csub, char *cmsg, int
19 clev_len, int csub_len, int cmsg_len)
20 {
21 /* Initialized data */
22
23 static integer imsg = 0;
24
25 /* System generated locals */
26 address a__1[6], a__2[4];
27 integer i__1, i__2[6], i__3[4];
28
29 /* Builtin functions */
30 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
31 char **, integer *, integer *, ftnlen), s_stop(char *, ftnlen);
32
33 /* Local variables */
34 extern integer lenc_(char *, ftnlen);
35 static char cprc[32];
36 static integer lprc, lmsg, nlev, lsub;
37 static logical llmsg;
38 static char clevx[1], cmsgx[200], csubx[32];
39 static integer iunit;
40 extern /* Subroutine */ int gliget_(char *, integer *, ftnlen);
41 extern logical lchreq_(char *, char *, ftnlen, ftnlen);
42 extern /* Subroutine */ int gllget_(char *, logical *, ftnlen), prcnam_(
43 integer *, char *, ftnlen), osabrt_(void);
44 static integer maxmsg, msglev;
45 extern /* Subroutine */ int prclvl_(integer *);
46 static integer lnsize;
47 extern /* Subroutine */ int mszdmp_(char *, integer *, integer *, ftnlen);
48
49 gliget_("MSGUNIT", &iunit, (ftnlen)7);
50 gliget_("MAXMSG", &maxmsg, (ftnlen)6);
51 gliget_("MSGLEV", &msglev, (ftnlen)6);
52 gliget_("NLNSIZE", &lnsize, (ftnlen)7);
53 gllget_("LLMSG", &llmsg, (ftnlen)5);
54 prclvl_(&nlev);
55 i__1 = min(nlev,1);
56 prcnam_(&i__1, cprc, (ftnlen)32);
57 s_copy(clevx, clev, (ftnlen)1, clev_len);
58 s_copy(csubx, csub, (ftnlen)32, csub_len);
59 lmsg = lenc_(cmsg, cmsg_len);
60 lprc = lenc_(cprc, (ftnlen)32);
61 lsub = lenc_(csubx, (ftnlen)32);
62 if (lchreq_(clevx, "E", (ftnlen)1, (ftnlen)1)) {
63 if (llmsg) {
64 /* Writing concatenation */
65 i__2[0] = 11, a__1[0] = "*** Error (";
66 i__2[1] = lsub, a__1[1] = csubx;
67 i__2[2] = 2, a__1[2] = "@ ";
68 i__2[3] = lprc, a__1[3] = cprc;
69 i__2[4] = 2, a__1[4] = ") ";
70 i__2[5] = lmsg, a__1[5] = cmsg;
71 s_cat(cmsgx, a__1, i__2, &c__6, (ftnlen)200);
72 } else {
73 /* Writing concatenation */
74 i__3[0] = 13, a__2[0] = "***** ERROR (";
75 i__3[1] = 6, a__2[1] = csubx;
76 i__3[2] = 7, a__2[2] = ") *** ";
77 i__3[3] = lmsg, a__2[3] = cmsg;
78 s_cat(cmsgx, a__2, i__3, &c__4, (ftnlen)200);
79 }
80 mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
81 osabrt_();
82 s_stop("", (ftnlen)0);
83 }
84 if (imsg < maxmsg) {
85 if (lchreq_(clevx, "W", (ftnlen)1, (ftnlen)1) && msglev <= 1) {
86 ++imsg;
87 if (llmsg) {
88 /* Writing concatenation */
89 i__2[0] = 11, a__1[0] = "- Warning (";
90 i__2[1] = lsub, a__1[1] = csubx;
91 i__2[2] = 2, a__1[2] = "@ ";
92 i__2[3] = lprc, a__1[3] = cprc;
93 i__2[4] = 2, a__1[4] = ") ";
94 i__2[5] = lmsg, a__1[5] = cmsg;
95 s_cat(cmsgx, a__1, i__2, &c__6, (ftnlen)200);
96 } else {
97 /* Writing concatenation */
98 i__3[0] = 13, a__2[0] = "*** WARNING (";
99 i__3[1] = 6, a__2[1] = csubx;
100 i__3[2] = 7, a__2[2] = ") *** ";
101 i__3[3] = lmsg, a__2[3] = cmsg;
102 s_cat(cmsgx, a__2, i__3, &c__4, (ftnlen)200);
103 }
104 mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
105 } else if (lchreq_(clevx, "M", (ftnlen)1, (ftnlen)1) && msglev <= 0) {
106 ++imsg;
107 if (llmsg) {
108 /* Writing concatenation */
109 i__2[0] = 11, a__1[0] = "- Message (";
110 i__2[1] = lsub, a__1[1] = csubx;
111 i__2[2] = 2, a__1[2] = "@ ";
112 i__2[3] = lprc, a__1[3] = cprc;
113 i__2[4] = 2, a__1[4] = ") ";
114 i__2[5] = lmsg, a__1[5] = cmsg;
115 s_cat(cmsgx, a__1, i__2, &c__6, (ftnlen)200);
116 } else {
117 /* Writing concatenation */
118 i__3[0] = 13, a__2[0] = "*** MESSAGE (";
119 i__3[1] = 6, a__2[1] = csubx;
120 i__3[2] = 7, a__2[2] = ") *** ";
121 i__3[3] = lmsg, a__2[3] = cmsg;
122 s_cat(cmsgx, a__2, i__3, &c__4, (ftnlen)200);
123 }
124 mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
125 }
126 if (imsg == maxmsg) {
127 s_copy(cmsgx, "+++ THE FOLLOWING MESSAGES ARE SUPPRESSED.", (
128 ftnlen)200, (ftnlen)42);
129 mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
130 }
131 }
132 return 0;
133 } /* msgdmp_ */
134
135 /* ----------------------------------------------------
136 * switchable MSGDMP by T. Horinouchi 2001/11/30
137 *
138 * function msgdmp_ in the following is to be used in place of
139 * the original msgdmp_, which is renamed as msgdmp_dclorig above.
140 * the new msgdmp_ calls msgdmp_func whose default value is
141 * msgdmp_dclorig. Thus, the default behavior the msgdmp_ is the same
142 * as before. However, msgdmp_func can be replaced by using
143 * set_msgdmp_func. Also, only the behaviour on error can be modified
144 * with set_mgsdmp_err.
145 * ---------------------------------------------------- */
146
147 static int (*msgdmp_func)(char *clev, char *csub, char *cmsg,
148 int clev_len, int csub_len, int cmsg_len)
149 = msgdmp_dclorig ; /* <-- default function */
150
151 static int (*msgdmp_err_func)(char *csub, char *cmsg,
152 int csub_len, int cmsg_len); /* no default */
153
154 static int msgdmp_err_replaceable (char *, char *, char *, int, int, int);
155 /* ^ defined below */
156
set_msgdmp_func(int (* f)(char * clev,char * csub,char * cmsg,int clev_len,int csub_len,int cmsg_len))157 int set_msgdmp_func( int (*f)(char *clev, char *csub, char *cmsg,
158 int clev_len, int csub_len, int cmsg_len) )
159 {
160 msgdmp_func = f;
161 }
162
set_msgdmp_err_func(int (* f)(char * csub,char * cmsg,int csub_len,int cmsg_len))163 int set_msgdmp_err_func( int (*f)(char *csub, char *cmsg,
164 int csub_len, int cmsg_len) )
165 {
166 msgdmp_err_func = f;
167 msgdmp_func = msgdmp_err_replaceable;
168 }
169
msgdmp_(char * clev,char * csub,char * cmsg,ftnlen clev_len,ftnlen csub_len,ftnlen cmsg_len)170 int msgdmp_(char *clev, char *csub, char *cmsg, ftnlen
171 clev_len, ftnlen csub_len, ftnlen cmsg_len)
172 {
173 return( (*msgdmp_func)(clev, csub, cmsg,
174 clev_len, csub_len, cmsg_len) );
175 }
176
msgdmp_err_replaceable(char * clev,char * csub,char * cmsg,int clev_len,int csub_len,int cmsg_len)177 static int msgdmp_err_replaceable(char *clev, char *csub, char *cmsg, int
178 clev_len, int csub_len, int cmsg_len)
179 /* msgdmp_err_replaceable: by T Horinouchi 2001/11/30
180 same as msgdmp_dclorig except that msgdmp_err_func (to be set
181 by set_msgdmp_err_func) is called on error */
182 {
183 /* Initialized data */
184
185 static integer imsg = 0;
186
187 /* System generated locals */
188 address a__1[6], a__2[4];
189 integer i__1, i__2[6], i__3[4];
190
191 /* Builtin functions */
192 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
193 char **, integer *, integer *, ftnlen), s_stop(char *, ftnlen);
194
195 /* Local variables */
196 extern integer lenc_(char *, ftnlen);
197 static char cprc[32];
198 static integer lprc, lmsg, nlev, lsub;
199 static logical llmsg;
200 static char clevx[1], cmsgx[200], csubx[32];
201 static integer iunit;
202 extern /* Subroutine */ int gliget_(char *, integer *, ftnlen);
203 extern logical lchreq_(char *, char *, ftnlen, ftnlen);
204 extern /* Subroutine */ int gllget_(char *, logical *, ftnlen), prcnam_(
205 integer *, char *, ftnlen), osabrt_(void);
206 static integer maxmsg, msglev;
207 extern /* Subroutine */ int prclvl_(integer *);
208 static integer lnsize;
209 extern /* Subroutine */ int mszdmp_(char *, integer *, integer *, ftnlen);
210
211 gliget_("MSGUNIT", &iunit, (ftnlen)7);
212 gliget_("MAXMSG", &maxmsg, (ftnlen)6);
213 gliget_("MSGLEV", &msglev, (ftnlen)6);
214 gliget_("NLNSIZE", &lnsize, (ftnlen)7);
215 gllget_("LLMSG", &llmsg, (ftnlen)5);
216 prclvl_(&nlev);
217 i__1 = min(nlev,1);
218 prcnam_(&i__1, cprc, (ftnlen)32);
219 s_copy(clevx, clev, (ftnlen)1, clev_len);
220 s_copy(csubx, csub, (ftnlen)32, csub_len);
221 lmsg = lenc_(cmsg, cmsg_len);
222 lprc = lenc_(cprc, (ftnlen)32);
223 lsub = lenc_(csubx, (ftnlen)32);
224 if (lchreq_(clevx, "E", (ftnlen)1, (ftnlen)1)) {
225 msgdmp_err_func(csub, cmsg, csub_len, cmsg_len);
226 }
227 if (imsg < maxmsg) {
228 if (lchreq_(clevx, "W", (ftnlen)1, (ftnlen)1) && msglev <= 1) {
229 ++imsg;
230 if (llmsg) {
231 /* Writing concatenation */
232 i__2[0] = 11, a__1[0] = "- Warning (";
233 i__2[1] = lsub, a__1[1] = csubx;
234 i__2[2] = 2, a__1[2] = "@ ";
235 i__2[3] = lprc, a__1[3] = cprc;
236 i__2[4] = 2, a__1[4] = ") ";
237 i__2[5] = lmsg, a__1[5] = cmsg;
238 s_cat(cmsgx, a__1, i__2, &c__6, (ftnlen)200);
239 } else {
240 /* Writing concatenation */
241 i__3[0] = 13, a__2[0] = "*** WARNING (";
242 i__3[1] = 6, a__2[1] = csubx;
243 i__3[2] = 7, a__2[2] = ") *** ";
244 i__3[3] = lmsg, a__2[3] = cmsg;
245 s_cat(cmsgx, a__2, i__3, &c__4, (ftnlen)200);
246 }
247 mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
248 } else if (lchreq_(clevx, "M", (ftnlen)1, (ftnlen)1) && msglev <= 0) {
249 ++imsg;
250 if (llmsg) {
251 /* Writing concatenation */
252 i__2[0] = 11, a__1[0] = "- Message (";
253 i__2[1] = lsub, a__1[1] = csubx;
254 i__2[2] = 2, a__1[2] = "@ ";
255 i__2[3] = lprc, a__1[3] = cprc;
256 i__2[4] = 2, a__1[4] = ") ";
257 i__2[5] = lmsg, a__1[5] = cmsg;
258 s_cat(cmsgx, a__1, i__2, &c__6, (ftnlen)200);
259 } else {
260 /* Writing concatenation */
261 i__3[0] = 13, a__2[0] = "*** MESSAGE (";
262 i__3[1] = 6, a__2[1] = csubx;
263 i__3[2] = 7, a__2[2] = ") *** ";
264 i__3[3] = lmsg, a__2[3] = cmsg;
265 s_cat(cmsgx, a__2, i__3, &c__4, (ftnlen)200);
266 }
267 mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
268 }
269 if (imsg == maxmsg) {
270 s_copy(cmsgx, "+++ THE FOLLOWING MESSAGES ARE SUPPRESSED.", (
271 ftnlen)200, (ftnlen)42);
272 mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
273 }
274 }
275 return 0;
276 } /* msgdmp_err_replaceable */
277