1 /* zzdafgsr.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 static logical c_false = FALSE_;
12 static integer c__1 = 1;
13 static integer c__128 = 128;
14
15 /* $Procedure ZZDAFGSR ( Private --- DAF Get Summary/Descriptor Record ) */
zzdafgsr_(integer * handle,integer * recno,integer * nd,integer * ni,doublereal * dprec,logical * found)16 /* Subroutine */ int zzdafgsr_(integer *handle, integer *recno, integer *nd,
17 integer *ni, doublereal *dprec, logical *found)
18 {
19 /* Initialized data */
20
21 static logical first = TRUE_;
22 static integer natbff = 0;
23
24 /* System generated locals */
25 integer i__1, i__2;
26 static doublereal equiv_0[128];
27
28 /* Builtin functions */
29 integer s_rnge(char *, integer, char *, integer), s_rdue(cilist *),
30 do_uio(integer *, char *, ftnlen), e_rdue(void);
31
32 /* Local variables */
33 integer ibff, iamh, left, nsum;
34 extern /* Subroutine */ int zzddhgsd_(char *, integer *, char *, ftnlen,
35 ftnlen), zzddhnfo_(integer *, char *, integer *, integer *,
36 integer *, logical *, ftnlen), zzddhhlu_(integer *, char *,
37 logical *, integer *, ftnlen), zzxlated_(integer *, char *,
38 integer *, doublereal *, ftnlen), zzplatfm_(char *, char *,
39 ftnlen, ftnlen), zzxlatei_(integer *, char *, integer *, integer *
40 , ftnlen);
41 integer i__;
42 char fname[255];
43 integer iarch;
44 extern /* Subroutine */ int chkin_(char *, ftnlen);
45 #define dpbuf (equiv_0)
46 extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
47 #define inbuf ((integer *)equiv_0)
48 extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
49 moved_(doublereal *, integer *, doublereal *);
50 extern logical failed_(void);
51 logical locfnd;
52 char chrbuf[1024];
53 integer cindex;
54 extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
55 integer dindex;
56 static char strbff[8*4];
57 extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
58 ftnlen), setmsg_(char *, ftnlen);
59 integer iostat;
60 extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
61 extern logical return_(void);
62 char tmpstr[8];
63 integer sumsiz, lun;
64
65 /* Fortran I/O blocks */
66 static cilist io___15 = { 1, 0, 1, 0, 0 };
67 static cilist io___16 = { 1, 0, 1, 0, 0 };
68
69
70 /* $ Abstract */
71
72 /* SPICE Private routine intended solely for the support of SPICE */
73 /* routines. Users should not call this routine directly due */
74 /* to the volatile nature of this routine. */
75
76 /* Read a summary/descriptor record from a DAF. */
77
78 /* $ Disclaimer */
79
80 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
81 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
82 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
83 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
84 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
85 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
86 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
87 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
88 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
89 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
90
91 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
92 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
93 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
94 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
95 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
96 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
97
98 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
99 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
100 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
101 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
102
103 /* $ Required_Reading */
104
105 /* None. */
106
107 /* $ Keywords */
108
109 /* PRIVATE */
110
111 /* $ Declarations */
112
113 /* $ Abstract */
114
115 /* Parameter declarations for the DAF/DAS handle manager. */
116
117 /* $ Disclaimer */
118
119 /* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
120 /* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
121 /* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
122 /* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
123 /* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
124 /* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
125 /* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
126 /* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
127 /* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
128 /* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
129
130 /* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
131 /* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
132 /* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
133 /* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
134 /* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
135 /* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
136
137 /* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
138 /* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
139 /* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
140 /* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
141
142 /* $ Required_Reading */
143
144 /* DAF, DAS */
145
146 /* $ Keywords */
147
148 /* PRIVATE */
149
150 /* $ Particulars */
151
152 /* This include file contains parameters defining limits and */
153 /* integer codes that are utilized in the DAF/DAS handle manager */
154 /* routines. */
155
156 /* $ Restrictions */
157
158 /* None. */
159
160 /* $ Author_and_Institution */
161
162 /* F.S. Turner (JPL) */
163
164 /* $ Literature_References */
165
166 /* None. */
167
168 /* $ Version */
169
170 /* - SPICELIB Version 2.5.0, 10-MAR-2014 (BVS) */
171
172 /* Updated for SUN-SOLARIS-64BIT-INTEL. */
173
174 /* - SPICELIB Version 2.4.0, 10-MAR-2014 (BVS) */
175
176 /* Updated for PC-LINUX-64BIT-IFORT. */
177
178 /* - SPICELIB Version 2.3.0, 10-MAR-2014 (BVS) */
179
180 /* Updated for PC-CYGWIN-GFORTRAN. */
181
182 /* - SPICELIB Version 2.2.0, 10-MAR-2014 (BVS) */
183
184 /* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
185
186 /* - SPICELIB Version 2.1.0, 10-MAR-2014 (BVS) */
187
188 /* Updated for PC-CYGWIN-64BIT-GCC_C. */
189
190 /* - SPICELIB Version 2.0.0, 12-APR-2012 (BVS) */
191
192 /* Increased FTSIZE (from 1000 to 5000). */
193
194 /* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
195
196 /* Updated for SUN-SOLARIS-INTEL. */
197
198 /* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
199
200 /* Updated for SUN-SOLARIS-INTEL-CC_C. */
201
202 /* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
203
204 /* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
205
206 /* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
207
208 /* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
209
210 /* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
211
212 /* Updated for PC-WINDOWS-64BIT-IFORT. */
213
214 /* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
215
216 /* Updated for PC-LINUX-64BIT-GFORTRAN. */
217
218 /* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
219
220 /* Updated for PC-64BIT-MS_C. */
221
222 /* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
223
224 /* Updated for MAC-OSX-64BIT-INTEL_C. */
225
226 /* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
227
228 /* Updated for MAC-OSX-64BIT-IFORT. */
229
230 /* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
231
232 /* Updated for MAC-OSX-64BIT-GFORTRAN. */
233
234 /* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
235
236 /* Updated for PC-LINUX-GFORTRAN. */
237
238 /* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
239
240 /* Updated for MAC-OSX-GFORTRAN. */
241
242 /* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
243
244 /* Updated for PC-LINUX-IFORT. */
245
246 /* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
247
248 /* Updated for PC-LINUX-64BIT-GCC_C. */
249
250 /* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
251
252 /* Updated for MAC-OSX-INTEL_C. */
253
254 /* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
255
256 /* Updated for MAC-OSX-IFORT. */
257
258 /* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
259
260 /* Updated for PC-WINDOWS-IFORT. */
261
262 /* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
263
264 /* Updated for SUN-SOLARIS-64BIT-GCC_C. */
265
266 /* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
267
268 /* Updated for PC-CYGWIN_C. */
269
270 /* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
271
272 /* Updated for PC-CYGWIN. */
273
274 /* - SPICELIB Version 1.0.1, 17-JUL-2002 */
275
276 /* Added MAC-OSX environments. */
277
278 /* - SPICELIB Version 1.0.0, 07-NOV-2001 */
279
280 /* -& */
281
282 /* Unit and file table size parameters. */
283
284 /* FTSIZE is the maximum number of files (DAS and DAF) that a */
285 /* user may have open simultaneously. */
286
287
288 /* RSVUNT is the number of units protected from being locked */
289 /* to a particular handle by ZZDDHHLU. */
290
291
292 /* SCRUNT is the number of units protected for use by scratch */
293 /* files. */
294
295
296 /* UTSIZE is the maximum number of logical units this manager */
297 /* will utilize at one time. */
298
299
300 /* Access method enumeration. These parameters are used to */
301 /* identify which access method is associated with a particular */
302 /* handle. They need to be synchronized with the STRAMH array */
303 /* defined in ZZDDHGSD in the following fashion: */
304
305 /* STRAMH ( READ ) = 'READ' */
306 /* STRAMH ( WRITE ) = 'WRITE' */
307 /* STRAMH ( SCRTCH ) = 'SCRATCH' */
308 /* STRAMH ( NEW ) = 'NEW' */
309
310 /* These values are used in the file table variable FTAMH. */
311
312
313 /* Binary file format enumeration. These parameters are used to */
314 /* identify which binary file format is associated with a */
315 /* particular handle. They need to be synchronized with the STRBFF */
316 /* array defined in ZZDDHGSD in the following fashion: */
317
318 /* STRBFF ( BIGI3E ) = 'BIG-IEEE' */
319 /* STRBFF ( LTLI3E ) = 'LTL-IEEE' */
320 /* STRBFF ( VAXGFL ) = 'VAX-GFLT' */
321 /* STRBFF ( VAXDFL ) = 'VAX-DFLT' */
322
323 /* These values are used in the file table variable FTBFF. */
324
325
326 /* Some random string lengths... more documentation required. */
327 /* For now this will have to suffice. */
328
329
330 /* Architecture enumeration. These parameters are used to identify */
331 /* which file architecture is associated with a particular handle. */
332 /* They need to be synchronized with the STRARC array defined in */
333 /* ZZDDHGSD in the following fashion: */
334
335 /* STRARC ( DAF ) = 'DAF' */
336 /* STRARC ( DAS ) = 'DAS' */
337
338 /* These values will be used in the file table variable FTARC. */
339
340
341 /* For the following environments, record length is measured in */
342 /* characters (bytes) with eight characters per double precision */
343 /* number. */
344
345 /* Environment: Sun, Sun FORTRAN */
346 /* Source: Sun Fortran Programmer's Guide */
347
348 /* Environment: PC, MS FORTRAN */
349 /* Source: Microsoft Fortran Optimizing Compiler User's Guide */
350
351 /* Environment: Macintosh, Language Systems FORTRAN */
352 /* Source: Language Systems FORTRAN Reference Manual, */
353 /* Version 1.2, page 12-7 */
354
355 /* Environment: PC/Linux, g77 */
356 /* Source: Determined by experiment. */
357
358 /* Environment: PC, Lahey F77 EM/32 Version 4.0 */
359 /* Source: Lahey F77 EM/32 Language Reference Manual, */
360 /* page 144 */
361
362 /* Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */
363 /* Source: FORTRAN/9000 Reference-Series 700 Computers, */
364 /* page 5-110 */
365
366 /* Environment: NeXT Mach OS (Black Hardware), */
367 /* Absoft Fortran Version 3.2 */
368 /* Source: NAIF Program */
369
370
371 /* The following parameter defines the size of a string used */
372 /* to store a filenames on this target platform. */
373
374
375 /* The following parameter controls the size of the character record */
376 /* buffer used to read data from non-native files. */
377
378 /* $ Brief_I/O */
379
380 /* VARIABLE I/O DESCRIPTION */
381 /* -------- --- -------------------------------------------------- */
382 /* HANDLE I Handle of the DAF. */
383 /* RECNO I Record number. */
384 /* ND I Number of double precision components in a summary. */
385 /* NI I Number of integer components in a summary. */
386 /* DPREC O Contents of the record. */
387 /* FOUND O Logical indicating whether the record was found. */
388
389 /* $ Detailed_Input */
390
391 /* HANDLE is the handle associated with the DAF. */
392
393 /* RECNO is the record number of a particular summary record */
394 /* within the DAF, whose contents are to be read. */
395 /* ND, */
396 /* NI are the number of double precision and integer */
397 /* components, respectively, in each array summary */
398 /* in the specified file. */
399
400 /* $ Detailed_Output */
401
402 /* DPREC contains the contents of the specified record from */
403 /* the DAF associated with HANDLE, properly translated */
404 /* for use on the native environment. */
405
406 /* FOUND is TRUE when the specified record is found, and is */
407 /* FALSE otherwise. */
408
409 /* $ Parameters */
410
411 /* None. */
412
413 /* $ Files */
414
415 /* This routine reads data from the DAF associated with HANDLE. */
416 /* This action may result in connecting a logical unit to the */
417 /* file, if the handle manager has rotated the file out of the */
418 /* unit table. */
419
420 /* $ Exceptions */
421
422 /* 1) SPICE(HANDLENOTFOUND) is signaled if HANDLE can not be */
423 /* found in the set of loaded handles. */
424
425 /* 2) Routines in the call tree of this routine may trap and */
426 /* signal errors. */
427
428 /* $ Particulars */
429
430 /* This routine reads summary records of double precision */
431 /* numbers which contain integers packed through an EQUIVALENCE */
432 /* statement from native and supported non-native DAFs. */
433
434 /* The size of the character buffer and the number of records */
435 /* read may have to change to support new environments. As of */
436 /* the original release of this routine, all systems currently */
437 /* supported have a 1 kilobyte record length. */
438
439 /* $ Examples */
440
441 /* See DAFGSR for sample usage. */
442
443 /* $ Restrictions */
444
445 /* 1) Numeric data when read as characters from a file preserves */
446 /* the bit patterns present in the file in memory. */
447
448 /* 2) A record of double precision data is at most 1024 characters */
449 /* in length. */
450
451 /* 3) DPREC has enough space to store 128 double precision numbers. */
452
453 /* 4) Characters a byte-sized, 8 characters constitute a double */
454 /* precision number, and 4 characters an integer. */
455
456 /* $ Author_and_Institution */
457
458 /* F.S. Turner (JPL) */
459
460 /* $ Literature_References */
461
462 /* None. */
463
464 /* $ Version */
465
466 /* - SPICELIB Version 1.0.0, 12-NOV-2001 (FST) */
467
468
469 /* -& */
470
471 /* SPICELIB Functions */
472
473
474 /* Local Parameters */
475
476 /* Length in bytes of double precision numbers and integers. */
477
478
479 /* Local Variables */
480
481
482 /* Equivalence DPBUF to INBUF. */
483
484
485 /* Saved Variables */
486
487
488 /* Data Statements */
489
490
491 /* Standard SPICE error handling. */
492
493 if (return_()) {
494 return 0;
495 } else {
496 chkin_("ZZDAFGSR", (ftnlen)8);
497 }
498
499 /* Perform some initialization tasks. */
500
501 if (first) {
502
503 /* Populate STRBFF, the buffer that contains the labels */
504 /* for each binary file format. */
505
506 for (i__ = 1; i__ <= 4; ++i__) {
507 zzddhgsd_("BFF", &i__, strbff + (((i__1 = i__ - 1) < 4 && 0 <=
508 i__1 ? i__1 : s_rnge("strbff", i__1, "zzdafgsr_", (ftnlen)
509 235)) << 3), (ftnlen)3, (ftnlen)8);
510 }
511
512 /* Fetch the native binary file format and determine its */
513 /* integer code. */
514
515 zzplatfm_("FILE_FORMAT", tmpstr, (ftnlen)11, (ftnlen)8);
516 ucase_(tmpstr, tmpstr, (ftnlen)8, (ftnlen)8);
517 natbff = isrchc_(tmpstr, &c__4, strbff, (ftnlen)8, (ftnlen)8);
518 if (natbff == 0) {
519 setmsg_("The binary file format, '#', is not supported by this v"
520 "ersion of the toolkit. This is a serious problem, contac"
521 "t NAIF.", (ftnlen)118);
522 errch_("#", tmpstr, (ftnlen)1, (ftnlen)8);
523 sigerr_("SPICE(BUG)", (ftnlen)10);
524 chkout_("ZZDAFGSR", (ftnlen)8);
525 return 0;
526 }
527
528 /* Do not perform initialization tasks again. */
529
530 first = FALSE_;
531 }
532
533 /* Assume the data record will not be found, until it has been read */
534 /* from the file, and if necessary, successfully translated. */
535
536 *found = FALSE_;
537
538 /* Retrieve information regarding the file from the handle manager. */
539 /* The value of IARCH is not a concern, since this is a DAF routine */
540 /* all values passed into handle manager entry points will have */
541 /* 'DAF' as their architecture arguments. */
542
543 zzddhnfo_(handle, fname, &iarch, &ibff, &iamh, &locfnd, (ftnlen)255);
544 if (! locfnd) {
545 setmsg_("Unable to locate file associated with HANDLE, #. The most "
546 "likely cause of this is the file that you are trying to read"
547 " has been closed.", (ftnlen)136);
548 errint_("#", handle, (ftnlen)1);
549 sigerr_("SPICE(HANDLENOTFOUND)", (ftnlen)21);
550 chkout_("ZZDAFGSR", (ftnlen)8);
551 return 0;
552 }
553
554 /* Now get a logical unit for the handle. Check FAILED() */
555 /* in case an error occurs. */
556
557 zzddhhlu_(handle, "DAF", &c_false, &lun, (ftnlen)3);
558 if (failed_()) {
559 *found = FALSE_;
560 chkout_("ZZDAFGSR", (ftnlen)8);
561 return 0;
562 }
563
564 /* Branch based on whether the binary file format is native */
565 /* or not. Only supported formats can be opened by ZZDDHOPN, */
566 /* so no check of IBFF is required. */
567
568 if (ibff == natbff) {
569
570 /* In the native case, just read the array of double precision */
571 /* numbers from the file. The packed integers will be */
572 /* processed properly by the READ. */
573
574 io___15.ciunit = lun;
575 io___15.cirec = *recno;
576 iostat = s_rdue(&io___15);
577 if (iostat != 0) {
578 goto L100001;
579 }
580 for (i__ = 1; i__ <= 128; ++i__) {
581 iostat = do_uio(&c__1, (char *)&dpbuf[(i__1 = i__ - 1) < 128 && 0
582 <= i__1 ? i__1 : s_rnge("dpbuf", i__1, "zzdafgsr_", (
583 ftnlen)315)], (ftnlen)sizeof(doublereal));
584 if (iostat != 0) {
585 goto L100001;
586 }
587 }
588 iostat = e_rdue();
589 L100001:
590
591 /* Since this routine does not signal any IOSTAT based */
592 /* errors, return if a non-zero value is assigned to IOSTAT. */
593
594 if (iostat != 0) {
595 chkout_("ZZDAFGSR", (ftnlen)8);
596 return 0;
597 }
598
599 /* Process the non-native binary file format case. */
600
601 } else {
602
603 /* Read the record as characters. */
604
605 io___16.ciunit = lun;
606 io___16.cirec = *recno;
607 iostat = s_rdue(&io___16);
608 if (iostat != 0) {
609 goto L100002;
610 }
611 iostat = do_uio(&c__1, chrbuf, (ftnlen)1024);
612 if (iostat != 0) {
613 goto L100002;
614 }
615 iostat = e_rdue();
616 L100002:
617
618 /* Again, since this routine does not signal any IOSTAT */
619 /* based errors, return if one occurs. */
620
621 if (iostat != 0) {
622 chkout_("ZZDAFGSR", (ftnlen)8);
623 return 0;
624 }
625
626 /* Translate the summary record. First extract the leading */
627 /* 3 double precision numbers from the summary record as these */
628 /* respectively are NEXT, PREV, and NSUM. */
629
630 zzxlated_(&ibff, chrbuf, &c__128, dpbuf, (ftnlen)24);
631
632 /* Check FAILED() in case the translation process fails for */
633 /* any reason. */
634
635 if (failed_()) {
636 chkout_("ZZDAFGSR", (ftnlen)8);
637 return 0;
638 }
639
640 /* Convert NSUM to an integer, and compute the number of */
641 /* double precision numbers required to store each individual */
642 /* summary in the record. */
643
644 nsum = (integer) dpbuf[2];
645 sumsiz = *nd + (*ni + 1) / 2;
646
647 /* Convert each of the summaries one at a time. */
648
649 i__1 = nsum;
650 for (i__ = 1; i__ <= i__1; ++i__) {
651
652 /* Set the start index into the double precision array */
653 /* to receive the componets. Also set the character */
654 /* substring index to the start location for this summary. */
655 /* In the diagram below, each box represents a double */
656 /* precision number. The figure assumes SUMSIZ is 5 */
657 /* double precision numbers: */
658
659 /* |--- 1 ---|--- 2 ---|--- 3 ---| |- (I-1) -| */
660 /* ------------------------------------- ------------- */
661 /* | | | | | | | | | | | | | | | | | | |...| | | | | | |... */
662 /* ------------------------------------- ------------- */
663 /* |-----| ^ */
664 /* ^ | */
665 /* | Summary */
666 /* NEXT, PREV, NSUM Start */
667
668 dindex = (i__ - 1) * sumsiz + 4;
669 cindex = (dindex - 1 << 3) + 1;
670
671 /* First, check to see if there are any double precision */
672 /* numbers to translate. If so, translate, and then */
673 /* increment DINDEX and CINDEX accordingly. */
674
675 if (*nd > 0) {
676
677 /* DPBUF has room for 128 double precision numbers */
678 /* total. Compute the amount of space left in the */
679 /* buffer. */
680
681 left = 128 - (i__ - 1) * sumsiz - 3;
682 zzxlated_(&ibff, chrbuf + (cindex - 1), &left, &dpbuf[(i__2 =
683 dindex - 1) < 128 && 0 <= i__2 ? i__2 : s_rnge("dpbuf"
684 , i__2, "zzdafgsr_", (ftnlen)412)], cindex + (*nd <<
685 3) - 1 - (cindex - 1));
686
687 /* If the translation routine fails for any reason, */
688 /* check out and return. */
689
690 if (failed_()) {
691 chkout_("ZZDAFGSR", (ftnlen)8);
692 return 0;
693 }
694 dindex += *nd;
695 cindex += *nd << 3;
696 }
697
698 /* At this point DINDEX and CINDEX are pointing at the */
699 /* locations for the packed integers in the record. */
700 /* Use DINDEX to compute the index into INBUF, the */
701 /* equivalenced integer buffer and translate. */
702
703 if (*ni > 0) {
704
705 /* INBUF has room for 256 integers total. Compute */
706 /* the amount of space left in the buffer. Since */
707 /* it is equivalenced to DPBUF, account for the */
708 /* double precision numbers that were just added. */
709
710 left = 256 - (i__ - 1 << 1) * sumsiz - (*nd << 1) - 6;
711 zzxlatei_(&ibff, chrbuf + (cindex - 1), &left, &inbuf[(i__2 =
712 (dindex << 1) - 2) < 256 && 0 <= i__2 ? i__2 : s_rnge(
713 "inbuf", i__2, "zzdafgsr_", (ftnlen)447)], cindex + (*
714 ni << 2) - 1 - (cindex - 1));
715
716 /* If the translation routine fails for any reason, */
717 /* check out and return. */
718
719 if (failed_()) {
720 chkout_("ZZDAFGSR", (ftnlen)8);
721 return 0;
722 }
723
724 /* Now check to see if NI is odd. If so, then zero */
725 /* the last integer occupied by the newly translated */
726 /* summary. This is necessary to purge any garbage */
727 /* present in memory. */
728
729 if (*ni % 2 == 1) {
730 inbuf[(i__2 = (dindex << 1) - 1 + *ni - 1) < 256 && 0 <=
731 i__2 ? i__2 : s_rnge("inbuf", i__2, "zzdafgsr_", (
732 ftnlen)468)] = 0;
733 }
734 }
735 }
736
737 /* Translating garbage is a bad idea in general, so set */
738 /* the any remaining double precision numbers in the summary */
739 /* record to 0. */
740
741 dindex = nsum * sumsiz + 4;
742 for (i__ = dindex; i__ <= 128; ++i__) {
743 dpbuf[(i__1 = i__ - 1) < 128 && 0 <= i__1 ? i__1 : s_rnge("dpbuf",
744 i__1, "zzdafgsr_", (ftnlen)483)] = 0.;
745 }
746 }
747
748 /* Transfer the DPs to the output argument and return to the */
749 /* caller. */
750
751 *found = TRUE_;
752 moved_(dpbuf, &c__128, dprec);
753 chkout_("ZZDAFGSR", (ftnlen)8);
754 return 0;
755 } /* zzdafgsr_ */
756
757 #undef inbuf
758 #undef dpbuf
759
760
761