1 /* stcc01.f -- translated by f2c (version 19980913).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include "f2c.h"
7
8 /* Table of constant values */
9
10 static integer c__4 = 4;
11
12 /* $Procedure STCC01 ( STAR catalog type 1, check whether type 1 ) */
stcc01_(char * catfnm,char * tabnam,logical * istyp1,char * errmsg,ftnlen catfnm_len,ftnlen tabnam_len,ftnlen errmsg_len)13 /* Subroutine */ int stcc01_(char *catfnm, char *tabnam, logical *istyp1,
14 char *errmsg, ftnlen catfnm_len, ftnlen tabnam_len, ftnlen errmsg_len)
15 {
16 /* Initialized data */
17
18 static char cat1nm[32*7] = "CATALOG_NUMBER " "RA "
19 " " "DEC " "RA_"
20 "SIGMA " "DEC_SIGMA "
21 "VISUAL_MAGNITUDE " "SPECTRAL_TYPE "
22 " ";
23 static char cat1dt[4*7] = "INT " "DP " "DP " "DP " "DP " "DP " "CHR "
24 ;
25
26 /* System generated locals */
27 address a__1[4];
28 integer i__1, i__2, i__3, i__4[4];
29
30 /* Builtin functions */
31 /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
32 integer s_cmp(char *, char *, ftnlen, ftnlen), s_rnge(char *, integer,
33 char *, integer);
34 /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
35
36 /* Local variables */
37 static integer i__, j;
38 extern /* Subroutine */ int chkin_(char *, ftnlen);
39 extern integer nblen_(char *, ftnlen);
40 extern /* Subroutine */ int ekcls_(integer *);
41 static logical found;
42 static integer ncols;
43 extern /* Subroutine */ int ekopr_(char *, integer *, ftnlen);
44 static integer sizes[100], nrows;
45 static char cnames[32*100];
46 extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
47 eknseg_(integer *);
48 static logical indexd[100];
49 static integer tmphnd, numseg;
50 extern /* Subroutine */ int chkout_(char *, ftnlen);
51 static logical nullok[100];
52 extern /* Subroutine */ int ekssum_(integer *, integer *, char *, integer
53 *, integer *, char *, char *, integer *, integer *, logical *,
54 logical *, ftnlen, ftnlen, ftnlen);
55 static char dtypes[4*100];
56 extern logical return_(void);
57 static char tmptnm[64];
58 static integer strlns[100];
59 static char tnmprv[64];
60
61 /* $ Abstract */
62
63 /* Check whether a file is a type 1 star catalog and return the */
64 /* catalog's table name if it is. */
65
66 /* $ Disclaimer */
67
68 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
69 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
70 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
71 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
72 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
73 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
74 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
75 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
76 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
77 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
78
79 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
80 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
81 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
82 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
83 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
84 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
85
86 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
87 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
88 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
89 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
90
91 /* $ Required_Reading */
92
93 /* EK */
94
95 /* $ Keywords */
96
97 /* None. */
98
99 /* $ Declarations */
100 /* $ Disclaimer */
101
102 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
103 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
104 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
105 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
106 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
107 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
108 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
109 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
110 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
111 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
112
113 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
114 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
115 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
116 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
117 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
118 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
119
120 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
121 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
122 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
123 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
124
125
126 /* Include Section: EK Column Name Size */
127
128 /* ekcnamsz.inc Version 1 17-JAN-1995 (NJB) */
129
130
131 /* Size of column name, in characters. */
132
133
134 /* End Include Section: EK Column Name Size */
135
136 /* $ Disclaimer */
137
138 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
139 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
140 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
141 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
142 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
143 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
144 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
145 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
146 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
147 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
148
149 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
150 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
151 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
152 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
153 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
154 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
155
156 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
157 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
158 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
159 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
160
161
162 /* Include Section: EK Table Name Size */
163
164 /* ektnamsz.inc Version 1 17-JAN-1995 (NJB) */
165
166
167 /* Size of table name, in characters. */
168
169
170 /* End Include Section: EK Table Name Size */
171
172 /* $ Disclaimer */
173
174 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
175 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
176 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
177 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
178 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
179 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
180 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
181 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
182 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
183 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
184
185 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
186 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
187 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
188 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
189 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
190 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
191
192 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
193 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
194 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
195 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
196
197
198 /* Include Section: EK General Limit Parameters */
199
200 /* ekglimit.inc Version 1 21-MAY-1995 (NJB) */
201
202
203 /* This file contains general limits for the EK system. */
204
205 /* MXCLSG is the maximum number of columns allowed in a segment. */
206 /* This limit applies to logical tables as well, since all segments */
207 /* in a logical table must have the same column definitions. */
208
209
210 /* End Include Section: EK General Limit Parameters */
211
212 /* $ Brief_I/O */
213
214 /* Variable I/O Description */
215 /* -------- --- -------------------------------------------------- */
216 /* CATFNM I Catalog file name. */
217 /* TABNAM O Catalog table name. */
218 /* ISTYP1 O True when file is type 1 star catalog. */
219 /* ERRMSG O Error message. */
220
221 /* $ Detailed_Input */
222
223 /* CATFNM is the name of the catalog file. */
224
225 /* $ Detailed_Output */
226
227 /* TABNAM is the name of the data table contained in the */
228 /* catalog. Set to blank if file is not a type 1 star */
229 /* catalog. */
230
231 /* ISTYP1 is TRUE when the file is a type 1 star catalog. FALSE */
232 /* otherwise. */
233
234 /* ERRMSG is a diagnostic message indicating why the file is */
235 /* not a type 1 star catalog. Set to blank if the file */
236 /* is a type 1 star catalog. */
237
238 /* $ Parameters */
239
240 /* None. */
241
242 /* $ Exceptions */
243
244 /* 1) If the indicated file cannot be opened, the error will be */
245 /* diagnosed by routines called by this routine. */
246
247 /* 2) If the indicated file has the wrong architecture version, the */
248 /* error will be diagnosed by routines called by this routine. */
249
250 /* 3) If an I/O error occurs while reading the indicated file, the */
251 /* error will be diagnosed by routines called by this routine. */
252
253 /* $ Files */
254
255 /* This routine checks whether file is really SPICE type 1 star */
256 /* catalog file. */
257
258 /* SPICE type 1 star catalog files MUST contain a single data table. */
259 /* It can occupy a single segment or it can spread across multiple */
260 /* segments. This table MUST include the following columns: */
261
262 /* column name data type units */
263 /* ------------------------------------------------------- */
264 /* RA DOUBLE PRECISION DEGREES */
265 /* DEC DOUBLE PRECISION DEGREES */
266 /* RA_SIGMA DOUBLE PRECISION DEGREES */
267 /* DEC_SIGMA DOUBLE PRECISION DEGREES */
268 /* CATALOG_NUMBER INTEGER */
269 /* SPECTRAL_TYPE CHARACTER*(4) */
270 /* VISUAL_MAGNITUDE DOUBLE PRECISION */
271
272 /* Nulls are not allowed in any of the columns. */
273 /* Other columns can also be present in the table but their data */
274 /* will NOT be accessible through type 1 star catalog access */
275 /* routines. Note that the names and attributes of these additional */
276 /* columns must be identical for all segments containing this table. */
277
278 /* $ Particulars */
279
280 /* This routine does not need to be called by the user's program. */
281 /* It is used by star catalog loader routines to check */
282 /* whether a particular file is a type 1 star catalog before loading */
283 /* the file. */
284
285 /* $ Examples */
286
287 /* In the following code fragment, STCC01 is used to determine */
288 /* whether a file is a SPICE type 1 star catalog. */
289
290 /* C */
291 /* C Call STCC01 to determine whether the file is type 1 star */
292 /* C catalog file. */
293 /* C */
294 /* CALL STCC01 ( CATFNM, TABNAM, ISTYP1, ERRMSG ) */
295
296 /* C */
297 /* C Check ISTYP1 flag and stop execution and report an */
298 /* C error if file is not type 1 star catalog file. */
299 /* C */
300 /* IF ( .NOT. ISTYP1 ) THEN */
301 /* . WRITE (*,*) 'The file:' */
302 /* . WRITE (*,*) ' ',CATFNM(1:RTRIM(CATFNM)) */
303 /* . WRITE (*,*) 'is not a type 1 star catalog.' */
304 /* . WRITE (*,*) ERRMSG */
305 /* STOP */
306 /* END IF */
307
308 /* $ Restrictions */
309
310 /* None. */
311
312 /* $ Literature_References */
313
314 /* None. */
315
316 /* $ Author_and_Institution */
317
318 /* B.V. Semenov (JPL) */
319
320 /* $ Version */
321
322 /* - SPICELIB Version 1.0.0, 15-MAY-1996 (BVS) */
323
324 /* -& */
325 /* $ Index_Entries */
326
327 /* check whether a file is a type 1 star catalog */
328
329 /* -& */
330
331
332 /* SPICELIB functions */
333
334
335 /* Local parameters. */
336
337
338 /* Local variables */
339
340
341 /* Initial values. */
342
343
344 /* Standard SPICE error handling. */
345
346 if (return_()) {
347 return 0;
348 } else {
349 chkin_("STCC01", (ftnlen)6);
350 }
351
352 /* More initial values. */
353
354 s_copy(tabnam, " ", tabnam_len, (ftnlen)1);
355 s_copy(errmsg, " ", errmsg_len, (ftnlen)1);
356 *istyp1 = TRUE_;
357
358 /* Open star catalog file with low level "open for read access" */
359 /* EK routine. */
360
361 ekopr_(catfnm, &tmphnd, catfnm_len);
362
363 /* Get the number of segments in the file and check whether it is */
364 /* greater than 0 (i.e. some data are is present in the file). If */
365 /* not then set an error message and return to the calling routine. */
366
367 numseg = eknseg_(&tmphnd);
368 if (numseg <= 0) {
369 s_copy(errmsg, "File contains no data.", errmsg_len, (ftnlen)22);
370 *istyp1 = FALSE_;
371 chkout_("STCC01", (ftnlen)6);
372 return 0;
373 }
374
375 /* Loop through the segments to find out whether all of them */
376 /* contain pieces of the same table. If not then set */
377 /* an error message and return to the calling routine. */
378
379 i__1 = numseg;
380 for (i__ = 1; i__ <= i__1; ++i__) {
381 ekssum_(&tmphnd, &i__, tmptnm, &nrows, &ncols, cnames, dtypes, sizes,
382 strlns, indexd, nullok, (ftnlen)64, (ftnlen)32, (ftnlen)4);
383 if (i__ > 1) {
384 if (s_cmp(tmptnm, tnmprv, (ftnlen)64, (ftnlen)64) != 0) {
385 s_copy(errmsg, "File contains more than one data table.",
386 errmsg_len, (ftnlen)39);
387 *istyp1 = FALSE_;
388 chkout_("STCC01", (ftnlen)6);
389 return 0;
390 }
391 }
392 s_copy(tnmprv, tmptnm, (ftnlen)64, (ftnlen)64);
393 }
394
395 /* Check whether the number of columns is less than it */
396 /* is supposed to be in type 1 star catalogs. If so then set */
397 /* an error message and return to a calling routine. */
398
399 if (ncols < 7) {
400 s_copy(errmsg, "File contains too few data columns.", errmsg_len, (
401 ftnlen)35);
402 *istyp1 = FALSE_;
403 chkout_("STCC01", (ftnlen)6);
404 return 0;
405 }
406
407 /* Check whether all columns that will be used in catalog search and */
408 /* star data fetching are present in the data table. If not */
409 /* then set an error message and return to a calling routine. */
410
411 for (i__ = 1; i__ <= 7; ++i__) {
412 found = FALSE_;
413 j = isrchc_(cat1nm + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1 :
414 s_rnge("cat1nm", i__1, "stcc01_", (ftnlen)319)) << 5), &ncols,
415 cnames, (ftnlen)32, (ftnlen)32);
416 if (j > 0) {
417 found = s_cmp(cat1dt + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1
418 : s_rnge("cat1dt", i__1, "stcc01_", (ftnlen)322)) << 2),
419 dtypes + (((i__2 = j - 1) < 100 && 0 <= i__2 ? i__2 :
420 s_rnge("dtypes", i__2, "stcc01_", (ftnlen)322)) << 2), (
421 ftnlen)4, (ftnlen)4) == 0 && ! nullok[(i__3 = j - 1) <
422 100 && 0 <= i__3 ? i__3 : s_rnge("nullok", i__3, "stcc01_"
423 , (ftnlen)322)];
424 }
425 if (! found) {
426 /* Writing concatenation */
427 i__4[0] = 8, a__1[0] = " Column ";
428 i__4[1] = nblen_(cat1nm + (((i__2 = i__ - 1) < 7 && 0 <= i__2 ?
429 i__2 : s_rnge("cat1nm", i__2, "stcc01_", (ftnlen)326)) <<
430 5), (ftnlen)32), a__1[1] = cat1nm + (((i__1 = i__ - 1) <
431 7 && 0 <= i__1 ? i__1 : s_rnge("cat1nm", i__1, "stcc01_",
432 (ftnlen)326)) << 5);
433 i__4[2] = 16, a__1[2] = " is not found or";
434 i__4[3] = 33, a__1[3] = " improperly declared in the file.";
435 s_cat(errmsg, a__1, i__4, &c__4, errmsg_len);
436 *istyp1 = FALSE_;
437 chkout_("STCC01", (ftnlen)6);
438 return 0;
439 }
440 }
441
442 /* If we got to this point then all checks were passed successfully */
443 /* and the file can be processed as a type 1 star catalog. We */
444 /* "return" the table name and close the file with the EK close */
445 /* routine. */
446
447 s_copy(tabnam, tmptnm, tabnam_len, (ftnlen)64);
448 ekcls_(&tmphnd);
449 chkout_("STCC01", (ftnlen)6);
450 return 0;
451 } /* stcc01_ */
452
453