Return to libI77.st CVS log

Up to [Research Unix] / researchv10no / cmd / f2c

Annotation of researchv10no/cmd/f2c/libI77.st, revision 1.1

1.1     ! root        1: ./ ADD NAME=libI77/Notice TIME=695663806
        !             2: /****************************************************************
        !             3: Copyright 1990, 1991, 1992 by AT&T Bell Laboratories and Bellcore.
        !             4: 
        !             5: Permission to use, copy, modify, and distribute this software
        !             6: and its documentation for any purpose and without fee is hereby
        !             7: granted, provided that the above copyright notice appear in all
        !             8: copies and that both that the copyright notice and this
        !             9: permission notice and warranty disclaimer appear in supporting
        !            10: documentation, and that the names of AT&T Bell Laboratories or
        !            11: Bellcore or any of their entities not be used in advertising or
        !            12: publicity pertaining to distribution of the software without
        !            13: specific, written prior permission.
        !            14: 
        !            15: AT&T and Bellcore disclaim all warranties with regard to this
        !            16: software, including all implied warranties of merchantability
        !            17: and fitness.  In no event shall AT&T or Bellcore be liable for
        !            18: any special, indirect or consequential damages or any damages
        !            19: whatsoever resulting from loss of use, data or profits, whether
        !            20: in an action of contract, negligence or other tortious action,
        !            21: arising out of or in connection with the use or performance of
        !            22: this software.
        !            23: ****************************************************************/
        !            24: 
        !            25: ./ ADD NAME=libI77/README TIME=711898327
        !            26: If your compiler does not recognize ANSI C headers,
        !            27: compile with KR_headers defined:  either add -DKR_headers
        !            28: to the definition of CFLAGS in the makefile, or insert
        !            29: 
        !            30: #define KR_headers
        !            31: 
        !            32: at the top of f2c.h .
        !            33: 
        !            34: 
        !            35: If your system lacks /usr/include/local.h ,
        !            36: then you should create an appropriate local.h in
        !            37: this directory.  An appropriate local.h may simply
        !            38: be empty, or it may #define VAX or #define CRAY
        !            39: (or whatever else you must do to make fp.h work right).
        !            40: Alternatively, edit fp.h to suite your machine.
        !            41: 
        !            42: If your system lacks /usr/include/fcntl.h , then you
        !            43: should simply create an empty fcntl.h in this directory.
        !            44: If your compiler then complains about creat and open not
        !            45: having a prototype, compile with OPEN_DECL defined.
        !            46: On many systems, open and creat are declared in fcntl.h .
        !            47: 
        !            48: If your system's sprintf does not work the way ANSI C
        !            49: specifies -- specifically, if it does not return the
        !            50: number of characters transmitted -- then insert the line
        !            51: 
        !            52: #define USE_STRLEN
        !            53: 
        !            54: at the end of fmt.h .  This is necessary with
        !            55: at least some versions of Sun software.
        !            56: 
        !            57: If your system's fopen does not like the ANSI binary
        !            58: reading and writing modes "rb" and "wb", then you should
        !            59: compile open.c with NON_ANSI_RW_MODES #defined.
        !            60: 
        !            61: If you get error messages about references to cf->_ptr
        !            62: and cf->_base when compiling wrtfmt.c and wsfe.c or to
        !            63: stderr->_flag when compiling err.c, then insert the line
        !            64: 
        !            65: #define NON_UNIX_STDIO
        !            66: 
        !            67: at the beginning of fio.h, and recompile these modules.
        !            68: 
        !            69: Unformatted sequential records consist of a length of record
        !            70: contents, the record contents themselves, and the length of
        !            71: record contents again (for backspace).  Prior to 17 Oct. 1991,
        !            72: the length was of type int; now it is of type long, but you
        !            73: can change it back to int by inserting
        !            74: 
        !            75: #define UIOLEN_int
        !            76: 
        !            77: at the beginning of fio.h.  This affects only sue.c and uio.c .
        !            78: 
        !            79: You may need to supply the following non-ANSI routines:
        !            80: 
        !            81:   fstat(int fileds, struct stat *buf) is similar
        !            82: to stat(char *name, struct stat *buf), except that
        !            83: the first argument, fileds, is the file descriptor
        !            84: returned by open rather than the name of the file.
        !            85: fstat is used in the system-dependent routine
        !            86: canseek (in the libI77 source file err.c), which
        !            87: is supposed to return 1 if it's possible to issue
        !            88: seeks on the file in question, 0 if it's not; you may
        !            89: need to suitably modify err.c .  On non-UNIX systems,
        !            90: you can avoid references to fstat and stat by compiling
        !            91: err.c, inquire.c, open.c, and util.c with MSDOS defined;
        !            92: in that case, you may need to supply access(char *Name,0),
        !            93: which is supposed to return 0 if file Name exists,
        !            94: nonzero otherwise.
        !            95: 
        !            96:   char * mktemp(char *buf) is supposed to replace the
        !            97: 6 trailing X's in buf with a unique number and then
        !            98: return buf.  The idea is to get a unique name for
        !            99: a temporary file.
        !           100: 
        !           101: On non-UNIX systems, you may need to change a few other,
        !           102: e.g.: the form of name computed by mktemp() in endfile.c and
        !           103: open.c; the use of the open(), close(), and creat() system
        !           104: calls in endfile.c, err.c, open.c; and the modes in calls on
        !           105: fopen() and fdopen() (and perhaps the use of fdopen() itself
        !           106: -- it's supposed to return a FILE* corresponding to a given
        !           107: an integer file descriptor) in err.c and open.c (component ufmt
        !           108: of struct unit is 1 for formatted I/O -- text mode on some systems
        !           109: -- and 0 for unformatted I/O -- binary mode on some systems).
        !           110: 
        !           111: For Turbo C++, in particular, you need to adjust the mktemp
        !           112: invocations and should compile all of libI77 with -DMSDOS .
        !           113: You also need to #undef ungetc in lread.c and rsne.c .
        !           114: Don't use -mh -- it is horribly broken.
        !           115: 
        !           116: If you want to be able to load against libI77 but not libF77,
        !           117: then you will need to add sig_die.o (from libF77) to libI77.
        !           118: 
        !           119: If you wish to use translated Fortran that has funny notions
        !           120: of record length for direct unformatted I/O (i.e., that assumes
        !           121: RECL= values in OPEN statements are not bytes but rather counts
        !           122: of some other units -- e.g., 4-character words for VMS), then you
        !           123: should insert an appropriate #define for url_Adjust at the
        !           124: beginning of open.c .  For VMS Fortran, for example,
        !           125: #define url_Adjust(x) x *= 4
        !           126: would suffice.
        !           127: 
        !           128: To check for transmission errors, issue the command
        !           129:        make check
        !           130: This assumes you have the xsum program whose source, xsum.c,
        !           131: is distributed as part of "all from f2c/src".  If you do not
        !           132: have xsum, you can obtain xsum.c by sending the following E-mail
        !           133: message to [email protected]
        !           134:        send xsum.c from f2c/src
        !           135: 
        !           136: The makefile assumes you have installed f2c.h in a standard
        !           137: place (and does not cause recompilation when f2c.h is changed);
        !           138: f2c.h comes with "all from f2c" (the source for f2c) and is
        !           139: available separately ("f2c.h from f2c").
        !           140: 
        !           141: By default, Fortran I/O units 5, 6, and 0 are pre-connected to
        !           142: stdin, stdout, and stderr, respectively.  You can change this
        !           143: behavior by changing f_init() in err.c to suit your needs.
        !           144: Note that f2c assumes READ(*... means READ(5... and WRITE(*...
        !           145: means WRITE(6... .  Moreover, an OPEN(n,... statement that does
        !           146: not specify a file name (and does not specify STATUS='SCRATCH')
        !           147: assumes FILE='fort.n' .  You can change this by editing open.c
        !           148: and endfile.c suitably.
        !           149: ./ ADD NAME=libI77/Version.c TIME=719849651
        !           150: static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 23 Oct. 1992\n";
        !           151: 
        !           152: /*
        !           153: 2.01   $ format added
        !           154: 2.02   Coding bug in open.c repaired
        !           155: 2.03   fixed bugs in lread.c (read * with negative f-format) and lio.c
        !           156:        and lio.h (e-format conforming to spec)
        !           157: 2.04   changed open.c and err.c (fopen and freopen respectively) to
        !           158:        update to new c-library (append mode)
        !           159: 2.05   added namelist capability
        !           160: 2.06   allow internal list and namelist I/O
        !           161: */
        !           162: 
        !           163: /*
        !           164: close.c:
        !           165:        allow upper-case STATUS= values
        !           166: endfile.c
        !           167:        create fort.nnn if unit nnn not open;
        !           168:        else if (file length == 0) use creat() rather than copy;
        !           169:        use local copy() rather than forking /bin/cp;
        !           170:        rewind, fseek to clear buffer (for no reading past EOF)
        !           171: err.c
        !           172:        use neither setbuf nor setvbuf; make stderr buffered
        !           173: fio.h
        !           174:        #define _bufend
        !           175: inquire.c
        !           176:        upper case responses;
        !           177:        omit byfile test from SEQUENTIAL=
        !           178:        answer "YES" to DIRECT= for unopened file (open to debate)
        !           179: lio.c
        !           180:        flush stderr, stdout at end of each stmt
        !           181:        space before character strings in list output only at line start
        !           182: lio.h
        !           183:        adjust LEW, LED consistent with old libI77
        !           184: lread.c
        !           185:        use atof()
        !           186:        allow "nnn*," when reading complex constants
        !           187: open.c
        !           188:        try opening for writing when open for read fails, with
        !           189:        special uwrt value (2) delaying creat() to first write;
        !           190:        set curunit so error messages don't drop core;
        !           191:        no file name ==> fort.nnn except for STATUS='SCRATCH'
        !           192: rdfmt.c
        !           193:        use atof(); trust EOF == end-of-file (so don't read past
        !           194:        end-of-file after endfile stmt)
        !           195: sfe.c
        !           196:        flush stderr, stdout at end of each stmt
        !           197: wrtfmt.c:
        !           198:        use upper case
        !           199:        put wrt_E and wrt_F into wref.c, use sprintf()
        !           200:                rather than ecvt() and fcvt() [more accurate on VAX]
        !           201: */
        !           202: 
        !           203: /* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */
        !           204: 
        !           205: /* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */
        !           206: 
        !           207: /* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */
        !           208: /* 29 Nov. 1989: change various int return types to long for f2c */
        !           209: /* 30 Nov. 1989: various types from f2c.h */
        !           210: /*  6 Dec. 1989: types corrected various places */
        !           211: /* 19 Dec. 1989: make iostat= work right for internal I/O */
        !           212: /*  8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */
        !           213: /* 28 Jan. 1990: have NAMELIST read treat $ as &, general white
        !           214:                 space as blank */
        !           215: /* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads
        !           216:                 of logical values reject letters other than fFtT;
        !           217:                 have nowwriting reset cf */
        !           218: /* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */
        !           219: /* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as
        !           220:                 blank='z...' when reopening an open file */
        !           221: /* 30 Aug. 1990: prevent embedded blanks in list output of complex values;
        !           222:                 omit exponent field in list output of values of
        !           223:                 magnitude between 10 and 1e8; prevent writing stdin
        !           224:                 and reading stdout or stderr; don't close stdin, stdout,
        !           225:                 or stderr when reopening units 5, 6, 0. */
        !           226: /* 18 Sep. 1990: add component udev to unit and consider old == new file
        !           227:                 iff uinode and udev values agree; use stat rather than
        !           228:                 access to check existence of file (when STATUS='OLD')*/
        !           229: /* 2 Oct. 1990:  adjust rewind.c so two successive rewinds after a write
        !           230:                 don't clobber the file. */
        !           231: /* 9 Oct. 1990:  add #include "fcntl.h" to endfile.c, err.c, open.c;
        !           232:                 adjust g_char in util.c for segmented memories. */
        !           233: /* 17 Oct. 1990: replace abort() and _cleanup() with calls on
        !           234:                 sig_die(...,1) (defined in main.c). */
        !           235: /* 5 Nov. 1990:  changes to open.c: complain if new= is specified and the
        !           236:                 file already exists; allow file= to be omitted in open stmts
        !           237:                 and allow status='replace' (Fortran 90 extensions). */
        !           238: /* 11 Dec. 1990: adjustments for POSIX. */
        !           239: /* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from
        !           240:                 strings in read-only memory. */
        !           241: /* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */
        !           242: /* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */
        !           243: /* 16 May 1991:  increase LEFBL in lio.h to bypass NeXT bug */
        !           244: /* 17 Oct. 1991: change type of length field in sequential unformatted
        !           245:                 records from int to long (for systems where sizeof(int)
        !           246:                 can vary, depending on the compiler or compiler options). */
        !           247: /* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c.
        !           248: /* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to
        !           249:                 sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */
        !           250: /* 1 Dec. 1991:  uio.c: add test for read failure (seq. unformatted reads);
        !           251:                 adjust an error return from EOF to off end of record */
        !           252: /* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused
        !           253:                 the last character of each record to be ignored.
        !           254:                 iio.c: adjust error message in internal formatted
        !           255:                 input from "end-of-file" to "off end of record" if
        !           256:                 the format specifies more characters than the
        !           257:                 record contains. */
        !           258: /* 17 Jan. 1992: lread.c, rsne.c: in list and namelist input,
        !           259:                 treat "r* ," and "r*," alike (where r is a
        !           260:                 positive integer constant), and fix a bug in
        !           261:                 handling null values following items with repeat
        !           262:                 counts (e.g., 2*1,,3); for namelist reading
        !           263:                 of a numeric array, allow a new name-value subsequence
        !           264:                 to terminate the current one (as though the current
        !           265:                 one ended with the right number of null values).
        !           266:                 lio.h, lwrite.c: omit insignificant zeros in
        !           267:                 list and namelist output. To get the old
        !           268:                 behavior, compile with -DOld_list_output . */
        !           269: /* 18 Jan. 1992: make list output consistent with F format by
        !           270:                 printing .1 rather than 0.1 (introduced yesterday). */
        !           271: /* 3 Feb. 1992:  rsne.c: fix namelist read bug that caused the
        !           272:                 character following a comma to be ignored. */
        !           273: /* 19 May 1992:  adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err=
        !           274:                 work with internal list and formatted I/O. */
        !           275: /* 18 July 1992: adjust rsne.c to allow namelist input to stop at
        !           276:                 an & (e.g. &end). */
        !           277: /* 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined ;
        !           278:                 recognize Z format (assuming 8-bit bytes). */
        !           279: /* 14 Aug. 1992: tweak wrt_E in wref.c to avoid -NaN */
        !           280: /* 23 Oct. 1992: Supply missing l_eof = 0 assignment to s_rsne() in rsne.c
        !           281:                 (so end-of-file on other files won't confuse namelist
        !           282:                 reads of external files).  Prepend f__ to external
        !           283:                 names that are only of internal interest to lib[FI]77. */
        !           284: ./ ADD NAME=libI77/backspace.c TIME=719848229
        !           285: #include "f2c.h"
        !           286: #include "fio.h"
        !           287: #ifdef KR_headers
        !           288: integer f_back(a) alist *a;
        !           289: #else
        !           290: integer f_back(alist *a)
        !           291: #endif
        !           292: {      unit *b;
        !           293:        int n,i;
        !           294:        long x;
        !           295:        char buf[32];
        !           296:        if(a->aunit >= MXUNIT || a->aunit < 0)
        !           297:                err(a->aerr,101,"backspace")
        !           298:        b= &f__units[a->aunit];
        !           299:        if(b->useek==0) err(a->aerr,106,"backspace")
        !           300:        if(b->ufd==NULL) {
        !           301:                fk_open(1, 1, a->aunit);
        !           302:                return(0);
        !           303:                }
        !           304:        if(b->uend==1)
        !           305:        {       b->uend=0;
        !           306:                return(0);
        !           307:        }
        !           308:        if(b->uwrt) {
        !           309:                (void) t_runc(a);
        !           310:                if (f__nowreading(b))
        !           311:                        err(a->aerr,errno,"backspace")
        !           312:                }
        !           313:        if(b->url>0)
        !           314:        {       long y;
        !           315:                x=ftell(b->ufd);
        !           316:                y = x % b->url;
        !           317:                if(y == 0) x--;
        !           318:                x /= b->url;
        !           319:                x *= b->url;
        !           320:                (void) fseek(b->ufd,x,SEEK_SET);
        !           321:                return(0);
        !           322:        }
        !           323: 
        !           324:        if(b->ufmt==0)
        !           325:        {       (void) fseek(b->ufd,-(long)sizeof(int),SEEK_CUR);
        !           326:                (void) fread((char *)&n,sizeof(int),1,b->ufd);
        !           327:                (void) fseek(b->ufd,-(long)n-2*sizeof(int),SEEK_CUR);
        !           328:                return(0);
        !           329:        }
        !           330:        for(;;)
        !           331:        {       long y;
        !           332:                y = x=ftell(b->ufd);
        !           333:                if(x<sizeof(buf)) x=0;
        !           334:                else x -= sizeof(buf);
        !           335:                (void) fseek(b->ufd,x,SEEK_SET);
        !           336:                n=fread(buf,1,(int)(y-x), b->ufd);
        !           337:                for(i=n-2;i>=0;i--)
        !           338:                {
        !           339:                        if(buf[i]!='\n') continue;
        !           340:                        (void) fseek(b->ufd,(long)(i+1-n),SEEK_CUR);
        !           341:                        return(0);
        !           342:                }
        !           343:                if(x==0)
        !           344:                        {
        !           345:                        (void) fseek(b->ufd, 0L, SEEK_SET);
        !           346:                        return(0);
        !           347:                        }
        !           348:                else if(n<=0) err(a->aerr,(EOF),"backspace")
        !           349:                (void) fseek(b->ufd, x, SEEK_SET);
        !           350:        }
        !           351: }
        !           352: ./ ADD NAME=libI77/close.c TIME=719848229
        !           353: #include "f2c.h"
        !           354: #include "fio.h"
        !           355: #ifdef KR_headers
        !           356: integer f_clos(a) cllist *a;
        !           357: #else
        !           358: #undef abs
        !           359: #undef min
        !           360: #undef max
        !           361: #include "stdlib.h"
        !           362: #ifdef MSDOS
        !           363: #include "io.h"
        !           364: #else
        !           365: #ifdef __cplusplus
        !           366: extern "C" int unlink(const char*);
        !           367: #else
        !           368: extern int unlink(const char*);
        !           369: #endif
        !           370: #endif
        !           371: 
        !           372: integer f_clos(cllist *a)
        !           373: #endif
        !           374: {      unit *b;
        !           375: 
        !           376:        if(a->cunit >= MXUNIT) return(0);
        !           377:        b= &f__units[a->cunit];
        !           378:        if(b->ufd==NULL)
        !           379:                goto done;
        !           380:        if (!a->csta)
        !           381:                if (b->uscrtch == 1)
        !           382:                        goto Delete;
        !           383:                else
        !           384:                        goto Keep;
        !           385:        switch(*a->csta) {
        !           386:                default:
        !           387:                Keep:
        !           388:                case 'k':
        !           389:                case 'K':
        !           390:                        if(b->uwrt == 1)
        !           391:                                (void) t_runc((alist *)a);
        !           392:                        if(b->ufnm) {
        !           393:                                (void) fclose(b->ufd);
        !           394:                                free(b->ufnm);
        !           395:                                }
        !           396:                        break;
        !           397:                case 'd':
        !           398:                case 'D':
        !           399:                Delete:
        !           400:                        if(b->ufnm) {
        !           401:                                (void) fclose(b->ufd);
        !           402:                                (void) unlink(b->ufnm); /*SYSDEP*/
        !           403:                                free(b->ufnm);
        !           404:                                }
        !           405:                }
        !           406:        b->ufd=NULL;
        !           407:  done:
        !           408:        b->uend=0;
        !           409:        b->ufnm=NULL;
        !           410:        return(0);
        !           411:        }
        !           412:  void
        !           413: #ifdef KR_headers
        !           414: f_exit()
        !           415: #else
        !           416: f_exit(void)
        !           417: #endif
        !           418: {      int i;
        !           419:        static cllist xx;
        !           420:        if (!xx.cerr) {
        !           421:                xx.cerr=1;
        !           422:                xx.csta=NULL;
        !           423:                for(i=0;i<MXUNIT;i++)
        !           424:                {
        !           425:                        xx.cunit=i;
        !           426:                        (void) f_clos(&xx);
        !           427:                }
        !           428:        }
        !           429: }
        !           430:  void
        !           431: #ifdef KR_headers
        !           432: flush_()
        !           433: #else
        !           434: flush_(void)
        !           435: #endif
        !           436: {      int i;
        !           437:        for(i=0;i<MXUNIT;i++)
        !           438:                if(f__units[i].ufd != NULL && f__units[i].uwrt)
        !           439:                        fflush(f__units[i].ufd);
        !           440: }
        !           441: ./ ADD NAME=libI77/dfe.c TIME=719848230
        !           442: #include "f2c.h"
        !           443: #include "fio.h"
        !           444: #include "fmt.h"
        !           445: 
        !           446: y_rsk(Void)
        !           447: {
        !           448:        if(f__curunit->uend || f__curunit->url <= f__recpos
        !           449:                || f__curunit->url == 1) return 0;
        !           450:        do {
        !           451:                getc(f__cf);
        !           452:        } while(++f__recpos < f__curunit->url);
        !           453:        return 0;
        !           454: }
        !           455: y_getc(Void)
        !           456: {
        !           457:        int ch;
        !           458:        if(f__curunit->uend) return(-1);
        !           459:        if((ch=getc(f__cf))!=EOF)
        !           460:        {
        !           461:                f__recpos++;
        !           462:                if(f__curunit->url>=f__recpos ||
        !           463:                        f__curunit->url==1)
        !           464:                        return(ch);
        !           465:                else    return(' ');
        !           466:        }
        !           467:        if(feof(f__cf))
        !           468:        {
        !           469:                f__curunit->uend=1;
        !           470:                errno=0;
        !           471:                return(-1);
        !           472:        }
        !           473:        err(f__elist->cierr,errno,"readingd");
        !           474: }
        !           475: #ifdef KR_headers
        !           476: y_putc(c)
        !           477: #else
        !           478: y_putc(int c)
        !           479: #endif
        !           480: {
        !           481:        f__recpos++;
        !           482:        if(f__recpos <= f__curunit->url || f__curunit->url==1)
        !           483:                putc(c,f__cf);
        !           484:        else
        !           485:                err(f__elist->cierr,110,"dout");
        !           486:        return(0);
        !           487: }
        !           488: y_rev(Void)
        !           489: {      /*what about work done?*/
        !           490:        if(f__curunit->url==1 || f__recpos==f__curunit->url)
        !           491:                return(0);
        !           492:        while(f__recpos<f__curunit->url)
        !           493:                (*f__putn)(' ');
        !           494:        f__recpos=0;
        !           495:        return(0);
        !           496: }
        !           497: y_err(Void)
        !           498: {
        !           499:        err(f__elist->cierr, 110, "dfe");
        !           500: }
        !           501: 
        !           502: y_newrec(Void)
        !           503: {
        !           504:        if(f__curunit->url == 1 || f__recpos == f__curunit->url) {
        !           505:                f__hiwater = f__recpos = f__cursor = 0;
        !           506:                return(1);
        !           507:        }
        !           508:        if(f__hiwater > f__recpos)
        !           509:                f__recpos = f__hiwater;
        !           510:        y_rev();
        !           511:        f__hiwater = f__cursor = 0;
        !           512:        return(1);
        !           513: }
        !           514: 
        !           515: #ifdef KR_headers
        !           516: c_dfe(a) cilist *a;
        !           517: #else
        !           518: c_dfe(cilist *a)
        !           519: #endif
        !           520: {
        !           521:        f__sequential=0;
        !           522:        f__formatted=f__external=1;
        !           523:        f__elist=a;
        !           524:        f__cursor=f__scale=f__recpos=0;
        !           525:        if(a->ciunit>MXUNIT || a->ciunit<0)
        !           526:                err(a->cierr,101,"startchk");
        !           527:        f__curunit = &f__units[a->ciunit];
        !           528:        if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit))
        !           529:                err(a->cierr,104,"dfe");
        !           530:        f__cf=f__curunit->ufd;
        !           531:        if(!f__curunit->ufmt) err(a->cierr,102,"dfe")
        !           532:        if(!f__curunit->useek) err(a->cierr,104,"dfe")
        !           533:        f__fmtbuf=a->cifmt;
        !           534:        (void) fseek(f__cf,(long)f__curunit->url * (a->cirec-1),SEEK_SET);
        !           535:        f__curunit->uend = 0;
        !           536:        return(0);
        !           537: }
        !           538: #ifdef KR_headers
        !           539: integer s_rdfe(a) cilist *a;
        !           540: #else
        !           541: integer s_rdfe(cilist *a)
        !           542: #endif
        !           543: {
        !           544:        int n;
        !           545:        if(!f__init) f_init();
        !           546:        if(n=c_dfe(a))return(n);
        !           547:        f__reading=1;
        !           548:        if(f__curunit->uwrt && f__nowreading(f__curunit))
        !           549:                err(a->cierr,errno,"read start");
        !           550:        f__getn = y_getc;
        !           551:        f__doed = rd_ed;
        !           552:        f__doned = rd_ned;
        !           553:        f__dorevert = f__donewrec = y_err;
        !           554:        f__doend = y_rsk;
        !           555:        if(pars_f(f__fmtbuf)<0)
        !           556:                err(a->cierr,100,"read start");
        !           557:        fmt_bg();
        !           558:        return(0);
        !           559: }
        !           560: #ifdef KR_headers
        !           561: integer s_wdfe(a) cilist *a;
        !           562: #else
        !           563: integer s_wdfe(cilist *a)
        !           564: #endif
        !           565: {
        !           566:        int n;
        !           567:        if(!f__init) f_init();
        !           568:        if(n=c_dfe(a)) return(n);
        !           569:        f__reading=0;
        !           570:        if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
        !           571:                err(a->cierr,errno,"startwrt");
        !           572:        f__putn = y_putc;
        !           573:        f__doed = w_ed;
        !           574:        f__doned= w_ned;
        !           575:        f__dorevert = y_err;
        !           576:        f__donewrec = y_newrec;
        !           577:        f__doend = y_rev;
        !           578:        if(pars_f(f__fmtbuf)<0)
        !           579:                err(a->cierr,100,"startwrt");
        !           580:        fmt_bg();
        !           581:        return(0);
        !           582: }
        !           583: integer e_rdfe(Void)
        !           584: {
        !           585:        (void) en_fio();
        !           586:        return(0);
        !           587: }
        !           588: integer e_wdfe(Void)
        !           589: {
        !           590:        (void) en_fio();
        !           591:        return(0);
        !           592: }
        !           593: ./ ADD NAME=libI77/dolio.c TIME=719848230
        !           594: #include "f2c.h"
        !           595: 
        !           596: #ifdef __cplusplus
        !           597: extern "C" {
        !           598: #endif
        !           599: #ifdef KR_headers
        !           600: extern int (*f__lioproc)();
        !           601: 
        !           602: integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len;
        !           603: #else
        !           604: extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint);
        !           605: 
        !           606: integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len)
        !           607: #endif
        !           608: {
        !           609:        return((*f__lioproc)(number,ptr,len,*type));
        !           610: }
        !           611: #ifdef __cplusplus
        !           612:        }
        !           613: #endif
        !           614: ./ ADD NAME=libI77/due.c TIME=719848230
        !           615: #include "f2c.h"
        !           616: #include "fio.h"
        !           617: 
        !           618: #ifdef KR_headers
        !           619: c_due(a) cilist *a;
        !           620: #else
        !           621: c_due(cilist *a)
        !           622: #endif
        !           623: {
        !           624:        if(!f__init) f_init();
        !           625:        if(a->ciunit>=MXUNIT || a->ciunit<0)
        !           626:                err(a->cierr,101,"startio");
        !           627:        f__recpos=f__sequential=f__formatted=0;
        !           628:        f__external=1;
        !           629:        f__curunit = &f__units[a->ciunit];
        !           630:        f__elist=a;
        !           631:        if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due");
        !           632:        f__cf=f__curunit->ufd;
        !           633:        if(f__curunit->ufmt) err(a->cierr,102,"cdue")
        !           634:        if(!f__curunit->useek) err(a->cierr,104,"cdue")
        !           635:        if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue")
        !           636:        (void) fseek(f__cf,(long)(a->cirec-1)*f__curunit->url,SEEK_SET);
        !           637:        f__curunit->uend = 0;
        !           638:        return(0);
        !           639: }
        !           640: #ifdef KR_headers
        !           641: integer s_rdue(a) cilist *a;
        !           642: #else
        !           643: integer s_rdue(cilist *a)
        !           644: #endif
        !           645: {
        !           646:        int n;
        !           647:        if(n=c_due(a)) return(n);
        !           648:        f__reading=1;
        !           649:        if(f__curunit->uwrt && f__nowreading(f__curunit))
        !           650:                err(a->cierr,errno,"read start");
        !           651:        return(0);
        !           652: }
        !           653: #ifdef KR_headers
        !           654: integer s_wdue(a) cilist *a;
        !           655: #else
        !           656: integer s_wdue(cilist *a)
        !           657: #endif
        !           658: {
        !           659:        int n;
        !           660:        if(n=c_due(a)) return(n);
        !           661:        f__reading=0;
        !           662:        if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
        !           663:                err(a->cierr,errno,"write start");
        !           664:        return(0);
        !           665: }
        !           666: integer e_rdue(Void)
        !           667: {
        !           668:        if(f__curunit->url==1 || f__recpos==f__curunit->url)
        !           669:                return(0);
        !           670:        (void) fseek(f__cf,(long)(f__curunit->url-f__recpos),SEEK_CUR);
        !           671:        if(ftell(f__cf)%f__curunit->url)
        !           672:                err(f__elist->cierr,200,"syserr");
        !           673:        return(0);
        !           674: }
        !           675: integer e_wdue(Void)
        !           676: {
        !           677:        return(e_rdue());
        !           678: }
        !           679: ./ ADD NAME=libI77/endfile.c TIME=719848230
        !           680: #include "f2c.h"
        !           681: #include "fio.h"
        !           682: #include "sys/types.h"
        !           683: #include "fcntl.h"
        !           684: #include "rawio.h"
        !           685: #ifndef O_RDONLY
        !           686: #define O_RDONLY 0
        !           687: #endif
        !           688: 
        !           689: #ifdef KR_headers
        !           690: extern char *strcpy();
        !           691: #else
        !           692: #undef abs
        !           693: #undef min
        !           694: #undef max
        !           695: #include "stdlib.h"
        !           696: #include "string.h"
        !           697: #endif
        !           698: 
        !           699: 
        !           700: #ifdef KR_headers
        !           701: integer f_end(a) alist *a;
        !           702: #else
        !           703: integer f_end(alist *a)
        !           704: #endif
        !           705: {
        !           706:        unit *b;
        !           707:        if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
        !           708:        b = &f__units[a->aunit];
        !           709:        if(b->ufd==NULL) {
        !           710:                char nbuf[10];
        !           711:                (void) sprintf(nbuf,"fort.%ld",a->aunit);
        !           712:                close(creat(nbuf, 0666));
        !           713:                return(0);
        !           714:                }
        !           715:        b->uend=1;
        !           716:        return(b->useek ? t_runc(a) : 0);
        !           717: }
        !           718: 
        !           719:  static int
        !           720: #ifdef KR_headers
        !           721: copy(from, len, to) char *from, *to; register long len;
        !           722: #else
        !           723: copy(char *from, register long len, char *to)
        !           724: #endif
        !           725: {
        !           726:        register int n;
        !           727:        int k, rc = 0, tmp;
        !           728:        char buf[BUFSIZ];
        !           729: 
        !           730:        if ((k = open(from, O_RDONLY)) < 0)
        !           731:                return 1;
        !           732:        if ((tmp = creat(to,0666)) < 0)
        !           733:                return 1;
        !           734:        while((n = read(k, buf, len > BUFSIZ ? BUFSIZ : (int)len)) > 0) {
        !           735:                if (write(tmp, buf, n) != n)
        !           736:                        { rc = 1; break; }
        !           737:                if ((len -= n) <= 0)
        !           738:                        break;
        !           739:                }
        !           740:        close(k);
        !           741:        close(tmp);
        !           742:        return n < 0 ? 1 : rc;
        !           743:        }
        !           744: 
        !           745: #ifndef L_tmpnam
        !           746: #define L_tmpnam 16
        !           747: #endif
        !           748: 
        !           749:  int
        !           750: #ifdef KR_headers
        !           751: t_runc(a) alist *a;
        !           752: #else
        !           753: t_runc(alist *a)
        !           754: #endif
        !           755: {
        !           756:        char nm[L_tmpnam];
        !           757:        long loc, len;
        !           758:        unit *b;
        !           759:        int rc = 0;
        !           760: 
        !           761:        b = &f__units[a->aunit];
        !           762:        if(b->url) return(0);   /*don't truncate direct files*/
        !           763:        loc=ftell(b->ufd);
        !           764:        (void) fseek(b->ufd,0L,SEEK_END);
        !           765:        len=ftell(b->ufd);
        !           766:        if (loc >= len || b->useek == 0 || b->ufnm == NULL)
        !           767:                return(0);
        !           768:        rewind(b->ufd); /* empty buffer */
        !           769:        if (!loc) {
        !           770:                if (close(creat(b->ufnm,0666)))
        !           771:                        { rc = 1; goto done; }
        !           772:                if (b->uwrt)
        !           773:                        b->uwrt = 1;
        !           774:                return 0;
        !           775:                }
        !           776: #ifdef _POSIX_SOURCE
        !           777:        tmpnam(nm);
        !           778: #else
        !           779:        (void) strcpy(nm,"tmp.FXXXXXX");
        !           780:        (void) mktemp(nm);
        !           781: #endif
        !           782:        if (copy(b->ufnm, loc, nm)
        !           783:         || copy(nm, loc, b->ufnm))
        !           784:                rc = 1;
        !           785:        unlink(nm);
        !           786: done:
        !           787:        fseek(b->ufd, loc, SEEK_SET);
        !           788:        if (rc)
        !           789:                err(a->aerr,111,"endfile");
        !           790:        return 0;
        !           791:        }
        !           792: ./ ADD NAME=libI77/err.c TIME=719848230
        !           793: #ifndef MSDOS
        !           794: #include "sys/types.h"
        !           795: #include "sys/stat.h"
        !           796: #endif
        !           797: #include "f2c.h"
        !           798: #include "fio.h"
        !           799: #include "fcntl.h"
        !           800: #include "rawio.h"
        !           801: #include "fmt.h"       /* for struct syl */
        !           802: #ifdef NON_UNIX_STDIO
        !           803: #ifdef KR_headers
        !           804: extern char *malloc();
        !           805: #else
        !           806: #undef abs
        !           807: #undef min
        !           808: #undef max
        !           809: #include "stdlib.h"
        !           810: #endif
        !           811: #endif
        !           812: #ifndef O_WRONLY
        !           813: #define O_WRONLY 1
        !           814: #endif
        !           815: 
        !           816: /*global definitions*/
        !           817: unit f__units[MXUNIT]; /*unit table*/
        !           818: flag f__init;  /*0 on entry, 1 after initializations*/
        !           819: cilist *f__elist;      /*active external io list*/
        !           820: flag f__reading;       /*1 if reading, 0 if writing*/
        !           821: flag f__cplus,f__cblank;
        !           822: char *f__fmtbuf;
        !           823: flag f__external;      /*1 if external io, 0 if internal */
        !           824: #ifdef KR_headers
        !           825: int (*f__doed)(),(*f__doned)();
        !           826: int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)();
        !           827: int (*f__getn)(),(*f__putn)(); /*for formatted io*/
        !           828: #else
        !           829: int (*f__getn)(void),(*f__putn)(int);  /*for formatted io*/
        !           830: int (*f__doed)(struct f__syl*, char*, ftnlen),(*f__doned)(struct f__syl*);
        !           831: int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void);
        !           832: #endif
        !           833: flag f__sequential;    /*1 if sequential io, 0 if direct*/
        !           834: flag f__formatted;     /*1 if formatted io, 0 if unformatted*/
        !           835: FILE *f__cf;   /*current file*/
        !           836: unit *f__curunit;      /*current unit*/
        !           837: int f__recpos; /*place in current record*/
        !           838: int f__cursor,f__scale;
        !           839: 
        !           840: /*error messages*/
        !           841: char *F_err[] =
        !           842: {
        !           843:        "error in format",                              /* 100 */
        !           844:        "illegal unit number",                          /* 101 */
        !           845:        "formatted io not allowed",                     /* 102 */
        !           846:        "unformatted io not allowed",                   /* 103 */
        !           847:        "direct io not allowed",                        /* 104 */
        !           848:        "sequential io not allowed",                    /* 105 */
        !           849:        "can't backspace file",                         /* 106 */
        !           850:        "null file name",                               /* 107 */
        !           851:        "can't stat file",                              /* 108 */
        !           852:        "unit not connected",                           /* 109 */
        !           853:        "off end of record",                            /* 110 */
        !           854:        "truncation failed in endfile",                 /* 111 */
        !           855:        "incomprehensible list input",                  /* 112 */
        !           856:        "out of free space",                            /* 113 */
        !           857:        "unit not connected",                           /* 114 */
        !           858:        "read unexpected character",                    /* 115 */
        !           859:        "bad logical input field",                      /* 116 */
        !           860:        "bad variable type",                            /* 117 */
        !           861:        "bad namelist name",                            /* 118 */
        !           862:        "variable not in namelist",                     /* 119 */
        !           863:        "no end record",                                /* 120 */
        !           864:        "variable count incorrect",                     /* 121 */
        !           865:        "subscript for scalar variable",                /* 122 */
        !           866:        "invalid array section",                        /* 123 */
        !           867:        "substring out of bounds",                      /* 124 */
        !           868:        "subscript out of bounds",                      /* 125 */
        !           869:        "can't read file",                              /* 126 */
        !           870:        "can't write file",                             /* 127 */
        !           871:        "'new' file exists"                             /* 128 */
        !           872: };
        !           873: #define MAXERR (sizeof(F_err)/sizeof(char *)+100)
        !           874: 
        !           875: #ifdef KR_headers
        !           876: f__canseek(f) FILE *f; /*SYSDEP*/
        !           877: #else
        !           878: f__canseek(FILE *f) /*SYSDEP*/
        !           879: #endif
        !           880: {
        !           881: #ifdef MSDOS
        !           882:        return !isatty(fileno(f));
        !           883: #else
        !           884:        struct stat x;
        !           885: 
        !           886:        if (fstat(fileno(f),&x) < 0)
        !           887:                return(0);
        !           888: #ifdef S_IFMT
        !           889:        switch(x.st_mode & S_IFMT) {
        !           890:        case S_IFDIR:
        !           891:        case S_IFREG:
        !           892:                if(x.st_nlink > 0)      /* !pipe */
        !           893:                        return(1);
        !           894:                else
        !           895:                        return(0);
        !           896:        case S_IFCHR:
        !           897:                if(isatty(fileno(f)))
        !           898:                        return(0);
        !           899:                return(1);
        !           900: #ifdef S_IFBLK
        !           901:        case S_IFBLK:
        !           902:                return(1);
        !           903: #endif
        !           904:        }
        !           905: #else
        !           906: #ifdef S_ISDIR
        !           907:        /* POSIX version */
        !           908:        if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) {
        !           909:                if(x.st_nlink > 0)      /* !pipe */
        !           910:                        return(1);
        !           911:                else
        !           912:                        return(0);
        !           913:                }
        !           914:        if (S_ISCHR(x.st_mode)) {
        !           915:                if(isatty(fileno(f)))
        !           916:                        return(0);
        !           917:                return(1);
        !           918:                }
        !           919:        if (S_ISBLK(x.st_mode))
        !           920:                return(1);
        !           921: #else
        !           922:        Help! How does fstat work on this system?
        !           923: #endif
        !           924: #endif
        !           925:        return(0);      /* who knows what it is? */
        !           926: #endif
        !           927: }
        !           928: 
        !           929:  void
        !           930: #ifdef KR_headers
        !           931: f__fatal(n,s) char *s;
        !           932: #else
        !           933: f__fatal(int n, char *s)
        !           934: #endif
        !           935: {
        !           936:        if(n<100 && n>=0) perror(s); /*SYSDEP*/
        !           937:        else if(n >= (int)MAXERR || n < -1)
        !           938:        {       fprintf(stderr,"%s: illegal error number %d\n",s,n);
        !           939:        }
        !           940:        else if(n == -1) fprintf(stderr,"%s: end of file\n",s);
        !           941:        else
        !           942:                fprintf(stderr,"%s: %s\n",s,F_err[n-100]);
        !           943:        if (f__curunit) {
        !           944:                fprintf(stderr,"apparent state: unit %d ",f__curunit-f__units);
        !           945:                fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n",
        !           946:                        f__curunit->ufnm);
        !           947:                }
        !           948:        else
        !           949:                fprintf(stderr,"apparent state: internal I/O\n");
        !           950:        if (f__fmtbuf)
        !           951:                fprintf(stderr,"last format: %s\n",f__fmtbuf);
        !           952:        fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing",
        !           953:                f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted",
        !           954:                f__external?"external":"internal");
        !           955:        sig_die(" IO", 1);
        !           956: }
        !           957: /*initialization routine*/
        !           958:  VOID
        !           959: f_init(Void)
        !           960: {      unit *p;
        !           961: 
        !           962:        f__init=1;
        !           963:        p= &f__units[0];
        !           964:        p->ufd=stderr;
        !           965:        p->useek=f__canseek(stderr);
        !           966: #ifdef COMMENTED_OUT
        !           967:        if(isatty(fileno(stderr))) {
        !           968:                extern char *malloc();
        !           969:                setbuf(stderr, malloc(BUFSIZ));
        !           970:                /* setvbuf(stderr, _IOLBF, 0, 0); */
        !           971:        }       /* wastes space, but win for debugging in windows */
        !           972: #endif
        !           973: #ifdef NON_UNIX_STDIO
        !           974:        setbuf(stderr, malloc(BUFSIZ));
        !           975: #else
        !           976:        stderr->_flag &= ~_IONBF;
        !           977: #endif
        !           978:        p->ufmt=1;
        !           979:        p->uwrt=1;
        !           980:        p = &f__units[5];
        !           981:        p->ufd=stdin;
        !           982:        p->useek=f__canseek(stdin);
        !           983:        p->ufmt=1;
        !           984:        p->uwrt=0;
        !           985:        p= &f__units[6];
        !           986:        p->ufd=stdout;
        !           987:        p->useek=f__canseek(stdout);
        !           988:        /* IOLBUF and setvbuf only in system 5+ */
        !           989: #ifdef COMMENTED_OUT
        !           990:        if(isatty(fileno(stdout))) {
        !           991:                extern char _sobuf[];
        !           992:                setbuf(stdout, _sobuf);
        !           993:                /* setvbuf(stdout, _IOLBF, 0, 0);       /* the buf arg in setvbuf? */
        !           994:                p->useek = 1;   /* only within a record no bigger than BUFSIZ */
        !           995:        }
        !           996: #endif
        !           997:        p->ufmt=1;
        !           998:        p->uwrt=1;
        !           999: }
        !          1000: #ifdef KR_headers
        !          1001: f__nowreading(x) unit *x;
        !          1002: #else
        !          1003: f__nowreading(unit *x)
        !          1004: #endif
        !          1005: {
        !          1006:        long loc;
        !          1007:        extern char *r_mode[];
        !          1008:        if (!x->ufnm)
        !          1009:                goto cantread;
        !          1010:        loc=ftell(x->ufd);
        !          1011:        if(freopen(x->ufnm,r_mode[x->ufmt],x->ufd) == NULL) {
        !          1012:  cantread:
        !          1013:                errno = 126;
        !          1014:                return(1);
        !          1015:                }
        !          1016:        x->uwrt=0;
        !          1017:        (void) fseek(x->ufd,loc,SEEK_SET);
        !          1018:        return(0);
        !          1019: }
        !          1020: #ifdef KR_headers
        !          1021: f__nowwriting(x) unit *x;
        !          1022: #else
        !          1023: f__nowwriting(unit *x)
        !          1024: #endif
        !          1025: {
        !          1026:        long loc;
        !          1027:        int k;
        !          1028:        extern char *w_mode[];
        !          1029: 
        !          1030:        if (!x->ufnm)
        !          1031:                goto cantwrite;
        !          1032:        if (x->uwrt == 3) { /* just did write, rewind */
        !          1033:                if (close(creat(x->ufnm,0666)))
        !          1034:                        goto cantwrite;
        !          1035:                }
        !          1036:        else {
        !          1037:                loc=ftell(x->ufd);
        !          1038:                if (fclose(x->ufd) < 0
        !          1039:                || (k = x->uwrt == 2 ? creat(x->ufnm,0666)
        !          1040:                                     : open(x->ufnm,O_WRONLY)) < 0
        !          1041:                || (f__cf = x->ufd = fdopen(k,w_mode[x->ufmt])) == NULL) {
        !          1042:                        x->ufd = NULL;
        !          1043:  cantwrite:
        !          1044:                        errno = 127;
        !          1045:                        return(1);
        !          1046:                        }
        !          1047:                (void) fseek(x->ufd,loc,SEEK_SET);
        !          1048:                }
        !          1049:        x->uwrt = 1;
        !          1050:        return(0);
        !          1051: }
        !          1052: ./ ADD NAME=libI77/fio.h TIME=719848230
        !          1053: #include "stdio.h"
        !          1054: #include "errno.h"
        !          1055: #ifndef NULL
        !          1056: /* ANSI C */
        !          1057: #include "stddef.h"
        !          1058: #endif
        !          1059: 
        !          1060: #ifndef SEEK_SET
        !          1061: #define SEEK_SET 0
        !          1062: #define SEEK_CUR 1
        !          1063: #define SEEK_END 2
        !          1064: #endif
        !          1065: 
        !          1066: #ifdef MSDOS
        !          1067: #ifndef NON_UNIX_STDIO
        !          1068: #define NON_UNIX_STDIO
        !          1069: #endif
        !          1070: #endif
        !          1071: 
        !          1072: #ifdef UIOLEN_int
        !          1073: typedef int uiolen;
        !          1074: #else
        !          1075: typedef long uiolen;
        !          1076: #endif
        !          1077: 
        !          1078: /*units*/
        !          1079: typedef struct
        !          1080: {      FILE *ufd;      /*0=unconnected*/
        !          1081:        char *ufnm;
        !          1082: #ifndef MSDOS
        !          1083:        long uinode;
        !          1084:        int udev;
        !          1085: #endif
        !          1086:        int url;        /*0=sequential*/
        !          1087:        flag useek;     /*true=can backspace, use dir, ...*/
        !          1088:        flag ufmt;
        !          1089:        flag uprnt;
        !          1090:        flag ublnk;
        !          1091:        flag uend;
        !          1092:        flag uwrt;      /*last io was write*/
        !          1093:        flag uscrtch;
        !          1094: } unit;
        !          1095: 
        !          1096: extern flag f__init;
        !          1097: extern cilist *f__elist;       /*active external io list*/
        !          1098: extern flag f__reading,f__external,f__sequential,f__formatted;
        !          1099: #ifdef KR_headers
        !          1100: #define Void /*void*/
        !          1101: extern int (*f__getn)(),(*f__putn)();  /*for formatted io*/
        !          1102: extern long f__inode();
        !          1103: extern VOID sig_die();
        !          1104: extern int (*f__donewrec)(), t_putc(), x_wSL();
        !          1105: extern int c_sfe();
        !          1106: #else
        !          1107: #define Void void
        !          1108: #ifdef __cplusplus
        !          1109: extern "C" {
        !          1110: #endif
        !          1111: extern int (*f__getn)(void),(*f__putn)(int);   /*for formatted io*/
        !          1112: extern long f__inode(char*,int*);
        !          1113: extern void sig_die(char*,int);
        !          1114: extern void f__fatal(int,char*);
        !          1115: extern int t_runc(alist*);
        !          1116: extern int f__nowreading(unit*), f__nowwriting(unit*);
        !          1117: extern int fk_open(int,int,ftnint);
        !          1118: extern int en_fio(void);
        !          1119: extern void f_init(void);
        !          1120: extern int (*f__donewrec)(void), t_putc(int), x_wSL(void);
        !          1121: extern void b_char(char*,char*,ftnlen), g_char(char*,ftnlen,char*);
        !          1122: extern int c_sfe(cilist*), z_rnew(void);
        !          1123: extern int isatty(int);
        !          1124: #ifdef __cplusplus
        !          1125:        }
        !          1126: #endif
        !          1127: #endif
        !          1128: extern FILE *f__cf;    /*current file*/
        !          1129: extern unit *f__curunit;       /*current unit*/
        !          1130: extern unit f__units[];
        !          1131: #define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);}
        !          1132: 
        !          1133: /*Table sizes*/
        !          1134: #define MXUNIT 100
        !          1135: 
        !          1136: extern int f__recpos;  /*position in current record*/
        !          1137: extern int f__cursor;  /* offset to move to */
        !          1138: extern int f__hiwater; /* so TL doesn't confuse us */
        !          1139: 
        !          1140: #define WRITE  1
        !          1141: #define READ   2
        !          1142: #define SEQ    3
        !          1143: #define DIR    4
        !          1144: #define FMT    5
        !          1145: #define UNF    6
        !          1146: #define EXT    7
        !          1147: #define INT    8
        !          1148: 
        !          1149: #define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ)
        !          1150: #ifdef __cplusplus
        !          1151: extern "C" {
        !          1152: extern long int f_back(alist *);
        !          1153: extern long int f_clos(cllist *);
        !          1154: extern void f_exit(void);
        !          1155: extern void flush_(void);
        !          1156: extern int y_rsk(void);
        !          1157: extern int y_getc(void);
        !          1158: extern int y_putc(int);
        !          1159: extern int y_rev(void);
        !          1160: extern int y_err(void);
        !          1161: extern int y_newrec(void);
        !          1162: extern int c_dfe(cilist *);
        !          1163: extern long int s_rdfe(cilist *);
        !          1164: extern long int s_wdfe(cilist *);
        !          1165: extern long int e_rdfe(void);
        !          1166: extern long int e_wdfe(void);
        !          1167: extern long int do_lio(long int *, long int *, char *, long int);
        !          1168: extern int c_due(cilist *);
        !          1169: extern long int s_rdue(cilist *);
        !          1170: extern long int s_wdue(cilist *);
        !          1171: extern long int e_rdue(void);
        !          1172: extern long int e_wdue(void);
        !          1173: extern long int f_end(alist *);
        !          1174: extern int f__canseek(struct _iobuf *);
        !          1175: extern char *ap_end(char *);
        !          1176: extern int op_gen(int, int, int, int);
        !          1177: extern char *gt_num(char *, int *);
        !          1178: extern char *f_s(char *, int);
        !          1179: extern int ne_d(char *, char **);
        !          1180: extern int e_d(char *, char **);
        !          1181: extern char *i_tem(char *);
        !          1182: extern char *f_list(char *);
        !          1183: extern int pars_f(char *);
        !          1184: extern int type_f(int);
        !          1185: extern long int do_fio(long int *, char *, long int);
        !          1186: extern void fmt_bg(void);
        !          1187: extern char *f__icvt(long int, int *, int *, int);
        !          1188: extern int z_getc(void);
        !          1189: extern int z_putc(int);
        !          1190: extern int c_si(icilist *);
        !          1191: extern int y_ierr(void);
        !          1192: extern long int s_rsfi(icilist *);
        !          1193: extern int z_wnew(void);
        !          1194: extern long int s_wsfi(icilist *);
        !          1195: extern long int e_rsfi(void);
        !          1196: extern long int e_wsfi(void);
        !          1197: extern void c_liw(icilist *);
        !          1198: extern int s_wsni(icilist *);
        !          1199: extern long int s_wsli(icilist *);
        !          1200: extern long int e_wsli(void);
        !          1201: extern long int f_inqu(inlist *);
        !          1202: extern int t_getc(void);
        !          1203: extern long int e_rsle(void);
        !          1204: extern int l_R(int);
        !          1205: extern int l_C(void);
        !          1206: extern int l_L(void);
        !          1207: extern int l_CHAR(void);
        !          1208: extern int c_le(cilist *);
        !          1209: extern int l_read(long int *, char *, long int, long int);
        !          1210: extern long int s_rsle(cilist *);
        !          1211: extern char *mktemp(char *);
        !          1212: extern int f__isdev(char *);
        !          1213: extern long int f_open(olist *);
        !          1214: extern long int f_rew(alist *);
        !          1215: extern int xrd_SL(void);
        !          1216: extern int x_getc(void);
        !          1217: extern int x_endp(void);
        !          1218: extern int x_rev(void);
        !          1219: extern long int s_rsfe(cilist *);
        !          1220: extern int i_getc(void);
        !          1221: extern int i_ungetc(int, struct _iobuf *);
        !          1222: extern long int s_rsli(icilist *);
        !          1223: extern long int e_rsli(void);
        !          1224: extern int s_rsni(icilist *);
        !          1225: extern int x_rsne(cilist *);
        !          1226: extern long int s_rsne(cilist *);
        !          1227: extern long int e_rsfe(void);
        !          1228: extern long int e_wsfe(void);
        !          1229: extern int c_sue(cilist *);
        !          1230: extern long int s_rsue(cilist *);
        !          1231: extern long int s_wsue(cilist *);
        !          1232: extern long int e_wsue(void);
        !          1233: extern long int e_rsue(void);
        !          1234: extern int do_us(long int *, char *, long int);
        !          1235: extern long int do_ud(long int *, char *, long int);
        !          1236: extern long int do_uio(long int *, char *, long int);
        !          1237: extern long int f__inode(char *, int *);
        !          1238: extern void f__mvgbt(int, int, char *, char *);
        !          1239: extern int mv_cur(void);
        !          1240: extern int x_putc(int);
        !          1241: extern int xw_end(void);
        !          1242: extern int xw_rev(void);
        !          1243: extern long int s_wsfe(cilist *);
        !          1244: extern long int s_wsle(cilist *);
        !          1245: extern long int e_wsle(void);
        !          1246: extern long int s_wsne(cilist *);
        !          1247: extern void x_wsne(cilist *);
        !          1248:        }
        !          1249: #endif
        !          1250: ./ ADD NAME=libI77/fmt.c TIME=719848230
        !          1251: #include "f2c.h"
        !          1252: #include "fio.h"
        !          1253: #include "fmt.h"
        !          1254: #define skip(s) while(*s==' ') s++
        !          1255: #ifdef interdata
        !          1256: #define SYLMX 300
        !          1257: #endif
        !          1258: #ifdef pdp11
        !          1259: #define SYLMX 300
        !          1260: #endif
        !          1261: #ifdef vax
        !          1262: #define SYLMX 300
        !          1263: #endif
        !          1264: #ifndef SYLMX
        !          1265: #define SYLMX 300
        !          1266: #endif
        !          1267: #define GLITCH '\2'
        !          1268:        /* special quote character for stu */
        !          1269: extern int f__cursor,f__scale;
        !          1270: extern flag f__cblank,f__cplus;        /*blanks in I and compulsory plus*/
        !          1271: struct f__syl f__syl[SYLMX];
        !          1272: int f__parenlvl,f__pc,f__revloc;
        !          1273: 
        !          1274: #ifdef KR_headers
        !          1275: char *ap_end(s) char *s;
        !          1276: #else
        !          1277: char *ap_end(char *s)
        !          1278: #endif
        !          1279: {      char quote;
        !          1280:        quote= *s++;
        !          1281:        for(;*s;s++)
        !          1282:        {       if(*s!=quote) continue;
        !          1283:                if(*++s!=quote) return(s);
        !          1284:        }
        !          1285:        if(f__elist->cierr) {
        !          1286:                errno = 100;
        !          1287:                return(NULL);
        !          1288:        }
        !          1289:        f__fatal(100, "bad string");
        !          1290:        /*NOTREACHED*/ return 0;
        !          1291: }
        !          1292: #ifdef KR_headers
        !          1293: op_gen(a,b,c,d)
        !          1294: #else
        !          1295: op_gen(int a, int b, int c, int d)
        !          1296: #endif
        !          1297: {      struct f__syl *p= &f__syl[f__pc];
        !          1298:        if(f__pc>=SYLMX)
        !          1299:        {       fprintf(stderr,"format too complicated:\n");
        !          1300:                sig_die(f__fmtbuf, 1);
        !          1301:        }
        !          1302:        p->op=a;
        !          1303:        p->p1=b;
        !          1304:        p->p2=c;
        !          1305:        p->p3=d;
        !          1306:        return(f__pc++);
        !          1307: }
        !          1308: #ifdef KR_headers
        !          1309: char *f_list();
        !          1310: char *gt_num(s,n) char *s; int *n;
        !          1311: #else
        !          1312: char *f_list(char*);
        !          1313: char *gt_num(char *s, int *n)
        !          1314: #endif
        !          1315: {      int m=0,f__cnt=0;
        !          1316:        char c;
        !          1317:        for(c= *s;;c = *s)
        !          1318:        {       if(c==' ')
        !          1319:                {       s++;
        !          1320:                        continue;
        !          1321:                }
        !          1322:                if(c>'9' || c<'0') break;
        !          1323:                m=10*m+c-'0';
        !          1324:                f__cnt++;
        !          1325:                s++;
        !          1326:        }
        !          1327:        if(f__cnt==0) *n=1;
        !          1328:        else *n=m;
        !          1329:        return(s);
        !          1330: }
        !          1331: #ifdef KR_headers
        !          1332: char *f_s(s,curloc) char *s;
        !          1333: #else
        !          1334: char *f_s(char *s, int curloc)
        !          1335: #endif
        !          1336: {
        !          1337:        skip(s);
        !          1338:        if(*s++!='(')
        !          1339:        {
        !          1340:                return(NULL);
        !          1341:        }
        !          1342:        if(f__parenlvl++ ==1) f__revloc=curloc;
        !          1343:        if(op_gen(RET1,curloc,0,0)<0 ||
        !          1344:                (s=f_list(s))==NULL)
        !          1345:        {
        !          1346:                return(NULL);
        !          1347:        }
        !          1348:        skip(s);
        !          1349:        return(s);
        !          1350: }
        !          1351: #ifdef KR_headers
        !          1352: ne_d(s,p) char *s,**p;
        !          1353: #else
        !          1354: ne_d(char *s, char **p)
        !          1355: #endif
        !          1356: {      int n,x,sign=0;
        !          1357:        struct f__syl *sp;
        !          1358:        switch(*s)
        !          1359:        {
        !          1360:        default:
        !          1361:                return(0);
        !          1362:        case ':': (void) op_gen(COLON,0,0,0); break;
        !          1363:        case '$':
        !          1364:                (void) op_gen(NONL, 0, 0, 0); break;
        !          1365:        case 'B':
        !          1366:        case 'b':
        !          1367:                if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0);
        !          1368:                else (void) op_gen(BN,0,0,0);
        !          1369:                break;
        !          1370:        case 'S':
        !          1371:        case 's':
        !          1372:                if(*(s+1)=='s' || *(s+1) == 'S')
        !          1373:                {       x=SS;
        !          1374:                        s++;
        !          1375:                }
        !          1376:                else if(*(s+1)=='p' || *(s+1) == 'P')
        !          1377:                {       x=SP;
        !          1378:                        s++;
        !          1379:                }
        !          1380:                else x=S;
        !          1381:                (void) op_gen(x,0,0,0);
        !          1382:                break;
        !          1383:        case '/': (void) op_gen(SLASH,0,0,0); break;
        !          1384:        case '-': sign=1;
        !          1385:        case '+':       s++;    /*OUTRAGEOUS CODING TRICK*/
        !          1386:        case '0': case '1': case '2': case '3': case '4':
        !          1387:        case '5': case '6': case '7': case '8': case '9':
        !          1388:                s=gt_num(s,&n);
        !          1389:                switch(*s)
        !          1390:                {
        !          1391:                default:
        !          1392:                        return(0);
        !          1393:                case 'P':
        !          1394:                case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break;
        !          1395:                case 'X':
        !          1396:                case 'x': (void) op_gen(X,n,0,0); break;
        !          1397:                case 'H':
        !          1398:                case 'h':
        !          1399:                        sp = &f__syl[op_gen(H,n,0,0)];
        !          1400:                        *(char **)&sp->p2 = s + 1;
        !          1401:                        s+=n;
        !          1402:                        break;
        !          1403:                }
        !          1404:                break;
        !          1405:        case GLITCH:
        !          1406:        case '"':
        !          1407:        case '\'':
        !          1408:                sp = &f__syl[op_gen(APOS,0,0,0)];
        !          1409:                *(char **)&sp->p2 = s;
        !          1410:                if((*p = ap_end(s)) == NULL)
        !          1411:                        return(0);
        !          1412:                return(1);
        !          1413:        case 'T':
        !          1414:        case 't':
        !          1415:                if(*(s+1)=='l' || *(s+1) == 'L')
        !          1416:                {       x=TL;
        !          1417:                        s++;
        !          1418:                }
        !          1419:                else if(*(s+1)=='r'|| *(s+1) == 'R')
        !          1420:                {       x=TR;
        !          1421:                        s++;
        !          1422:                }
        !          1423:                else x=T;
        !          1424:                s=gt_num(s+1,&n);
        !          1425:                s--;
        !          1426:                (void) op_gen(x,n,0,0);
        !          1427:                break;
        !          1428:        case 'X':
        !          1429:        case 'x': (void) op_gen(X,1,0,0); break;
        !          1430:        case 'P':
        !          1431:        case 'p': (void) op_gen(P,1,0,0); break;
        !          1432:        }
        !          1433:        s++;
        !          1434:        *p=s;
        !          1435:        return(1);
        !          1436: }
        !          1437: #ifdef KR_headers
        !          1438: e_d(s,p) char *s,**p;
        !          1439: #else
        !          1440: e_d(char *s, char **p)
        !          1441: #endif
        !          1442: {      int i,im,n,w,d,e,found=0,x=0;
        !          1443:        char *sv=s;
        !          1444:        s=gt_num(s,&n);
        !          1445:        (void) op_gen(STACK,n,0,0);
        !          1446:        switch(*s++)
        !          1447:        {
        !          1448:        default: break;
        !          1449:        case 'E':
        !          1450:        case 'e':       x=1;
        !          1451:        case 'G':
        !          1452:        case 'g':
        !          1453:                found=1;
        !          1454:                s=gt_num(s,&w);
        !          1455:                if(w==0) break;
        !          1456:                if(*s=='.')
        !          1457:                {       s++;
        !          1458:                        s=gt_num(s,&d);
        !          1459:                }
        !          1460:                else d=0;
        !          1461:                if(*s!='E' && *s != 'e')
        !          1462:                        (void) op_gen(x==1?E:G,w,d,0);  /* default is Ew.dE2 */
        !          1463:                else
        !          1464:                {       s++;
        !          1465:                        s=gt_num(s,&e);
        !          1466:                        (void) op_gen(x==1?EE:GE,w,d,e);
        !          1467:                }
        !          1468:                break;
        !          1469:        case 'O':
        !          1470:        case 'o':
        !          1471:                i = O;
        !          1472:                im = OM;
        !          1473:                goto finish_I;
        !          1474:        case 'Z':
        !          1475:        case 'z':
        !          1476:                i = Z;
        !          1477:                im = ZM;
        !          1478:                goto finish_I;
        !          1479:        case 'L':
        !          1480:        case 'l':
        !          1481:                found=1;
        !          1482:                s=gt_num(s,&w);
        !          1483:                if(w==0) break;
        !          1484:                (void) op_gen(L,w,0,0);
        !          1485:                break;
        !          1486:        case 'A':
        !          1487:        case 'a':
        !          1488:                found=1;
        !          1489:                skip(s);
        !          1490:                if(*s>='0' && *s<='9')
        !          1491:                {       s=gt_num(s,&w);
        !          1492:                        if(w==0) break;
        !          1493:                        (void) op_gen(AW,w,0,0);
        !          1494:                        break;
        !          1495:                }
        !          1496:                (void) op_gen(A,0,0,0);
        !          1497:                break;
        !          1498:        case 'F':
        !          1499:        case 'f':
        !          1500:                found=1;
        !          1501:                s=gt_num(s,&w);
        !          1502:                if(w==0) break;
        !          1503:                if(*s=='.')
        !          1504:                {       s++;
        !          1505:                        s=gt_num(s,&d);
        !          1506:                }
        !          1507:                else d=0;
        !          1508:                (void) op_gen(F,w,d,0);
        !          1509:                break;
        !          1510:        case 'D':
        !          1511:        case 'd':
        !          1512:                found=1;
        !          1513:                s=gt_num(s,&w);
        !          1514:                if(w==0) break;
        !          1515:                if(*s=='.')
        !          1516:                {       s++;
        !          1517:                        s=gt_num(s,&d);
        !          1518:                }
        !          1519:                else d=0;
        !          1520:                (void) op_gen(D,w,d,0);
        !          1521:                break;
        !          1522:        case 'I':
        !          1523:        case 'i':
        !          1524:                i = I;
        !          1525:                im = IM;
        !          1526:  finish_I:
        !          1527:                found=1;
        !          1528:                s=gt_num(s,&w);
        !          1529:                if(w==0) break;
        !          1530:                if(*s!='.')
        !          1531:                {       (void) op_gen(i,w,0,0);
        !          1532:                        break;
        !          1533:                }
        !          1534:                s++;
        !          1535:                s=gt_num(s,&d);
        !          1536:                (void) op_gen(im,w,d,0);
        !          1537:                break;
        !          1538:        }
        !          1539:        if(found==0)
        !          1540:        {       f__pc--; /*unSTACK*/
        !          1541:                *p=sv;
        !          1542:                return(0);
        !          1543:        }
        !          1544:        *p=s;
        !          1545:        return(1);
        !          1546: }
        !          1547: #ifdef KR_headers
        !          1548: char *i_tem(s) char *s;
        !          1549: #else
        !          1550: char *i_tem(char *s)
        !          1551: #endif
        !          1552: {      char *t;
        !          1553:        int n,curloc;
        !          1554:        if(*s==')') return(s);
        !          1555:        if(ne_d(s,&t)) return(t);
        !          1556:        if(e_d(s,&t)) return(t);
        !          1557:        s=gt_num(s,&n);
        !          1558:        if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
        !          1559:        return(f_s(s,curloc));
        !          1560: }
        !          1561: #ifdef KR_headers
        !          1562: char *f_list(s) char *s;
        !          1563: #else
        !          1564: char *f_list(char *s)
        !          1565: #endif
        !          1566: {
        !          1567:        for(;*s!=0;)
        !          1568:        {       skip(s);
        !          1569:                if((s=i_tem(s))==NULL) return(NULL);
        !          1570:                skip(s);
        !          1571:                if(*s==',') s++;
        !          1572:                else if(*s==')')
        !          1573:                {       if(--f__parenlvl==0)
        !          1574:                        {
        !          1575:                                (void) op_gen(REVERT,f__revloc,0,0);
        !          1576:                                return(++s);
        !          1577:                        }
        !          1578:                        (void) op_gen(GOTO,0,0,0);
        !          1579:                        return(++s);
        !          1580:                }
        !          1581:        }
        !          1582:        return(NULL);
        !          1583: }
        !          1584: 
        !          1585: #ifdef KR_headers
        !          1586: pars_f(s) char *s;
        !          1587: #else
        !          1588: pars_f(char *s)
        !          1589: #endif
        !          1590: {
        !          1591:        f__parenlvl=f__revloc=f__pc=0;
        !          1592:        if(f_s(s,0) == NULL)
        !          1593:        {
        !          1594:                return(-1);
        !          1595:        }
        !          1596:        return(0);
        !          1597: }
        !          1598: #define STKSZ 10
        !          1599: int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp;
        !          1600: flag f__workdone, f__nonl;
        !          1601: 
        !          1602: #ifdef KR_headers
        !          1603: type_f(n)
        !          1604: #else
        !          1605: type_f(int n)
        !          1606: #endif
        !          1607: {
        !          1608:        switch(n)
        !          1609:        {
        !          1610:        default:
        !          1611:                return(n);
        !          1612:        case RET1:
        !          1613:                return(RET1);
        !          1614:        case REVERT: return(REVERT);
        !          1615:        case GOTO: return(GOTO);
        !          1616:        case STACK: return(STACK);
        !          1617:        case X:
        !          1618:        case SLASH:
        !          1619:        case APOS: case H:
        !          1620:        case T: case TL: case TR:
        !          1621:                return(NED);
        !          1622:        case F:
        !          1623:        case I:
        !          1624:        case IM:
        !          1625:        case A: case AW:
        !          1626:        case O: case OM:
        !          1627:        case L:
        !          1628:        case E: case EE: case D:
        !          1629:        case G: case GE:
        !          1630:        case Z: case ZM:
        !          1631:                return(ED);
        !          1632:        }
        !          1633: }
        !          1634: #ifdef KR_headers
        !          1635: integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
        !          1636: #else
        !          1637: integer do_fio(ftnint *number, char *ptr, ftnlen len)
        !          1638: #endif
        !          1639: {      struct f__syl *p;
        !          1640:        int n,i;
        !          1641:        for(i=0;i<*number;i++,ptr+=len)
        !          1642:        {
        !          1643: loop:  switch(type_f((p= &f__syl[f__pc])->op))
        !          1644:        {
        !          1645:        default:
        !          1646:                fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
        !          1647:                        p->op,f__fmtbuf);
        !          1648:                err(f__elist->cierr,100,"do_fio");
        !          1649:        case NED:
        !          1650:                if((*f__doned)(p))
        !          1651:                {       f__pc++;
        !          1652:                        goto loop;
        !          1653:                }
        !          1654:                f__pc++;
        !          1655:                continue;
        !          1656:        case ED:
        !          1657:                if(f__cnt[f__cp]<=0)
        !          1658:                {       f__cp--;
        !          1659:                        f__pc++;
        !          1660:                        goto loop;
        !          1661:                }
        !          1662:                if(ptr==NULL)
        !          1663:                        return((*f__doend)());
        !          1664:                f__cnt[f__cp]--;
        !          1665:                f__workdone=1;
        !          1666:                if((n=(*f__doed)(p,ptr,len))>0) err(f__elist->cierr,errno,"fmt");
        !          1667:                if(n<0) err(f__elist->ciend,(EOF),"fmt");
        !          1668:                continue;
        !          1669:        case STACK:
        !          1670:                f__cnt[++f__cp]=p->p1;
        !          1671:                f__pc++;
        !          1672:                goto loop;
        !          1673:        case RET1:
        !          1674:                f__ret[++f__rp]=p->p1;
        !          1675:                f__pc++;
        !          1676:                goto loop;
        !          1677:        case GOTO:
        !          1678:                if(--f__cnt[f__cp]<=0)
        !          1679:                {       f__cp--;
        !          1680:                        f__rp--;
        !          1681:                        f__pc++;
        !          1682:                        goto loop;
        !          1683:                }
        !          1684:                f__pc=1+f__ret[f__rp--];
        !          1685:                goto loop;
        !          1686:        case REVERT:
        !          1687:                f__rp=f__cp=0;
        !          1688:                f__pc = p->p1;
        !          1689:                if(ptr==NULL)
        !          1690:                        return((*f__doend)());
        !          1691:                if(!f__workdone) return(0);
        !          1692:                if((n=(*f__dorevert)()) != 0) return(n);
        !          1693:                goto loop;
        !          1694:        case COLON:
        !          1695:                if(ptr==NULL)
        !          1696:                        return((*f__doend)());
        !          1697:                f__pc++;
        !          1698:                goto loop;
        !          1699:        case NONL:
        !          1700:                f__nonl = 1;
        !          1701:                f__pc++;
        !          1702:                goto loop;
        !          1703:        case S:
        !          1704:        case SS:
        !          1705:                f__cplus=0;
        !          1706:                f__pc++;
        !          1707:                goto loop;
        !          1708:        case SP:
        !          1709:                f__cplus = 1;
        !          1710:                f__pc++;
        !          1711:                goto loop;
        !          1712:        case P: f__scale=p->p1;
        !          1713:                f__pc++;
        !          1714:                goto loop;
        !          1715:        case BN:
        !          1716:                f__cblank=0;
        !          1717:                f__pc++;
        !          1718:                goto loop;
        !          1719:        case BZ:
        !          1720:                f__cblank=1;
        !          1721:                f__pc++;
        !          1722:                goto loop;
        !          1723:        }
        !          1724:        }
        !          1725:        return(0);
        !          1726: }
        !          1727: en_fio(Void)
        !          1728: {      ftnint one=1;
        !          1729:        return(do_fio(&one,(char *)NULL,(ftnint)0));
        !          1730: }
        !          1731:  VOID
        !          1732: fmt_bg(Void)
        !          1733: {
        !          1734:        f__workdone=f__cp=f__rp=f__pc=f__cursor=0;
        !          1735:        f__cnt[0]=f__ret[0]=0;
        !          1736: }
        !          1737: ./ ADD NAME=libI77/fmt.h TIME=719848230
        !          1738: struct f__syl
        !          1739: {      int op,p1,p2,p3;
        !          1740: };
        !          1741: #define RET1 1
        !          1742: #define REVERT 2
        !          1743: #define GOTO 3
        !          1744: #define X 4
        !          1745: #define SLASH 5
        !          1746: #define STACK 6
        !          1747: #define I 7
        !          1748: #define ED 8
        !          1749: #define NED 9
        !          1750: #define IM 10
        !          1751: #define APOS 11
        !          1752: #define H 12
        !          1753: #define TL 13
        !          1754: #define TR 14
        !          1755: #define T 15
        !          1756: #define COLON 16
        !          1757: #define S 17
        !          1758: #define SP 18
        !          1759: #define SS 19
        !          1760: #define P 20
        !          1761: #define BN 21
        !          1762: #define BZ 22
        !          1763: #define F 23
        !          1764: #define E 24
        !          1765: #define EE 25
        !          1766: #define D 26
        !          1767: #define G 27
        !          1768: #define GE 28
        !          1769: #define L 29
        !          1770: #define A 30
        !          1771: #define AW 31
        !          1772: #define O 32
        !          1773: #define NONL 33
        !          1774: #define OM 34
        !          1775: #define Z 35
        !          1776: #define ZM 36
        !          1777: extern struct f__syl f__syl[];
        !          1778: extern int f__pc,f__parenlvl,f__revloc;
        !          1779: typedef union
        !          1780: {      real pf;
        !          1781:        doublereal pd;
        !          1782: } ufloat;
        !          1783: typedef union
        !          1784: {      short is;
        !          1785:        char ic;
        !          1786:        long il;
        !          1787: } Uint;
        !          1788: #ifdef KR_headers
        !          1789: extern int (*f__doed)(),(*f__doned)();
        !          1790: extern int (*f__dorevert)(), (*f__doend)();
        !          1791: extern int rd_ed(),rd_ned();
        !          1792: extern int w_ed(),w_ned();
        !          1793: #else
        !          1794: #ifdef __cplusplus
        !          1795: extern "C" {
        !          1796: #endif
        !          1797: extern int (*f__doed)(struct f__syl*, char*, ftnlen),(*f__doned)(struct f__syl*);
        !          1798: extern int (*f__dorevert)(void), (*f__doend)(void);
        !          1799: extern void fmt_bg(void);
        !          1800: extern int pars_f(char*);
        !          1801: extern int rd_ed(struct f__syl*, char*, ftnlen),rd_ned(struct f__syl*);
        !          1802: extern int w_ed(struct f__syl*, char*, ftnlen),w_ned(struct f__syl*);
        !          1803: extern int wrt_E(ufloat*, int, int, int, ftnlen);
        !          1804: extern int wrt_F(ufloat*, int, int, ftnlen);
        !          1805: extern int wrt_L(Uint*, int, ftnlen);
        !          1806: #ifdef __cplusplus
        !          1807:        }
        !          1808: #endif
        !          1809: #endif
        !          1810: extern flag f__cblank,f__cplus,f__workdone, f__nonl;
        !          1811: extern char *f__fmtbuf;
        !          1812: extern int f__scale;
        !          1813: #define GET(x) if((x=(*f__getn)())<0) return(x)
        !          1814: #define VAL(x) (x!='\n'?x:' ')
        !          1815: #define PUT(x) (*f__putn)(x)
        !          1816: extern int f__cursor;
        !          1817: ./ ADD NAME=libI77/fmtlib.c TIME=719848230
        !          1818: /*     @(#)fmtlib.c    1.2     */
        !          1819: #define MAXINTLENGTH 23
        !          1820: #ifdef __cplusplus
        !          1821: extern "C" {
        !          1822: #endif
        !          1823: #ifdef KR_headers
        !          1824: char *f__icvt(value,ndigit,sign, base) long value; int *ndigit,*sign;
        !          1825:  register int base;
        !          1826: #else
        !          1827: char *f__icvt(long value, int *ndigit, int *sign, int base)
        !          1828: #endif
        !          1829: {      static char buf[MAXINTLENGTH+1];
        !          1830:        register int i;
        !          1831:        if(value>0) *sign=0;
        !          1832:        else if(value<0)
        !          1833:        {       value = -value;
        !          1834:                *sign= 1;
        !          1835:        }
        !          1836:        else
        !          1837:        {       *sign=0;
        !          1838:                *ndigit=1;
        !          1839:                buf[MAXINTLENGTH]='0';
        !          1840:                return(&buf[MAXINTLENGTH]);
        !          1841:        }
        !          1842:        for(i=MAXINTLENGTH-1;value>0;i--)
        !          1843:        {       *(buf+i)=(int)(value%base)+'0';
        !          1844:                value /= base;
        !          1845:        }
        !          1846:        *ndigit=MAXINTLENGTH-1-i;
        !          1847:        return(&buf[i+1]);
        !          1848: }
        !          1849: #ifdef __cplusplus
        !          1850:        }
        !          1851: #endif
        !          1852: ./ ADD NAME=libI77/fp.h TIME=580998005
        !          1853: #define FMAX 40
        !          1854: #define EXPMAXDIGS 8
        !          1855: #define EXPMAX 99999999
        !          1856: /* FMAX = max number of nonzero digits passed to atof() */
        !          1857: /* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */
        !          1858: 
        !          1859: #include "local.h"
        !          1860: 
        !          1861: /* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily
        !          1862:    tight) on the maximum number of digits to the right and left of
        !          1863:  * the decimal point.
        !          1864:  */
        !          1865: 
        !          1866: #ifdef VAX
        !          1867: #define MAXFRACDIGS 56
        !          1868: #define MAXINTDIGS 38
        !          1869: #else
        !          1870: #ifdef CRAY
        !          1871: #define MAXFRACDIGS 9880
        !          1872: #define MAXINTDIGS 9864
        !          1873: #else
        !          1874: /* values that suffice for IEEE double */
        !          1875: #define MAXFRACDIGS 344
        !          1876: #define MAXINTDIGS 308
        !          1877: #endif
        !          1878: #endif
        !          1879: ./ ADD NAME=libI77/iio.c TIME=719848231
        !          1880: #include "f2c.h"
        !          1881: #include "fio.h"
        !          1882: #include "fmt.h"
        !          1883: extern char *f__icptr;
        !          1884: char *f__icend;
        !          1885: extern icilist *f__svic;
        !          1886: int f__icnum;
        !          1887: extern int f__hiwater;
        !          1888: z_getc(Void)
        !          1889: {
        !          1890:        if(f__recpos++ < f__svic->icirlen) {
        !          1891:                if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile");
        !          1892:                return(*f__icptr++);
        !          1893:                }
        !          1894:        err(f__svic->icierr,110,"recend");
        !          1895: }
        !          1896: #ifdef KR_headers
        !          1897: z_putc(c)
        !          1898: #else
        !          1899: z_putc(int c)
        !          1900: #endif
        !          1901: {
        !          1902:        if(f__icptr >= f__icend) err(f__svic->icierr,110,"inwrite");
        !          1903:        if(f__recpos++ < f__svic->icirlen)
        !          1904:                *f__icptr++ = c;
        !          1905:        else    err(f__svic->icierr,110,"recend");
        !          1906:        return 0;
        !          1907: }
        !          1908: z_rnew(Void)
        !          1909: {
        !          1910:        f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen;
        !          1911:        f__recpos = 0;
        !          1912:        f__cursor = 0;
        !          1913:        f__hiwater = 0;
        !          1914:        return 1;
        !          1915: }
        !          1916: 
        !          1917:  static int
        !          1918: z_endp(Void)
        !          1919: {
        !          1920:        (*f__donewrec)();
        !          1921:        return 0;
        !          1922:        }
        !          1923: 
        !          1924: #ifdef KR_headers
        !          1925: c_si(a) icilist *a;
        !          1926: #else
        !          1927: c_si(icilist *a)
        !          1928: #endif
        !          1929: {
        !          1930:        f__elist = (cilist *)a;
        !          1931:        f__fmtbuf=a->icifmt;
        !          1932:        if(pars_f(f__fmtbuf)<0)
        !          1933:                err(a->icierr,100,"startint");
        !          1934:        fmt_bg();
        !          1935:        f__sequential=f__formatted=1;
        !          1936:        f__external=0;
        !          1937:        f__cblank=f__cplus=f__scale=0;
        !          1938:        f__svic=a;
        !          1939:        f__icnum=f__recpos=0;
        !          1940:        f__cursor = 0;
        !          1941:        f__hiwater = 0;
        !          1942:        f__icptr = a->iciunit;
        !          1943:        f__icend = f__icptr + a->icirlen*a->icirnum;
        !          1944:        f__curunit = 0;
        !          1945:        f__cf = 0;
        !          1946:        return(0);
        !          1947: }
        !          1948: y_ierr(Void)
        !          1949: {
        !          1950:        err(f__elist->cierr, 110, "iio");
        !          1951: }
        !          1952: #ifdef KR_headers
        !          1953: integer s_rsfi(a) icilist *a;
        !          1954: #else
        !          1955: integer s_rsfi(icilist *a)
        !          1956: #endif
        !          1957: {      int n;
        !          1958:        if(n=c_si(a)) return(n);
        !          1959:        f__reading=1;
        !          1960:        f__doed=rd_ed;
        !          1961:        f__doned=rd_ned;
        !          1962:        f__getn=z_getc;
        !          1963:        f__dorevert = y_ierr;
        !          1964:        f__donewrec = z_rnew;
        !          1965:        f__doend = z_endp;
        !          1966:        return(0);
        !          1967: }
        !          1968: 
        !          1969: z_wnew(Void)
        !          1970: {
        !          1971:        while(f__recpos++ < f__svic->icirlen)
        !          1972:                *f__icptr++ = ' ';
        !          1973:        f__recpos = 0;
        !          1974:        f__cursor = 0;
        !          1975:        f__hiwater = 0;
        !          1976:        f__icnum++;
        !          1977:        return 1;
        !          1978: }
        !          1979: #ifdef KR_headers
        !          1980: integer s_wsfi(a) icilist *a;
        !          1981: #else
        !          1982: integer s_wsfi(icilist *a)
        !          1983: #endif
        !          1984: {      int n;
        !          1985:        if(n=c_si(a)) return(n);
        !          1986:        f__reading=0;
        !          1987:        f__doed=w_ed;
        !          1988:        f__doned=w_ned;
        !          1989:        f__putn=z_putc;
        !          1990:        f__dorevert = y_ierr;
        !          1991:        f__donewrec = z_wnew;
        !          1992:        f__doend = z_endp;
        !          1993:        return(0);
        !          1994: }
        !          1995: integer e_rsfi(Void)
        !          1996: {      int n;
        !          1997:        n = en_fio();
        !          1998:        f__fmtbuf = NULL;
        !          1999:        return(n);
        !          2000: }
        !          2001: integer e_wsfi(Void)
        !          2002: {
        !          2003:        int n;
        !          2004:        n = en_fio();
        !          2005:        f__fmtbuf = NULL;
        !          2006:        if(f__icnum >= f__svic->icirnum)
        !          2007:                return(n);
        !          2008:        while(f__recpos++ < f__svic->icirlen)
        !          2009:                *f__icptr++ = ' ';
        !          2010:        return(n);
        !          2011: }
        !          2012: ./ ADD NAME=libI77/ilnw.c TIME=719848231
        !          2013: #include "f2c.h"
        !          2014: #include "fio.h"
        !          2015: #include "lio.h"
        !          2016: extern char *f__icptr;
        !          2017: extern char *f__icend;
        !          2018: extern icilist *f__svic;
        !          2019: extern int f__icnum;
        !          2020: #ifdef KR_headers
        !          2021: extern int z_putc();
        !          2022: #else
        !          2023: extern int z_putc(int);
        !          2024: #endif
        !          2025: 
        !          2026:  static int
        !          2027: z_wSL(Void)
        !          2028: {
        !          2029:        while(f__recpos < f__svic->icirlen)
        !          2030:                z_putc(' ');
        !          2031:        return z_rnew();
        !          2032:        }
        !          2033: 
        !          2034:  VOID
        !          2035: #ifdef KR_headers
        !          2036: c_liw(a) icilist *a;
        !          2037: #else
        !          2038: c_liw(icilist *a)
        !          2039: #endif
        !          2040: {
        !          2041:        f__reading = 0;
        !          2042:        f__external = 0;
        !          2043:        f__formatted = 1;
        !          2044:        f__putn = z_putc;
        !          2045:        L_len = a->icirlen;
        !          2046:        f__donewrec = z_wSL;
        !          2047:        f__svic = a;
        !          2048:        f__icnum = f__recpos = 0;
        !          2049:        f__cursor = 0;
        !          2050:        f__cf = 0;
        !          2051:        f__curunit = 0;
        !          2052:        f__icptr = a->iciunit;
        !          2053:        f__icend = f__icptr + a->icirlen*a->icirnum;
        !          2054:        f__elist = (cilist *)a;
        !          2055:        }
        !          2056: 
        !          2057: #ifdef KR_headers
        !          2058: s_wsni(a) icilist *a;
        !          2059: #else
        !          2060: s_wsni(icilist *a)
        !          2061: #endif
        !          2062: {
        !          2063:        cilist ca;
        !          2064: 
        !          2065:        c_liw(a);
        !          2066:        ca.cifmt = a->icifmt;
        !          2067:        x_wsne(&ca);
        !          2068:        z_wSL();
        !          2069:        return 0;
        !          2070:        }
        !          2071: 
        !          2072: #ifdef KR_headers
        !          2073: integer s_wsli(a) icilist *a;
        !          2074: #else
        !          2075: integer s_wsli(icilist *a)
        !          2076: #endif
        !          2077: {
        !          2078:        f__lioproc = l_write;
        !          2079:        c_liw(a);
        !          2080:        return(0);
        !          2081:        }
        !          2082: 
        !          2083: integer e_wsli(Void)
        !          2084: {
        !          2085:        z_wSL();
        !          2086:        return(0);
        !          2087:        }
        !          2088: ./ ADD NAME=libI77/inquire.c TIME=719848231
        !          2089: #include "f2c.h"
        !          2090: #include "fio.h"
        !          2091: #ifdef KR_headers
        !          2092: integer f_inqu(a) inlist *a;
        !          2093: #else
        !          2094: #ifdef MSDOS
        !          2095: #undef abs
        !          2096: #undef min
        !          2097: #undef max
        !          2098: #include "string.h"
        !          2099: #include "io.h"
        !          2100: #endif
        !          2101: integer f_inqu(inlist *a)
        !          2102: #endif
        !          2103: {      flag byfile;
        !          2104:        int i, n;
        !          2105:        unit *p;
        !          2106:        char buf[256];
        !          2107:        long x;
        !          2108:        if(a->infile!=NULL)
        !          2109:        {       byfile=1;
        !          2110:                g_char(a->infile,a->infilen,buf);
        !          2111: #ifdef MSDOS
        !          2112:                x = access(buf,0) ? -1 : 0;
        !          2113:                for(i=0,p=NULL;i<MXUNIT;i++)
        !          2114:                        if(f__units[i].ufd != NULL
        !          2115:                         && f__units[i].ufnm != NULL
        !          2116:                         && !strcmp(f__units[i].ufnm,buf)) {
        !          2117:                                p = &f__units[i];
        !          2118:                                break;
        !          2119:                                }
        !          2120: #else
        !          2121:                x=f__inode(buf, &n);
        !          2122:                for(i=0,p=NULL;i<MXUNIT;i++)
        !          2123:                        if(f__units[i].uinode==x
        !          2124:                        && f__units[i].ufd!=NULL
        !          2125:                        && f__units[i].udev == n) {
        !          2126:                                p = &f__units[i];
        !          2127:                                break;
        !          2128:                                }
        !          2129: #endif
        !          2130:        }
        !          2131:        else
        !          2132:        {
        !          2133:                byfile=0;
        !          2134:                if(a->inunit<MXUNIT && a->inunit>=0)
        !          2135:                {
        !          2136:                        p= &f__units[a->inunit];
        !          2137:                }
        !          2138:                else
        !          2139:                {
        !          2140:                        p=NULL;
        !          2141:                }
        !          2142:        }
        !          2143:        if(a->inex!=NULL)
        !          2144:                if(byfile && x != -1 || !byfile && p!=NULL)
        !          2145:                        *a->inex=1;
        !          2146:                else *a->inex=0;
        !          2147:        if(a->inopen!=NULL)
        !          2148:                if(byfile) *a->inopen=(p!=NULL);
        !          2149:                else *a->inopen=(p!=NULL && p->ufd!=NULL);
        !          2150:        if(a->innum!=NULL) *a->innum= p-f__units;
        !          2151:        if(a->innamed!=NULL)
        !          2152:                if(byfile || p!=NULL && p->ufnm!=NULL)
        !          2153:                        *a->innamed=1;
        !          2154:                else    *a->innamed=0;
        !          2155:        if(a->inname!=NULL)
        !          2156:                if(byfile)
        !          2157:                        b_char(buf,a->inname,a->innamlen);
        !          2158:                else if(p!=NULL && p->ufnm!=NULL)
        !          2159:                        b_char(p->ufnm,a->inname,a->innamlen);
        !          2160:        if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL)
        !          2161:                if(p->url)
        !          2162:                        b_char("DIRECT",a->inacc,a->inacclen);
        !          2163:                else    b_char("SEQUENTIAL",a->inacc,a->inacclen);
        !          2164:        if(a->inseq!=NULL)
        !          2165:                if(p!=NULL && p->url)
        !          2166:                        b_char("NO",a->inseq,a->inseqlen);
        !          2167:                else    b_char("YES",a->inseq,a->inseqlen);
        !          2168:        if(a->indir!=NULL)
        !          2169:                if(p==NULL || p->url)
        !          2170:                        b_char("YES",a->indir,a->indirlen);
        !          2171:                else    b_char("NO",a->indir,a->indirlen);
        !          2172:        if(a->infmt!=NULL)
        !          2173:                if(p!=NULL && p->ufmt==0)
        !          2174:                        b_char("UNFORMATTED",a->infmt,a->infmtlen);
        !          2175:                else    b_char("FORMATTED",a->infmt,a->infmtlen);
        !          2176:        if(a->inform!=NULL)
        !          2177:                if(p!=NULL && p->ufmt==0)
        !          2178:                b_char("NO",a->inform,a->informlen);
        !          2179:                else b_char("YES",a->inform,a->informlen);
        !          2180:        if(a->inunf)
        !          2181:                if(p!=NULL && p->ufmt==0)
        !          2182:                        b_char("YES",a->inunf,a->inunflen);
        !          2183:                else if (p!=NULL) b_char("NO",a->inunf,a->inunflen);
        !          2184:                else b_char("UNKNOWN",a->inunf,a->inunflen);
        !          2185:        if(a->inrecl!=NULL && p!=NULL)
        !          2186:                *a->inrecl=p->url;
        !          2187:        if(a->innrec!=NULL && p!=NULL && p->url>0)
        !          2188:                *a->innrec=ftell(p->ufd)/p->url+1;
        !          2189:        if(a->inblank && p!=NULL && p->ufmt)
        !          2190:                if(p->ublnk)
        !          2191:                        b_char("ZERO",a->inblank,a->inblanklen);
        !          2192:                else    b_char("NULL",a->inblank,a->inblanklen);
        !          2193:        return(0);
        !          2194: }
        !          2195: ./ ADD NAME=libI77/lio.h TIME=719848231
        !          2196: /*     copy of ftypes from the compiler */
        !          2197: /* variable types
        !          2198:  * numeric assumptions:
        !          2199:  *     int < reals < complexes
        !          2200:  *     TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
        !          2201:  */
        !          2202: 
        !          2203: /* 0-10 retain their old (pre LOGICAL*1, etc.) */
        !          2204: /* values to allow mixing old and new objects. */
        !          2205: 
        !          2206: #define TYUNKNOWN 0
        !          2207: #define TYADDR 1
        !          2208: #define TYSHORT 2
        !          2209: #define TYLONG 3
        !          2210: #define TYREAL 4
        !          2211: #define TYDREAL 5
        !          2212: #define TYCOMPLEX 6
        !          2213: #define TYDCOMPLEX 7
        !          2214: #define TYLOGICAL 8
        !          2215: #define TYCHAR 9
        !          2216: #define TYSUBR 10
        !          2217: #define TYINT1 11
        !          2218: #define TYLOGICAL1 12
        !          2219: #define TYLOGICAL2 13
        !          2220: #define TYERROR 14
        !          2221: 
        !          2222: #define NTYPES (TYERROR+1)
        !          2223: 
        !          2224: #define        LINTW   12
        !          2225: #define        LINE    80
        !          2226: #define        LLOGW   2
        !          2227: #ifdef Old_list_output
        !          2228: #define        LLOW    1.0
        !          2229: #define        LHIGH   1.e9
        !          2230: #define        LEFMT   " %# .8E"
        !          2231: #define        LFFMT   " %# .9g"
        !          2232: #else
        !          2233: #define        LGFMT   "%.9G"
        !          2234: #endif
        !          2235: /* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */
        !          2236: #define        LEFBL   24
        !          2237: 
        !          2238: typedef union
        !          2239: {
        !          2240:        char    flchar;
        !          2241:        short   flshort;
        !          2242:        ftnint  flint;
        !          2243:        real    flreal;
        !          2244:        doublereal      fldouble;
        !          2245: } flex;
        !          2246: extern int f__scale;
        !          2247: #ifdef KR_headers
        !          2248: extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
        !          2249: extern int l_read(), l_write();
        !          2250: #else
        !          2251: #ifdef __cplusplus
        !          2252: extern "C" {
        !          2253: #endif
        !          2254: extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint);
        !          2255: extern int l_write(ftnint*, char*, ftnlen, ftnint);
        !          2256: extern void x_wsne(cilist*);
        !          2257: extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*);
        !          2258: extern int l_read(ftnint*,char*,ftnlen,ftnint);
        !          2259: extern integer e_rsle(void);
        !          2260: extern int z_rnew(void);
        !          2261: #ifdef __cplusplus
        !          2262:        }
        !          2263: #endif
        !          2264: #endif
        !          2265: extern int L_len;
        !          2266: ./ ADD NAME=libI77/lread.c TIME=719848231
        !          2267: #include "f2c.h"
        !          2268: #include "fio.h"
        !          2269: #include "fmt.h"
        !          2270: #include "lio.h"
        !          2271: #include "ctype.h"
        !          2272: #include "fp.h"
        !          2273: 
        !          2274: extern char *f__fmtbuf;
        !          2275: #ifdef KR_headers
        !          2276: extern double atof();
        !          2277: extern char *malloc(), *realloc();
        !          2278: int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
        !          2279: #else
        !          2280: #undef abs
        !          2281: #undef min
        !          2282: #undef max
        !          2283: #include "stdlib.h"
        !          2284: int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
        !          2285:        (*l_ungetc)(int,FILE*);
        !          2286: #endif
        !          2287: int l_eof;
        !          2288: 
        !          2289: #define isblnk(x) (f__ltab[x+1]&B)
        !          2290: #define issep(x) (f__ltab[x+1]&SX)
        !          2291: #define isapos(x) (f__ltab[x+1]&AX)
        !          2292: #define isexp(x) (f__ltab[x+1]&EX)
        !          2293: #define issign(x) (f__ltab[x+1]&SG)
        !          2294: #define iswhit(x) (f__ltab[x+1]&WH)
        !          2295: #define SX 1
        !          2296: #define B 2
        !          2297: #define AX 4
        !          2298: #define EX 8
        !          2299: #define SG 16
        !          2300: #define WH 32
        !          2301: char f__ltab[128+1] = {        /* offset one for EOF */
        !          2302:        0,
        !          2303:        0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
        !          2304:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
        !          2305:        SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
        !          2306:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
        !          2307:        0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
        !          2308:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
        !          2309:        AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
        !          2310:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
        !          2311: };
        !          2312: 
        !          2313: #ifdef ungetc
        !          2314:  static int
        !          2315: #ifdef KR_headers
        !          2316: un_getc(x,f__cf) int x; FILE *f__cf;
        !          2317: #else
        !          2318: un_getc(int x, FILE *f__cf)
        !          2319: #endif
        !          2320: { return ungetc(x,f__cf); }
        !          2321: #else
        !          2322: #define un_getc ungetc
        !          2323: #ifdef KR_headers
        !          2324:  extern int ungetc();
        !          2325: #endif
        !          2326: #endif
        !          2327: 
        !          2328: t_getc(Void)
        !          2329: {      int ch;
        !          2330:        if(f__curunit->uend) return(EOF);
        !          2331:        if((ch=getc(f__cf))!=EOF) return(ch);
        !          2332:        if(feof(f__cf))
        !          2333:                l_eof = f__curunit->uend = 1;
        !          2334:        return(EOF);
        !          2335: }
        !          2336: integer e_rsle(Void)
        !          2337: {
        !          2338:        int ch;
        !          2339:        if(f__curunit->uend) return(0);
        !          2340:        while((ch=t_getc())!='\n' && ch!=EOF);
        !          2341:        return(0);
        !          2342: }
        !          2343: 
        !          2344: flag f__lquit;
        !          2345: int f__lcount,f__ltype,nml_read;
        !          2346: char *f__lchar;
        !          2347: double f__lx,f__ly;
        !          2348: #define ERR(x) if(n=(x)) return(n)
        !          2349: #define GETC(x) (x=(*l_getc)())
        !          2350: #define Ungetc(x,y) (*l_ungetc)(x,y)
        !          2351: 
        !          2352: #ifdef KR_headers
        !          2353: l_R(poststar) int poststar;
        !          2354: #else
        !          2355: l_R(int poststar)
        !          2356: #endif
        !          2357: {
        !          2358:        char s[FMAX+EXPMAXDIGS+4];
        !          2359:        register int ch;
        !          2360:        register char *sp, *spe, *sp1;
        !          2361:        long e, exp;
        !          2362:        int havenum, havestar, se;
        !          2363: 
        !          2364:        if (!poststar) {
        !          2365:                if (f__lcount > 0)
        !          2366:                        return(0);
        !          2367:                f__lcount = 1;
        !          2368:                }
        !          2369:        f__ltype = 0;
        !          2370:        exp = 0;
        !          2371:        havestar = 0;
        !          2372: retry:
        !          2373:        sp1 = sp = s;
        !          2374:        spe = sp + FMAX;
        !          2375:        havenum = 0;
        !          2376: 
        !          2377:        switch(GETC(ch)) {
        !          2378:                case '-': *sp++ = ch; sp1++; spe++;
        !          2379:                case '+':
        !          2380:                        GETC(ch);
        !          2381:                }
        !          2382:        while(ch == '0') {
        !          2383:                ++havenum;
        !          2384:                GETC(ch);
        !          2385:                }
        !          2386:        while(isdigit(ch)) {
        !          2387:                if (sp < spe) *sp++ = ch;
        !          2388:                else ++exp;
        !          2389:                GETC(ch);
        !          2390:                }
        !          2391:        if (ch == '*' && !poststar) {
        !          2392:                if (sp == sp1 || exp || *s == '-') {
        !          2393:                        err(f__elist->cierr,112,"bad repetition count")
        !          2394:                        }
        !          2395:                poststar = havestar = 1;
        !          2396:                *sp = 0;
        !          2397:                f__lcount = atoi(s);
        !          2398:                goto retry;
        !          2399:                }
        !          2400:        if (ch == '.') {
        !          2401:                GETC(ch);
        !          2402:                if (sp == sp1)
        !          2403:                        while(ch == '0') {
        !          2404:                                ++havenum;
        !          2405:                                --exp;
        !          2406:                                GETC(ch);
        !          2407:                                }
        !          2408:                while(isdigit(ch)) {
        !          2409:                        if (sp < spe)
        !          2410:                                { *sp++ = ch; --exp; }
        !          2411:                        GETC(ch);
        !          2412:                        }
        !          2413:                }
        !          2414:        se = 0;
        !          2415:        if (issign(ch))
        !          2416:                goto signonly;
        !          2417:        if (isexp(ch)) {
        !          2418:                GETC(ch);
        !          2419:                if (issign(ch)) {
        !          2420: signonly:
        !          2421:                        if (ch == '-') se = 1;
        !          2422:                        GETC(ch);
        !          2423:                        }
        !          2424:                if (!isdigit(ch)) {
        !          2425: bad:
        !          2426:                        err(f__elist->cierr,112,"exponent field")
        !          2427:                        }
        !          2428: 
        !          2429:                e = ch - '0';
        !          2430:                while(isdigit(GETC(ch))) {
        !          2431:                        e = 10*e + ch - '0';
        !          2432:                        if (e > EXPMAX)
        !          2433:                                goto bad;
        !          2434:                        }
        !          2435:                if (se)
        !          2436:                        exp -= e;
        !          2437:                else
        !          2438:                        exp += e;
        !          2439:                }
        !          2440:        (void) Ungetc(ch, f__cf);
        !          2441:        if (sp > sp1) {
        !          2442:                ++havenum;
        !          2443:                while(*--sp == '0')
        !          2444:                        ++exp;
        !          2445:                if (exp)
        !          2446:                        sprintf(sp+1, "e%ld", exp);
        !          2447:                else
        !          2448:                        sp[1] = 0;
        !          2449:                f__lx = atof(s);
        !          2450:                }
        !          2451:        else
        !          2452:                f__lx = 0.;
        !          2453:        if (havenum)
        !          2454:                f__ltype = TYLONG;
        !          2455:        else
        !          2456:                switch(ch) {
        !          2457:                        case ',':
        !          2458:                        case '/':
        !          2459:                                break;
        !          2460:                        default:
        !          2461:                                if (havestar && ( ch == ' '
        !          2462:                                                ||ch == '\t'
        !          2463:                                                ||ch == '\n'))
        !          2464:                                        break;
        !          2465:                                if (nml_read > 1) {
        !          2466:                                        f__lquit = 2;
        !          2467:                                        return 0;
        !          2468:                                        }
        !          2469:                                err(f__elist->cierr,112,"invalid number")
        !          2470:                        }
        !          2471:        return 0;
        !          2472:        }
        !          2473: 
        !          2474:  static int
        !          2475: #ifdef KR_headers
        !          2476: rd_count(ch) register int ch;
        !          2477: #else
        !          2478: rd_count(register int ch)
        !          2479: #endif
        !          2480: {
        !          2481:        if (ch < '0' || ch > '9')
        !          2482:                return 1;
        !          2483:        f__lcount = ch - '0';
        !          2484:        while(GETC(ch) >= '0' && ch <= '9')
        !          2485:                f__lcount = 10*f__lcount + ch - '0';
        !          2486:        Ungetc(ch,f__cf);
        !          2487:        return f__lcount <= 0;
        !          2488:        }
        !          2489: 
        !          2490: l_C(Void)
        !          2491: {      int ch, nml_save;
        !          2492:        double lz;
        !          2493:        if(f__lcount>0) return(0);
        !          2494:        f__ltype=0;
        !          2495:        GETC(ch);
        !          2496:        if(ch!='(')
        !          2497:        {
        !          2498:                if (nml_read > 1 && (ch < '0' || ch > '9')) {
        !          2499:                        Ungetc(ch,f__cf);
        !          2500:                        f__lquit = 2;
        !          2501:                        return 0;
        !          2502:                        }
        !          2503:                if (rd_count(ch))
        !          2504:                        if(!f__cf || !feof(f__cf))
        !          2505:                                err(f__elist->cierr,112,"complex format")
        !          2506:                        else
        !          2507:                                err(f__elist->cierr,(EOF),"lread");
        !          2508:                if(GETC(ch)!='*')
        !          2509:                {
        !          2510:                        if(!f__cf || !feof(f__cf))
        !          2511:                                err(f__elist->cierr,112,"no star")
        !          2512:                        else
        !          2513:                                err(f__elist->cierr,(EOF),"lread");
        !          2514:                }
        !          2515:                if(GETC(ch)!='(')
        !          2516:                {       Ungetc(ch,f__cf);
        !          2517:                        return(0);
        !          2518:                }
        !          2519:        }
        !          2520:        else
        !          2521:                f__lcount = 1;
        !          2522:        while(iswhit(GETC(ch)));
        !          2523:        Ungetc(ch,f__cf);
        !          2524:        nml_save = nml_read;
        !          2525:        nml_read = 0;
        !          2526:        if (ch = l_R(1))
        !          2527:                return ch;
        !          2528:        if (!f__ltype)
        !          2529:                err(f__elist->cierr,112,"no real part");
        !          2530:        lz = f__lx;
        !          2531:        while(iswhit(GETC(ch)));
        !          2532:        if(ch!=',')
        !          2533:        {       (void) Ungetc(ch,f__cf);
        !          2534:                err(f__elist->cierr,112,"no comma");
        !          2535:        }
        !          2536:        while(iswhit(GETC(ch)));
        !          2537:        (void) Ungetc(ch,f__cf);
        !          2538:        if (ch = l_R(1))
        !          2539:                return ch;
        !          2540:        if (!f__ltype)
        !          2541:                err(f__elist->cierr,112,"no imaginary part");
        !          2542:        while(iswhit(GETC(ch)));
        !          2543:        if(ch!=')') err(f__elist->cierr,112,"no )");
        !          2544:        f__ly = f__lx;
        !          2545:        f__lx = lz;
        !          2546:        nml_read = nml_save;
        !          2547:        return(0);
        !          2548: }
        !          2549: l_L(Void)
        !          2550: {
        !          2551:        int ch;
        !          2552:        if(f__lcount>0) return(0);
        !          2553:        f__ltype=0;
        !          2554:        GETC(ch);
        !          2555:        if(isdigit(ch))
        !          2556:        {
        !          2557:                rd_count(ch);
        !          2558:                if(GETC(ch)!='*')
        !          2559:                        if(!f__cf || !feof(f__cf))
        !          2560:                                err(f__elist->cierr,112,"no star")
        !          2561:                        else
        !          2562:                                err(f__elist->cierr,(EOF),"lread");
        !          2563:                GETC(ch);
        !          2564:        }
        !          2565:        if(ch == '.') GETC(ch);
        !          2566:        switch(ch)
        !          2567:        {
        !          2568:        case 't':
        !          2569:        case 'T':
        !          2570:                f__lx=1;
        !          2571:                break;
        !          2572:        case 'f':
        !          2573:        case 'F':
        !          2574:                f__lx=0;
        !          2575:                break;
        !          2576:        default:
        !          2577:                if(isblnk(ch) || issep(ch) || ch==EOF)
        !          2578:                {       (void) Ungetc(ch,f__cf);
        !          2579:                        return(0);
        !          2580:                }
        !          2581:                else    err(f__elist->cierr,112,"logical");
        !          2582:        }
        !          2583:        f__ltype=TYLONG;
        !          2584:        f__lcount = 1;
        !          2585:        while(!issep(GETC(ch)) && ch!=EOF);
        !          2586:        (void) Ungetc(ch, f__cf);
        !          2587:        return(0);
        !          2588: }
        !          2589: #define BUFSIZE        128
        !          2590: l_CHAR(Void)
        !          2591: {      int ch,size,i;
        !          2592:        char quote,*p;
        !          2593:        if(f__lcount>0) return(0);
        !          2594:        f__ltype=0;
        !          2595:        if(f__lchar!=NULL) free(f__lchar);
        !          2596:        size=BUFSIZE;
        !          2597:        p=f__lchar=malloc((unsigned int)size);
        !          2598:        if(f__lchar==NULL) err(f__elist->cierr,113,"no space");
        !          2599: 
        !          2600:        GETC(ch);
        !          2601:        if(isdigit(ch)) {
        !          2602:                /* allow Fortran 8x-style unquoted string...    */
        !          2603:                /* either find a repetition count or the string */
        !          2604:                f__lcount = ch - '0';
        !          2605:                *p++ = ch;
        !          2606:                for(i = 1;;) {
        !          2607:                        switch(GETC(ch)) {
        !          2608:                                case '*':
        !          2609:                                        if (f__lcount == 0) {
        !          2610:                                                f__lcount = 1;
        !          2611:                                                goto noquote;
        !          2612:                                                }
        !          2613:                                        p = f__lchar;
        !          2614:                                        goto have_lcount;
        !          2615:                                case ',':
        !          2616:                                case ' ':
        !          2617:                                case '\t':
        !          2618:                                case '\n':
        !          2619:                                case '/':
        !          2620:                                        Ungetc(ch,f__cf);
        !          2621:                                        /* no break */
        !          2622:                                case EOF:
        !          2623:                                        f__lcount = 1;
        !          2624:                                        f__ltype = TYCHAR;
        !          2625:                                        return *p = 0;
        !          2626:                                }
        !          2627:                        if (!isdigit(ch)) {
        !          2628:                                f__lcount = 1;
        !          2629:                                goto noquote;
        !          2630:                                }
        !          2631:                        *p++ = ch;
        !          2632:                        f__lcount = 10*f__lcount + ch - '0';
        !          2633:                        if (++i == size) {
        !          2634:                                f__lchar = realloc(f__lchar,
        !          2635:                                        (unsigned int)(size += BUFSIZE));
        !          2636:                                p = f__lchar + i;
        !          2637:                                }
        !          2638:                        }
        !          2639:                }
        !          2640:        else    (void) Ungetc(ch,f__cf);
        !          2641:  have_lcount:
        !          2642:        if(GETC(ch)=='\'' || ch=='"') quote=ch;
        !          2643:        else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
        !          2644:        {       (void) Ungetc(ch,f__cf);
        !          2645:                return(0);
        !          2646:        }
        !          2647:        else {
        !          2648:                /* Fortran 8x-style unquoted string */
        !          2649:                *p++ = ch;
        !          2650:                for(i = 1;;) {
        !          2651:                        switch(GETC(ch)) {
        !          2652:                                case ',':
        !          2653:                                case ' ':
        !          2654:                                case '\t':
        !          2655:                                case '\n':
        !          2656:                                case '/':
        !          2657:                                        Ungetc(ch,f__cf);
        !          2658:                                        /* no break */
        !          2659:                                case EOF:
        !          2660:                                        f__ltype = TYCHAR;
        !          2661:                                        return *p = 0;
        !          2662:                                }
        !          2663:  noquote:
        !          2664:                        *p++ = ch;
        !          2665:                        if (++i == size) {
        !          2666:                                f__lchar = realloc(f__lchar,
        !          2667:                                        (unsigned int)(size += BUFSIZE));
        !          2668:                                p = f__lchar + i;
        !          2669:                                }
        !          2670:                        }
        !          2671:                }
        !          2672:        f__ltype=TYCHAR;
        !          2673:        for(i=0;;)
        !          2674:        {       while(GETC(ch)!=quote && ch!='\n'
        !          2675:                        && ch!=EOF && ++i<size) *p++ = ch;
        !          2676:                if(i==size)
        !          2677:                {
        !          2678:                newone:
        !          2679:                        f__lchar= realloc(f__lchar, (unsigned int)(size += BUFSIZE));
        !          2680:                        p=f__lchar+i-1;
        !          2681:                        *p++ = ch;
        !          2682:                }
        !          2683:                else if(ch==EOF) return(EOF);
        !          2684:                else if(ch=='\n')
        !          2685:                {       if(*(p-1) != '\\') continue;
        !          2686:                        i--;
        !          2687:                        p--;
        !          2688:                        if(++i<size) *p++ = ch;
        !          2689:                        else goto newone;
        !          2690:                }
        !          2691:                else if(GETC(ch)==quote)
        !          2692:                {       if(++i<size) *p++ = ch;
        !          2693:                        else goto newone;
        !          2694:                }
        !          2695:                else
        !          2696:                {       (void) Ungetc(ch,f__cf);
        !          2697:                        *p = 0;
        !          2698:                        return(0);
        !          2699:                }
        !          2700:        }
        !          2701: }
        !          2702: #ifdef KR_headers
        !          2703: c_le(a) cilist *a;
        !          2704: #else
        !          2705: c_le(cilist *a)
        !          2706: #endif
        !          2707: {
        !          2708:        f__fmtbuf="list io";
        !          2709:        if(a->ciunit>=MXUNIT || a->ciunit<0)
        !          2710:                err(a->cierr,101,"stler");
        !          2711:        f__scale=f__recpos=0;
        !          2712:        f__elist=a;
        !          2713:        f__curunit = &f__units[a->ciunit];
        !          2714:        if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
        !          2715:                err(a->cierr,102,"lio");
        !          2716:        f__cf=f__curunit->ufd;
        !          2717:        if(!f__curunit->ufmt) err(a->cierr,103,"lio")
        !          2718:        return(0);
        !          2719: }
        !          2720: #ifdef KR_headers
        !          2721: l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
        !          2722: #else
        !          2723: l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
        !          2724: #endif
        !          2725: {
        !          2726: #define Ptr ((flex *)ptr)
        !          2727:        int i,n,ch;
        !          2728:        doublereal *yy;
        !          2729:        real *xx;
        !          2730:        for(i=0;i<*number;i++)
        !          2731:        {
        !          2732:                if(f__lquit) return(0);
        !          2733:                if(l_eof)
        !          2734:                        err(f__elist->ciend, EOF, "list in")
        !          2735:                if(f__lcount == 0) {
        !          2736:                        f__ltype = 0;
        !          2737:                        for(;;)  {
        !          2738:                                GETC(ch);
        !          2739:                                switch(ch) {
        !          2740:                                case EOF:
        !          2741:                                        goto loopend;
        !          2742:                                case ' ':
        !          2743:                                case '\t':
        !          2744:                                case '\n':
        !          2745:                                        continue;
        !          2746:                                case '/':
        !          2747:                                        f__lquit = 1;
        !          2748:                                        goto loopend;
        !          2749:                                case ',':
        !          2750:                                        f__lcount = 1;
        !          2751:                                        goto loopend;
        !          2752:                                default:
        !          2753:                                        (void) Ungetc(ch, f__cf);
        !          2754:                                        goto rddata;
        !          2755:                                }
        !          2756:                        }
        !          2757:                }
        !          2758:        rddata:
        !          2759:                switch((int)type)
        !          2760:                {
        !          2761:                case TYINT1:
        !          2762:                case TYSHORT:
        !          2763:                case TYLONG:
        !          2764:                case TYREAL:
        !          2765:                case TYDREAL:
        !          2766:                        ERR(l_R(0));
        !          2767:                        break;
        !          2768:                case TYCOMPLEX:
        !          2769:                case TYDCOMPLEX:
        !          2770:                        ERR(l_C());
        !          2771:                        break;
        !          2772:                case TYLOGICAL1:
        !          2773:                case TYLOGICAL2:
        !          2774:                case TYLOGICAL:
        !          2775:                        ERR(l_L());
        !          2776:                        break;
        !          2777:                case TYCHAR:
        !          2778:                        ERR(l_CHAR());
        !          2779:                        break;
        !          2780:                }
        !          2781:        while (GETC(ch) == ' ' || ch == '\t');
        !          2782:        if (ch != ',' || f__lcount > 1)
        !          2783:                Ungetc(ch,f__cf);
        !          2784:        loopend:
        !          2785:                if(f__lquit) return(0);
        !          2786:                if(f__cf) {
        !          2787:                        if (feof(f__cf))
        !          2788:                                err(f__elist->ciend,(EOF),"list in")
        !          2789:                        else if(ferror(f__cf)) {
        !          2790:                                clearerr(f__cf);
        !          2791:                                err(f__elist->cierr,errno,"list in")
        !          2792:                                }
        !          2793:                        }
        !          2794:                if(f__ltype==0) goto bump;
        !          2795:                switch((int)type)
        !          2796:                {
        !          2797:                case TYINT1:
        !          2798:                case TYLOGICAL1:
        !          2799:                        Ptr->flchar = f__lx;
        !          2800:                        break;
        !          2801:                case TYLOGICAL2:
        !          2802:                case TYSHORT:
        !          2803:                        Ptr->flshort=f__lx;
        !          2804:                        break;
        !          2805:                case TYLOGICAL:
        !          2806:                case TYLONG:
        !          2807:                        Ptr->flint=f__lx;
        !          2808:                        break;
        !          2809:                case TYREAL:
        !          2810:                        Ptr->flreal=f__lx;
        !          2811:                        break;
        !          2812:                case TYDREAL:
        !          2813:                        Ptr->fldouble=f__lx;
        !          2814:                        break;
        !          2815:                case TYCOMPLEX:
        !          2816:                        xx=(real *)ptr;
        !          2817:                        *xx++ = f__lx;
        !          2818:                        *xx = f__ly;
        !          2819:                        break;
        !          2820:                case TYDCOMPLEX:
        !          2821:                        yy=(doublereal *)ptr;
        !          2822:                        *yy++ = f__lx;
        !          2823:                        *yy = f__ly;
        !          2824:                        break;
        !          2825:                case TYCHAR:
        !          2826:                        b_char(f__lchar,ptr,len);
        !          2827:                        break;
        !          2828:                }
        !          2829:        bump:
        !          2830:                if(f__lcount>0) f__lcount--;
        !          2831:                ptr += len;
        !          2832:                if (nml_read)
        !          2833:                        nml_read++;
        !          2834:        }
        !          2835:        return(0);
        !          2836: #undef Ptr
        !          2837: }
        !          2838: #ifdef KR_headers
        !          2839: integer s_rsle(a) cilist *a;
        !          2840: #else
        !          2841: integer s_rsle(cilist *a)
        !          2842: #endif
        !          2843: {
        !          2844:        int n;
        !          2845: 
        !          2846:        if(!f__init) f_init();
        !          2847:        if(n=c_le(a)) return(n);
        !          2848:        f__reading=1;
        !          2849:        f__external=1;
        !          2850:        f__formatted=1;
        !          2851:        f__lioproc = l_read;
        !          2852:        f__lquit = 0;
        !          2853:        f__lcount = 0;
        !          2854:        l_eof = 0;
        !          2855:        if(f__curunit->uwrt && f__nowreading(f__curunit))
        !          2856:                err(a->cierr,errno,"read start");
        !          2857:        l_getc = t_getc;
        !          2858:        l_ungetc = un_getc;
        !          2859:        return(0);
        !          2860: }
        !          2861: ./ ADD NAME=libI77/lwrite.c TIME=719848231
        !          2862: #include "f2c.h"
        !          2863: #include "fio.h"
        !          2864: #include "fmt.h"
        !          2865: #include "lio.h"
        !          2866: int L_len;
        !          2867: 
        !          2868: #ifdef KR_headers
        !          2869: t_putc(c)
        !          2870: #else
        !          2871: t_putc(int c)
        !          2872: #endif
        !          2873: {
        !          2874:        f__recpos++;
        !          2875:        putc(c,f__cf);
        !          2876:        return(0);
        !          2877: }
        !          2878:  static VOID
        !          2879: #ifdef KR_headers
        !          2880: lwrt_I(n) ftnint n;
        !          2881: #else
        !          2882: lwrt_I(ftnint n)
        !          2883: #endif
        !          2884: {
        !          2885:        char buf[LINTW],*p;
        !          2886: #ifdef USE_STRLEN
        !          2887:        (void) sprintf(buf," %ld",(long)n);
        !          2888:        if(f__recpos+strlen(buf)>=L_len)
        !          2889: #else
        !          2890:        if(f__recpos + sprintf(buf," %ld",(long)n) >= L_len)
        !          2891: #endif
        !          2892:                (*f__donewrec)();
        !          2893:        for(p=buf;*p;PUT(*p++));
        !          2894: }
        !          2895:  static VOID
        !          2896: #ifdef KR_headers
        !          2897: lwrt_L(n, len) ftnint n; ftnlen len;
        !          2898: #else
        !          2899: lwrt_L(ftnint n, ftnlen len)
        !          2900: #endif
        !          2901: {
        !          2902:        if(f__recpos+LLOGW>=L_len)
        !          2903:                (*f__donewrec)();
        !          2904:        wrt_L((Uint *)&n,LLOGW, len);
        !          2905: }
        !          2906:  static VOID
        !          2907: #ifdef KR_headers
        !          2908: lwrt_A(p,len) char *p; ftnlen len;
        !          2909: #else
        !          2910: lwrt_A(char *p, ftnlen len)
        !          2911: #endif
        !          2912: {
        !          2913:        int i;
        !          2914:        if(f__recpos+len>=L_len)
        !          2915:                (*f__donewrec)();
        !          2916:        if (!f__recpos)
        !          2917:                { PUT(' '); ++f__recpos; }
        !          2918:        for(i=0;i<len;i++) PUT(*p++);
        !          2919: }
        !          2920: 
        !          2921:  static int
        !          2922: #ifdef KR_headers
        !          2923: l_g(buf, n) char *buf; double n;
        !          2924: #else
        !          2925: l_g(char *buf, double n)
        !          2926: #endif
        !          2927: {
        !          2928: #ifdef Old_list_output
        !          2929:        doublereal absn;
        !          2930:        char *fmt;
        !          2931: 
        !          2932:        absn = n;
        !          2933:        if (absn < 0)
        !          2934:                absn = -absn;
        !          2935:        fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
        !          2936: #ifdef USE_STRLEN
        !          2937:        sprintf(buf, fmt, n);
        !          2938:        return strlen(buf);
        !          2939: #else
        !          2940:        return sprintf(buf, fmt, n);
        !          2941: #endif
        !          2942: 
        !          2943: #else
        !          2944:        register char *b, c, c1;
        !          2945: 
        !          2946:        b = buf;
        !          2947:        *b++ = ' ';
        !          2948:        if (n < 0) {
        !          2949:                *b++ = '-';
        !          2950:                n = -n;
        !          2951:                }
        !          2952:        else
        !          2953:                *b++ = ' ';
        !          2954:        if (n == 0) {
        !          2955:                *b++ = '0';
        !          2956:                *b++ = '.';
        !          2957:                *b = 0;
        !          2958:                goto f__ret;
        !          2959:                }
        !          2960:        sprintf(b, LGFMT, n);
        !          2961:        if (*b == '0') {
        !          2962:                while(b[0] = b[1])
        !          2963:                        b++;
        !          2964:                }
        !          2965:        /* Fortran 77 insists on having a decimal point... */
        !          2966:        else for(;; b++)
        !          2967:                switch(*b) {
        !          2968:                        case 0:
        !          2969:                                *b++ = '.';
        !          2970:                                *b = 0;
        !          2971:                                goto f__ret;
        !          2972:                        case '.':
        !          2973:                                while(*++b);
        !          2974:                                goto f__ret;
        !          2975:                        case 'E':
        !          2976:                                for(c1 = '.', c = 'E';  *b = c1;
        !          2977:                                        c1 = c, c = *++b);
        !          2978:                                goto f__ret;
        !          2979:                        }
        !          2980:  f__ret:
        !          2981:        return b - buf;
        !          2982: #endif
        !          2983:        }
        !          2984: 
        !          2985:  static VOID
        !          2986: #ifdef KR_headers
        !          2987: l_put(s) register char *s;
        !          2988: #else
        !          2989: l_put(register char *s)
        !          2990: #endif
        !          2991: {
        !          2992: #ifdef KR_headers
        !          2993:        register int c, (*pn)() = f__putn;
        !          2994: #else
        !          2995:        register int c, (*pn)(int) = f__putn;
        !          2996: #endif
        !          2997:        while(c = *s++)
        !          2998:                (*pn)(c);
        !          2999:        }
        !          3000: 
        !          3001:  static VOID
        !          3002: #ifdef KR_headers
        !          3003: lwrt_F(n) double n;
        !          3004: #else
        !          3005: lwrt_F(double n)
        !          3006: #endif
        !          3007: {
        !          3008:        char buf[LEFBL];
        !          3009: 
        !          3010:        if(f__recpos + l_g(buf,n) >= L_len)
        !          3011:                (*f__donewrec)();
        !          3012:        l_put(buf);
        !          3013: }
        !          3014:  static VOID
        !          3015: #ifdef KR_headers
        !          3016: lwrt_C(a,b) double a,b;
        !          3017: #else
        !          3018: lwrt_C(double a, double b)
        !          3019: #endif
        !          3020: {
        !          3021:        char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
        !          3022:        int al, bl;
        !          3023: 
        !          3024:        al = l_g(bufa, a);
        !          3025:        for(ba = bufa; *ba == ' '; ba++)
        !          3026:                --al;
        !          3027:        bl = l_g(bufb, b) + 1;  /* intentionally high by 1 */
        !          3028:        for(bb = bufb; *bb == ' '; bb++)
        !          3029:                --bl;
        !          3030:        if(f__recpos + al + bl + 3 >= L_len && f__recpos)
        !          3031:                (*f__donewrec)();
        !          3032:        PUT(' ');
        !          3033:        PUT('(');
        !          3034:        l_put(ba);
        !          3035:        PUT(',');
        !          3036:        if (f__recpos + bl >= L_len) {
        !          3037:                (*f__donewrec)();
        !          3038:                PUT(' ');
        !          3039:                }
        !          3040:        l_put(bb);
        !          3041:        PUT(')');
        !          3042: }
        !          3043: #ifdef KR_headers
        !          3044: l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
        !          3045: #else
        !          3046: l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
        !          3047: #endif
        !          3048: {
        !          3049: #define Ptr ((flex *)ptr)
        !          3050:        int i;
        !          3051:        ftnint x;
        !          3052:        double y,z;
        !          3053:        real *xx;
        !          3054:        doublereal *yy;
        !          3055:        for(i=0;i< *number; i++)
        !          3056:        {
        !          3057:                switch((int)type)
        !          3058:                {
        !          3059:                default: f__fatal(204,"unknown type in lio");
        !          3060:                case TYINT1:
        !          3061:                        x = Ptr->flchar;
        !          3062:                        goto xint;
        !          3063:                case TYSHORT:
        !          3064:                        x=Ptr->flshort;
        !          3065:                        goto xint;
        !          3066:                case TYLONG:
        !          3067:                        x=Ptr->flint;
        !          3068:                xint:   lwrt_I(x);
        !          3069:                        break;
        !          3070:                case TYREAL:
        !          3071:                        y=Ptr->flreal;
        !          3072:                        goto xfloat;
        !          3073:                case TYDREAL:
        !          3074:                        y=Ptr->fldouble;
        !          3075:                xfloat: lwrt_F(y);
        !          3076:                        break;
        !          3077:                case TYCOMPLEX:
        !          3078:                        xx= &Ptr->flreal;
        !          3079:                        y = *xx++;
        !          3080:                        z = *xx;
        !          3081:                        goto xcomplex;
        !          3082:                case TYDCOMPLEX:
        !          3083:                        yy = &Ptr->fldouble;
        !          3084:                        y= *yy++;
        !          3085:                        z = *yy;
        !          3086:                xcomplex:
        !          3087:                        lwrt_C(y,z);
        !          3088:                        break;
        !          3089:                case TYLOGICAL1:
        !          3090:                        x = Ptr->flchar;
        !          3091:                        goto xlog;
        !          3092:                case TYLOGICAL2:
        !          3093:                        x = Ptr->flshort;
        !          3094:                        goto xlog;
        !          3095:                case TYLOGICAL:
        !          3096:                        x = Ptr->flint;
        !          3097:                xlog:   lwrt_L(Ptr->flint, len);
        !          3098:                        break;
        !          3099:                case TYCHAR:
        !          3100:                        lwrt_A(ptr,len);
        !          3101:                        break;
        !          3102:                }
        !          3103:                ptr += len;
        !          3104:        }
        !          3105:        return(0);
        !          3106: }
        !          3107: ./ ADD NAME=libI77/makefile TIME=711902952
        !          3108: .SUFFIXES: .c .o
        !          3109: 
        !          3110: CC = cc
        !          3111: CFLAGS = -DSkip_f2c_Undefs -O
        !          3112: SHELL = /bin/sh
        !          3113: 
        !          3114: # compile, then strip unnecessary symbols
        !          3115: .c.o:
        !          3116:        $(CC) $(CFLAGS) -c $*.c
        !          3117:        ld -r -x -o $*.xxx $*.o
        !          3118:        mv $*.xxx $*.o
        !          3119: 
        !          3120: OBJ =  Version.o backspace.o close.o dfe.o dolio.o due.o endfile.o err.o \
        !          3121:        fmt.o fmtlib.o iio.o ilnw.o inquire.o lread.o lwrite.o open.o \
        !          3122:        rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o typesize.o uio.o \
        !          3123:        util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o
        !          3124: libI77.a:      $(OBJ)
        !          3125:                ar r libI77.a $?
        !          3126:                ranlib libI77.a
        !          3127: install:       libI77.a
        !          3128:        cp libI77.a /usr/lib/libI77.a
        !          3129:        ranlib /usr/lib/libI77.a
        !          3130: 
        !          3131: Version.o: Version.c
        !          3132:        $(CC) -c Version.c
        !          3133: 
        !          3134: 
        !          3135: clean:
        !          3136:        rm -f $(OBJ) libI77.a
        !          3137: 
        !          3138: clobber:       clean
        !          3139:        rm -f libI77.a
        !          3140: 
        !          3141: backspace.o:   fio.h
        !          3142: close.o:       fio.h
        !          3143: dfe.o:         fio.h
        !          3144: dfe.o:         fmt.h
        !          3145: due.o:         fio.h
        !          3146: endfile.o:     fio.h rawio.h
        !          3147: err.o:         fio.h rawio.h
        !          3148: fmt.o:         fio.h
        !          3149: fmt.o:         fmt.h
        !          3150: iio.o:         fio.h
        !          3151: iio.o:         fmt.h
        !          3152: ilnw.o:                fio.h
        !          3153: ilnw.o:                lio.h
        !          3154: inquire.o:     fio.h
        !          3155: lread.o:       fio.h
        !          3156: lread.o:       fmt.h
        !          3157: lread.o:       lio.h
        !          3158: lread.o:       fp.h
        !          3159: lwrite.o:      fio.h
        !          3160: lwrite.o:      fmt.h
        !          3161: lwrite.o:      lio.h
        !          3162: open.o:                fio.h rawio.h
        !          3163: rdfmt.o:       fio.h
        !          3164: rdfmt.o:       fmt.h
        !          3165: rdfmt.o:       fp.h
        !          3166: rewind.o:      fio.h
        !          3167: rsfe.o:                fio.h
        !          3168: rsfe.o:                fmt.h
        !          3169: rsli.o:                fio.h
        !          3170: rsli.o:                lio.h
        !          3171: rsne.o:                fio.h
        !          3172: rsne.o:                lio.h
        !          3173: sfe.o:         fio.h
        !          3174: sue.o:         fio.h
        !          3175: uio.o:         fio.h
        !          3176: util.o:                fio.h
        !          3177: wref.o:                fio.h
        !          3178: wref.o:                fmt.h
        !          3179: wref.o:                fp.h
        !          3180: wrtfmt.o:      fio.h
        !          3181: wrtfmt.o:      fmt.h
        !          3182: wsfe.o:                fio.h
        !          3183: wsfe.o:                fmt.h
        !          3184: wsle.o:                fio.h
        !          3185: wsle.o:                fmt.h
        !          3186: wsle.o:                lio.h
        !          3187: wsne.o:                fio.h
        !          3188: wsne.o:                lio.h
        !          3189: xwsne.o:       fio.h
        !          3190: xwsne.o:       lio.h
        !          3191: xwsne.o:       fmt.h
        !          3192: 
        !          3193: check:
        !          3194:        xsum Notice README Version.c backspace.c close.c dfe.c dolio.c \
        !          3195:        due.c endfile.c err.c fio.h fmt.c fmt.h fmtlib.c fp.h iio.c \
        !          3196:        ilnw.c inquire.c lio.h lread.c lwrite.c makefile open.c rawio.h \
        !          3197:        rdfmt.c rewind.c rsfe.c rsli.c rsne.c sfe.c sue.c typesize.c \
        !          3198:        uio.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c >zap
        !          3199:        cmp zap libI77.xsum && rm zap || diff libI77.xsum zap
        !          3200: ./ ADD NAME=libI77/open.c TIME=719848232
        !          3201: #include "sys/types.h"
        !          3202: #include "sys/stat.h"
        !          3203: #include "f2c.h"
        !          3204: #include "fio.h"
        !          3205: #include "string.h"
        !          3206: #include "fcntl.h"
        !          3207: #include "rawio.h"
        !          3208: #ifndef O_WRONLY
        !          3209: #define O_RDONLY 0
        !          3210: #define O_WRONLY 1
        !          3211: #endif
        !          3212: 
        !          3213: #ifdef KR_headers
        !          3214: extern char *malloc(), *mktemp();
        !          3215: extern FILE *fdopen();
        !          3216: extern integer f_clos();
        !          3217: #else
        !          3218: #undef abs
        !          3219: #undef min
        !          3220: #undef max
        !          3221: #include "stdlib.h"
        !          3222: extern int f__canseek(FILE*);
        !          3223: extern integer f_clos(cllist*);
        !          3224: #endif
        !          3225: 
        !          3226: #ifdef NON_ANSI_RW_MODES
        !          3227: char *r_mode[2] = {"r", "r"};
        !          3228: char *w_mode[2] = {"w", "w"};
        !          3229: #else
        !          3230: char *r_mode[2] = {"rb", "r"};
        !          3231: char *w_mode[2] = {"wb", "w"};
        !          3232: #endif
        !          3233: 
        !          3234: #ifdef KR_headers
        !          3235: f__isdev(s) char *s;
        !          3236: #else
        !          3237: f__isdev(char *s)
        !          3238: #endif
        !          3239: {
        !          3240: #ifdef MSDOS
        !          3241:        int i, j;
        !          3242: 
        !          3243:        i = open(s,O_RDONLY);
        !          3244:        if (i == -1)
        !          3245:                return 0;
        !          3246:        j = isatty(i);
        !          3247:        close(i);
        !          3248:        return j;
        !          3249: #else
        !          3250:        struct stat x;
        !          3251: 
        !          3252:        if(stat(s, &x) == -1) return(0);
        !          3253: #ifdef S_IFMT
        !          3254:        switch(x.st_mode&S_IFMT) {
        !          3255:                case S_IFREG:
        !          3256:                case S_IFDIR:
        !          3257:                        return(0);
        !          3258:                }
        !          3259: #else
        !          3260: #ifdef S_ISREG
        !          3261:        /* POSIX version */
        !          3262:        if(S_ISREG(x.st_mode) || S_ISDIR(x.st_mode))
        !          3263:                return(0);
        !          3264:        else
        !          3265: #else
        !          3266:        Help! How does stat work on this system?
        !          3267: #endif
        !          3268: #endif
        !          3269:                return(1);
        !          3270: #endif
        !          3271: }
        !          3272: #ifdef KR_headers
        !          3273: integer f_open(a) olist *a;
        !          3274: #else
        !          3275: integer f_open(olist *a)
        !          3276: #endif
        !          3277: {      unit *b;
        !          3278:        int n;
        !          3279:        char buf[256];
        !          3280:        cllist x;
        !          3281: #ifndef MSDOS
        !          3282:        struct stat stb;
        !          3283: #endif
        !          3284:        if(a->ounit>=MXUNIT || a->ounit<0)
        !          3285:                err(a->oerr,101,"open")
        !          3286:        f__curunit = b = &f__units[a->ounit];
        !          3287:        if(b->ufd) {
        !          3288:                if(a->ofnm==0)
        !          3289:                {
        !          3290:                same:   if (a->oblnk)
        !          3291:                                b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z';
        !          3292:                        return(0);
        !          3293:                }
        !          3294: #ifdef MSDOS
        !          3295:                if (b->ufnm
        !          3296:                 && strlen(b->ufnm) == a->ofnmlen
        !          3297:                 && !strncmp(b->ufnm, b->ufnm, (unsigned)a->ofnmlen))
        !          3298:                        goto same;
        !          3299: #else
        !          3300:                g_char(a->ofnm,a->ofnmlen,buf);
        !          3301:                if (f__inode(buf,&n) == b->uinode && n == b->udev)
        !          3302:                        goto same;
        !          3303: #endif
        !          3304:                x.cunit=a->ounit;
        !          3305:                x.csta=0;
        !          3306:                x.cerr=a->oerr;
        !          3307:                if((n=f_clos(&x))!=0) return(n);
        !          3308:                }
        !          3309:        b->url=a->orl;
        !          3310:        b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z');
        !          3311:        if(a->ofm==0)
        !          3312:        {       if(b->url>0) b->ufmt=0;
        !          3313:                else b->ufmt=1;
        !          3314:        }
        !          3315:        else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1;
        !          3316:        else b->ufmt=0;
        !          3317: #ifdef url_Adjust
        !          3318:        if (b->url && !b->ufmt)
        !          3319:                url_Adjust(b->url);
        !          3320: #endif
        !          3321:        if (a->ofnm) {
        !          3322:                g_char(a->ofnm,a->ofnmlen,buf);
        !          3323:                if (!buf[0])
        !          3324:                        err(a->oerr,107,"open")
        !          3325:                }
        !          3326:        else
        !          3327:                sprintf(buf, "fort.%ld", a->ounit);
        !          3328:        b->uscrtch = 0;
        !          3329:        switch(a->osta ? *a->osta : 'u')
        !          3330:        {
        !          3331:        case 'o':
        !          3332:        case 'O':
        !          3333: #ifdef MSDOS
        !          3334:                if(access(buf,0))
        !          3335: #else
        !          3336:                if(stat(buf,&stb))
        !          3337: #endif
        !          3338:                        err(a->oerr,errno,"open")
        !          3339:                break;
        !          3340:         case 's':
        !          3341:         case 'S':
        !          3342:                b->uscrtch=1;
        !          3343: #ifdef _POSIX_SOURCE
        !          3344:                tmpnam(buf);
        !          3345: #else
        !          3346:                (void) strcpy(buf,"tmp.FXXXXXX");
        !          3347:                (void) mktemp(buf);
        !          3348: #endif
        !          3349:                (void) close(creat(buf, 0666));
        !          3350:                break;
        !          3351:        case 'n':
        !          3352:        case 'N':
        !          3353: #ifdef MSDOS
        !          3354:                if(!access(buf,0))
        !          3355: #else
        !          3356:                if(!stat(buf,&stb))
        !          3357: #endif
        !          3358:                        err(a->oerr,128,"open")
        !          3359:                /* no break */
        !          3360:        case 'r':       /* Fortran 90 replace option */
        !          3361:        case 'R':
        !          3362:                (void) close(creat(buf, 0666));
        !          3363:                break;
        !          3364:        }
        !          3365: 
        !          3366:        b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1));
        !          3367:        if(b->ufnm==NULL) err(a->oerr,113,"no space");
        !          3368:        (void) strcpy(b->ufnm,buf);
        !          3369:        b->uend=0;
        !          3370:        b->uwrt = 0;
        !          3371:        if(f__isdev(buf))
        !          3372:        {       b->ufd = fopen(buf,r_mode[b->ufmt]);
        !          3373:                if(b->ufd==NULL) err(a->oerr,errno,buf)
        !          3374:        }
        !          3375:        else {
        !          3376:                if((b->ufd = fopen(buf, r_mode[b->ufmt])) == NULL) {
        !          3377:                        if ((n = open(buf,O_WRONLY)) >= 0) {
        !          3378:                                b->uwrt = 2;
        !          3379:                                }
        !          3380:                        else {
        !          3381:                                n = creat(buf, 0666);
        !          3382:                                b->uwrt = 1;
        !          3383:                                }
        !          3384:                        if (n < 0
        !          3385:                        || (b->ufd = fdopen(n, w_mode[b->ufmt])) == NULL)
        !          3386:                                err(a->oerr, errno, "open");
        !          3387:                        }
        !          3388:        }
        !          3389:        b->useek=f__canseek(b->ufd);
        !          3390: #ifndef MSDOS
        !          3391:        if((b->uinode=f__inode(buf,&b->udev))==-1)
        !          3392:                err(a->oerr,108,"open")
        !          3393: #endif
        !          3394:        if(a->orl && b->useek) rewind(b->ufd);
        !          3395:        return(0);
        !          3396: }
        !          3397: #ifdef KR_headers
        !          3398: fk_open(seq,fmt,n) ftnint n;
        !          3399: #else
        !          3400: fk_open(int seq, int fmt, ftnint n)
        !          3401: #endif
        !          3402: {      char nbuf[10];
        !          3403:        olist a;
        !          3404:        (void) sprintf(nbuf,"fort.%ld",n);
        !          3405:        a.oerr=1;
        !          3406:        a.ounit=n;
        !          3407:        a.ofnm=nbuf;
        !          3408:        a.ofnmlen=strlen(nbuf);
        !          3409:        a.osta=NULL;
        !          3410:        a.oacc= seq==SEQ?"s":"d";
        !          3411:        a.ofm = fmt==FMT?"f":"u";
        !          3412:        a.orl = seq==DIR?1:0;
        !          3413:        a.oblnk=NULL;
        !          3414:        return(f_open(&a));
        !          3415: }
        !          3416: ./ ADD NAME=libI77/rawio.h TIME=718658082
        !          3417: #ifdef KR_headers
        !          3418: extern FILE *fdopen();
        !          3419: #else
        !          3420: #ifdef MSDOS
        !          3421: #include "io.h"
        !          3422: #define close _close
        !          3423: #define creat _creat
        !          3424: #define open _open
        !          3425: #define read _read
        !          3426: #define write _write
        !          3427: #endif
        !          3428: #ifdef __cplusplus
        !          3429: extern "C" {
        !          3430: #endif
        !          3431: #ifndef MSDOS
        !          3432: #ifdef OPEN_DECL
        !          3433: extern int creat(const char*,int), open(const char*,int);
        !          3434: #endif
        !          3435: extern int close(int);
        !          3436: extern int read(int,void*,size_t), write(int,void*,size_t);
        !          3437: extern int unlink(const char*);
        !          3438: #ifndef _POSIX_SOURCE
        !          3439: extern FILE *fdopen(int, const char*);
        !          3440: #endif
        !          3441: #endif
        !          3442: 
        !          3443: extern char *mktemp(char*);
        !          3444: 
        !          3445: #ifdef __cplusplus
        !          3446:        }
        !          3447: #endif
        !          3448: #endif
        !          3449: ./ ADD NAME=libI77/rdfmt.c TIME=719848232
        !          3450: #include "f2c.h"
        !          3451: #include "fio.h"
        !          3452: #include "fmt.h"
        !          3453: #include "fp.h"
        !          3454: 
        !          3455: extern int f__cursor;
        !          3456: #ifdef KR_headers
        !          3457: extern double atof();
        !          3458: #else
        !          3459: #undef abs
        !          3460: #undef min
        !          3461: #undef max
        !          3462: #include "stdlib.h"
        !          3463: #endif
        !          3464: 
        !          3465:  static int
        !          3466: #ifdef KR_headers
        !          3467: rd_Z(n,w,len) Uint *n; ftnlen len;
        !          3468: #else
        !          3469: rd_Z(Uint *n, int w, ftnlen len)
        !          3470: #endif
        !          3471: {
        !          3472:        long x[9];
        !          3473:        char *s, *s0, *s1, *se, *t;
        !          3474:        int ch, i, w1, w2;
        !          3475:        static char hex[256];
        !          3476:        static int one = 1;
        !          3477:        int bad = 0;
        !          3478: 
        !          3479:        if (!hex['0']) {
        !          3480:                s = "0123456789";
        !          3481:                while(ch = *s++)
        !          3482:                        hex[ch] = ch - '0' + 1;
        !          3483:                s = "ABCDEF";
        !          3484:                while(ch = *s++)
        !          3485:                        hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
        !          3486:                } 
        !          3487:        s = s0 = (char *)x;
        !          3488:        s1 = (char *)&x[4];
        !          3489:        se = (char *)&x[8];
        !          3490:        if (len > 4*sizeof(long))
        !          3491:                return errno = 117;
        !          3492:        while (w) {
        !          3493:                GET(ch);
        !          3494:                if (ch==',' || ch=='\n')
        !          3495:                        break;
        !          3496:                w--;
        !          3497:                if (ch > ' ') {
        !          3498:                        if (!hex[ch & 0xff])
        !          3499:                                bad++;
        !          3500:                        *s++ = ch;
        !          3501:                        if (s == se) {
        !          3502:                                /* discard excess characters */
        !          3503:                                for(t = s0, s = s1; t < s1;)
        !          3504:                                        *t++ = *s++;
        !          3505:                                s = s1;
        !          3506:                                }
        !          3507:                        }
        !          3508:                }
        !          3509:        if (bad)
        !          3510:                return errno = 115;
        !          3511:        w = (int)len;
        !          3512:        w1 = s - s0;
        !          3513:        w2 = w1+1 >> 1;
        !          3514:        t = (char *)n;
        !          3515:        if (*(char *)&one) {
        !          3516:                /* little endian */
        !          3517:                t += w - 1;
        !          3518:                i = -1;
        !          3519:                }
        !          3520:        else
        !          3521:                i = 1;
        !          3522:        for(; w > w2; t += i, --w)
        !          3523:                *t = 0;
        !          3524:        if (!w)
        !          3525:                return 0;
        !          3526:        if (w < w2)
        !          3527:                s0 = s - (w << 1);
        !          3528:        else if (w1 & 1) {
        !          3529:                *t = hex[*s0++ & 0xff] - 1;
        !          3530:                if (!--w)
        !          3531:                        return 0;
        !          3532:                t += i;
        !          3533:                }
        !          3534:        do {
        !          3535:                *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1;
        !          3536:                t += i;
        !          3537:                s0 += 2;
        !          3538:                }
        !          3539:                while(--w);
        !          3540:        return 0;
        !          3541:        }
        !          3542: 
        !          3543:  static int
        !          3544: #ifdef KR_headers
        !          3545: rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base;
        !          3546: #else
        !          3547: rd_I(Uint *n, int w, ftnlen len, register int base)
        !          3548: #endif
        !          3549: {      long x;
        !          3550:        int sign,ch;
        !          3551:        char s[84], *ps;
        !          3552:        ps=s; x=0;
        !          3553:        while (w)
        !          3554:        {
        !          3555:                GET(ch);
        !          3556:                if (ch==',' || ch=='\n') break;
        !          3557:                *ps=ch; ps++; w--;
        !          3558:        }
        !          3559:        *ps='\0';
        !          3560:        ps=s;
        !          3561:        while (*ps==' ') ps++;
        !          3562:        if (*ps=='-') { sign=1; ps++; }
        !          3563:        else { sign=0; if (*ps=='+') ps++; }
        !          3564: loop:  while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
        !          3565:        if (*ps==' ') {if (f__cblank) x *= base; ps++; goto loop;}
        !          3566:        if(sign) x = -x;
        !          3567:        if(len==sizeof(integer)) n->il=x;
        !          3568:        else if(len == sizeof(char)) n->ic = (char)x;
        !          3569:        else n->is = (short)x;
        !          3570:        if (*ps) return(errno=115); else return(0);
        !          3571: }
        !          3572:  static int
        !          3573: #ifdef KR_headers
        !          3574: rd_L(n,w,len) ftnint *n; ftnlen len;
        !          3575: #else
        !          3576: rd_L(ftnint *n, int w, ftnlen len)
        !          3577: #endif
        !          3578: {      int ch, lv;
        !          3579:        char s[84], *ps;
        !          3580:        ps=s;
        !          3581:        while (w) {
        !          3582:                GET(ch);
        !          3583:                if (ch==','||ch=='\n') break;
        !          3584:                *ps=ch;
        !          3585:                ps++; w--;
        !          3586:                }
        !          3587:        *ps='\0';
        !          3588:        ps=s; while (*ps==' ') ps++;
        !          3589:        if (*ps=='.') ps++;
        !          3590:        if (*ps=='t' || *ps == 'T')
        !          3591:                lv = 1;
        !          3592:        else if (*ps == 'f' || *ps == 'F')
        !          3593:                lv = 0;
        !          3594:        else return(errno=116);
        !          3595:        switch(len) {
        !          3596:                case sizeof(char):      *(char *)n = (char)lv;   break;
        !          3597:                case sizeof(short):     *(short *)n = (short)lv; break;
        !          3598:                default:                *n = lv;
        !          3599:                }
        !          3600:        return 0;
        !          3601: }
        !          3602: 
        !          3603: #include "ctype.h"
        !          3604: 
        !          3605:  static int
        !          3606: #ifdef KR_headers
        !          3607: rd_F(p, w, d, len) ufloat *p; ftnlen len;
        !          3608: #else
        !          3609: rd_F(ufloat *p, int w, int d, ftnlen len)
        !          3610: #endif
        !          3611: {
        !          3612:        char s[FMAX+EXPMAXDIGS+4];
        !          3613:        register int ch;
        !          3614:        register char *sp, *spe, *sp1;
        !          3615:        double x;
        !          3616:        int scale1, se;
        !          3617:        long e, exp;
        !          3618: 
        !          3619:        sp1 = sp = s;
        !          3620:        spe = sp + FMAX;
        !          3621:        exp = -d;
        !          3622:        x = 0.;
        !          3623: 
        !          3624:        do {
        !          3625:                GET(ch);
        !          3626:                w--;
        !          3627:                } while (ch == ' ' && w);
        !          3628:        switch(ch) {
        !          3629:                case '-': *sp++ = ch; sp1++; spe++;
        !          3630:                case '+':
        !          3631:                        if (!w) goto zero;
        !          3632:                        --w;
        !          3633:                        GET(ch);
        !          3634:                }
        !          3635:        while(ch == ' ') {
        !          3636: blankdrop:
        !          3637:                if (!w--) goto zero; GET(ch); }
        !          3638:        while(ch == '0')
        !          3639:                { if (!w--) goto zero; GET(ch); }
        !          3640:        if (ch == ' ' && f__cblank)
        !          3641:                goto blankdrop;
        !          3642:        scale1 = f__scale;
        !          3643:        while(isdigit(ch)) {
        !          3644: digloop1:
        !          3645:                if (sp < spe) *sp++ = ch;
        !          3646:                else ++exp;
        !          3647: digloop1e:
        !          3648:                if (!w--) goto done;
        !          3649:                GET(ch);
        !          3650:                }
        !          3651:        if (ch == ' ') {
        !          3652:                if (f__cblank)
        !          3653:                        { ch = '0'; goto digloop1; }
        !          3654:                goto digloop1e;
        !          3655:                }
        !          3656:        if (ch == '.') {
        !          3657:                exp += d;
        !          3658:                if (!w--) goto done;
        !          3659:                GET(ch);
        !          3660:                if (sp == sp1) { /* no digits yet */
        !          3661:                        while(ch == '0') {
        !          3662: skip01:
        !          3663:                                --exp;
        !          3664: skip0:
        !          3665:                                if (!w--) goto done;
        !          3666:                                GET(ch);
        !          3667:                                }
        !          3668:                        if (ch == ' ') {
        !          3669:                                if (f__cblank) goto skip01;
        !          3670:                                goto skip0;
        !          3671:                                }
        !          3672:                        }
        !          3673:                while(isdigit(ch)) {
        !          3674: digloop2:
        !          3675:                        if (sp < spe)
        !          3676:                                { *sp++ = ch; --exp; }
        !          3677: digloop2e:
        !          3678:                        if (!w--) goto done;
        !          3679:                        GET(ch);
        !          3680:                        }
        !          3681:                if (ch == ' ') {
        !          3682:                        if (f__cblank)
        !          3683:                                { ch = '0'; goto digloop2; }
        !          3684:                        goto digloop2e;
        !          3685:                        }
        !          3686:                }
        !          3687:        switch(ch) {
        !          3688:          default:
        !          3689:                break;
        !          3690:          case '-': se = 1; goto signonly;
        !          3691:          case '+': se = 0; goto signonly;
        !          3692:          case 'e':
        !          3693:          case 'E':
        !          3694:          case 'd':
        !          3695:          case 'D':
        !          3696:                if (!w--)
        !          3697:                        goto bad;
        !          3698:                GET(ch);
        !          3699:                while(ch == ' ') {
        !          3700:                        if (!w--)
        !          3701:                                goto bad;
        !          3702:                        GET(ch);
        !          3703:                        }
        !          3704:                se = 0;
        !          3705:                switch(ch) {
        !          3706:                  case '-': se = 1;
        !          3707:                  case '+':
        !          3708: signonly:
        !          3709:                        if (!w--)
        !          3710:                                goto bad;
        !          3711:                        GET(ch);
        !          3712:                        }
        !          3713:                while(ch == ' ') {
        !          3714:                        if (!w--)
        !          3715:                                goto bad;
        !          3716:                        GET(ch);
        !          3717:                        }
        !          3718:                if (!isdigit(ch))
        !          3719:                        goto bad;
        !          3720: 
        !          3721:                e = ch - '0';
        !          3722:                for(;;) {
        !          3723:                        if (!w--)
        !          3724:                                { ch = '\n'; break; }
        !          3725:                        GET(ch);
        !          3726:                        if (!isdigit(ch)) {
        !          3727:                                if (ch == ' ') {
        !          3728:                                        if (f__cblank)
        !          3729:                                                ch = '0';
        !          3730:                                        else continue;
        !          3731:                                        }
        !          3732:                                else
        !          3733:                                        break;
        !          3734:                                }
        !          3735:                        e = 10*e + ch - '0';
        !          3736:                        if (e > EXPMAX && sp > sp1)
        !          3737:                                goto bad;
        !          3738:                        }
        !          3739:                if (se)
        !          3740:                        exp -= e;
        !          3741:                else
        !          3742:                        exp += e;
        !          3743:                scale1 = 0;
        !          3744:                }
        !          3745:        switch(ch) {
        !          3746:          case '\n':
        !          3747:          case ',':
        !          3748:                break;
        !          3749:          default:
        !          3750: bad:
        !          3751:                return (errno = 115);
        !          3752:                }
        !          3753: done:
        !          3754:        if (sp > sp1) {
        !          3755:                while(*--sp == '0')
        !          3756:                        ++exp;
        !          3757:                if (exp -= scale1)
        !          3758:                        sprintf(sp+1, "e%ld", exp);
        !          3759:                else
        !          3760:                        sp[1] = 0;
        !          3761:                x = atof(s);
        !          3762:                }
        !          3763: zero:
        !          3764:        if (len == sizeof(real))
        !          3765:                p->pf = x;
        !          3766:        else
        !          3767:                p->pd = x;
        !          3768:        return(0);
        !          3769:        }
        !          3770: 
        !          3771: 
        !          3772:  static int
        !          3773: #ifdef KR_headers
        !          3774: rd_A(p,len) char *p; ftnlen len;
        !          3775: #else
        !          3776: rd_A(char *p, ftnlen len)
        !          3777: #endif
        !          3778: {      int i,ch;
        !          3779:        for(i=0;i<len;i++)
        !          3780:        {       GET(ch);
        !          3781:                *p++=VAL(ch);
        !          3782:        }
        !          3783:        return(0);
        !          3784: }
        !          3785:  static int
        !          3786: #ifdef KR_headers
        !          3787: rd_AW(p,w,len) char *p; ftnlen len;
        !          3788: #else
        !          3789: rd_AW(char *p, int w, ftnlen len)
        !          3790: #endif
        !          3791: {      int i,ch;
        !          3792:        if(w>=len)
        !          3793:        {       for(i=0;i<w-len;i++)
        !          3794:                        GET(ch);
        !          3795:                for(i=0;i<len;i++)
        !          3796:                {       GET(ch);
        !          3797:                        *p++=VAL(ch);
        !          3798:                }
        !          3799:                return(0);
        !          3800:        }
        !          3801:        for(i=0;i<w;i++)
        !          3802:        {       GET(ch);
        !          3803:                *p++=VAL(ch);
        !          3804:        }
        !          3805:        for(i=0;i<len-w;i++) *p++=' ';
        !          3806:        return(0);
        !          3807: }
        !          3808:  static int
        !          3809: #ifdef KR_headers
        !          3810: rd_H(n,s) char *s;
        !          3811: #else
        !          3812: rd_H(int n, char *s)
        !          3813: #endif
        !          3814: {      int i,ch;
        !          3815:        for(i=0;i<n;i++)
        !          3816:                if((ch=(*f__getn)())<0) return(ch);
        !          3817:                else *s++ = ch=='\n'?' ':ch;
        !          3818:        return(1);
        !          3819: }
        !          3820:  static int
        !          3821: #ifdef KR_headers
        !          3822: rd_POS(s) char *s;
        !          3823: #else
        !          3824: rd_POS(char *s)
        !          3825: #endif
        !          3826: {      char quote;
        !          3827:        int ch;
        !          3828:        quote= *s++;
        !          3829:        for(;*s;s++)
        !          3830:                if(*s==quote && *(s+1)!=quote) break;
        !          3831:                else if((ch=(*f__getn)())<0) return(ch);
        !          3832:                else *s = ch=='\n'?' ':ch;
        !          3833:        return(1);
        !          3834: }
        !          3835: #ifdef KR_headers
        !          3836: rd_ed(p,ptr,len) struct f__syl *p; char *ptr; ftnlen len;
        !          3837: #else
        !          3838: rd_ed(struct f__syl *p, char *ptr, ftnlen len)
        !          3839: #endif
        !          3840: {      int ch;
        !          3841:        for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch);
        !          3842:        if(f__cursor<0)
        !          3843:        {       if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/
        !          3844:                        f__cursor = -f__recpos; /* is this in the standard? */
        !          3845:                if(f__external == 0) {
        !          3846:                        extern char *f__icptr;
        !          3847:                        f__icptr += f__cursor;
        !          3848:                }
        !          3849:                else if(f__curunit && f__curunit->useek)
        !          3850:                        (void) fseek(f__cf,(long) f__cursor,SEEK_CUR);
        !          3851:                else
        !          3852:                        err(f__elist->cierr,106,"fmt");
        !          3853:                f__recpos += f__cursor;
        !          3854:                f__cursor=0;
        !          3855:        }
        !          3856:        switch(p->op)
        !          3857:        {
        !          3858:        default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
        !          3859:                sig_die(f__fmtbuf, 1);
        !          3860:        case IM:
        !          3861:        case I: ch = rd_I((Uint *)ptr,p->p1,len, 10);
        !          3862:                break;
        !          3863: 
        !          3864:                /* O and OM don't work right for character, double, complex, */
        !          3865:                /* or doublecomplex, and they differ from Fortran 90 in */
        !          3866:                /* showing a minus sign for negative values. */
        !          3867: 
        !          3868:        case OM:
        !          3869:        case O: ch = rd_I((Uint *)ptr, p->p1, len, 8);
        !          3870:                break;
        !          3871:        case L: ch = rd_L((ftnint *)ptr,p->p1,len);
        !          3872:                break;
        !          3873:        case A: ch = rd_A(ptr,len);
        !          3874:                break;
        !          3875:        case AW:
        !          3876:                ch = rd_AW(ptr,p->p1,len);
        !          3877:                break;
        !          3878:        case E: case EE:
        !          3879:        case D:
        !          3880:        case G:
        !          3881:        case GE:
        !          3882:        case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2,len);
        !          3883:                break;
        !          3884: 
        !          3885:                /* Z and ZM assume 8-bit bytes. */
        !          3886: 
        !          3887:        case ZM:
        !          3888:        case Z:
        !          3889:                ch = rd_Z((Uint *)ptr, p->p1, len);
        !          3890:                break;
        !          3891:        }
        !          3892:        if(ch == 0) return(ch);
        !          3893:        else if(ch == EOF) return(EOF);
        !          3894:        if (f__cf)
        !          3895:                clearerr(f__cf);
        !          3896:        return(errno);
        !          3897: }
        !          3898: #ifdef KR_headers
        !          3899: rd_ned(p) struct f__syl *p;
        !          3900: #else
        !          3901: rd_ned(struct f__syl *p)
        !          3902: #endif
        !          3903: {
        !          3904:        switch(p->op)
        !          3905:        {
        !          3906:        default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
        !          3907:                sig_die(f__fmtbuf, 1);
        !          3908:        case APOS:
        !          3909:                return(rd_POS(*(char **)&p->p2));
        !          3910:        case H: return(rd_H(p->p1,*(char **)&p->p2));
        !          3911:        case SLASH: return((*f__donewrec)());
        !          3912:        case TR:
        !          3913:        case X: f__cursor += p->p1;
        !          3914:                return(1);
        !          3915:        case T: f__cursor=p->p1-f__recpos - 1;
        !          3916:                return(1);
        !          3917:        case TL: f__cursor -= p->p1;
        !          3918:                if(f__cursor < -f__recpos)      /* TL1000, 1X */
        !          3919:                        f__cursor = -f__recpos;
        !          3920:                return(1);
        !          3921:        }
        !          3922: }
        !          3923: ./ ADD NAME=libI77/rewind.c TIME=719848232
        !          3924: #include "f2c.h"
        !          3925: #include "fio.h"
        !          3926: #ifdef KR_headers
        !          3927: integer f_rew(a) alist *a;
        !          3928: #else
        !          3929: integer f_rew(alist *a)
        !          3930: #endif
        !          3931: {
        !          3932:        unit *b;
        !          3933:        if(a->aunit>=MXUNIT || a->aunit<0)
        !          3934:                err(a->aerr,101,"rewind");
        !          3935:        b = &f__units[a->aunit];
        !          3936:        if(b->ufd == NULL || b->uwrt == 3)
        !          3937:                return(0);
        !          3938:        if(!b->useek)
        !          3939:                err(a->aerr,106,"rewind")
        !          3940:        if(b->uwrt) {
        !          3941:                (void) t_runc(a);
        !          3942:                b->uwrt = 3;
        !          3943:                }
        !          3944:        rewind(b->ufd);
        !          3945:        b->uend=0;
        !          3946:        return(0);
        !          3947: }
        !          3948: ./ ADD NAME=libI77/rsfe.c TIME=719848232
        !          3949: /* read sequential formatted external */
        !          3950: #include "f2c.h"
        !          3951: #include "fio.h"
        !          3952: #include "fmt.h"
        !          3953: 
        !          3954: xrd_SL(Void)
        !          3955: {      int ch;
        !          3956:        if(!f__curunit->uend)
        !          3957:                while((ch=getc(f__cf))!='\n' && ch!=EOF);
        !          3958:        f__cursor=f__recpos=0;
        !          3959:        return(1);
        !          3960: }
        !          3961: x_getc(Void)
        !          3962: {      int ch;
        !          3963:        if(f__curunit->uend) return(EOF);
        !          3964:        ch = getc(f__cf);
        !          3965:        if(ch!=EOF && ch!='\n')
        !          3966:        {       f__recpos++;
        !          3967:                return(ch);
        !          3968:        }
        !          3969:        if(ch=='\n')
        !          3970:        {       (void) ungetc(ch,f__cf);
        !          3971:                return(ch);
        !          3972:        }
        !          3973:        if(f__curunit->uend || feof(f__cf))
        !          3974:        {       errno=0;
        !          3975:                f__curunit->uend=1;
        !          3976:                return(-1);
        !          3977:        }
        !          3978:        return(-1);
        !          3979: }
        !          3980: x_endp(Void)
        !          3981: {
        !          3982:        (void) xrd_SL();
        !          3983:        return(0);
        !          3984: }
        !          3985: x_rev(Void)
        !          3986: {
        !          3987:        (void) xrd_SL();
        !          3988:        return(0);
        !          3989: }
        !          3990: #ifdef KR_headers
        !          3991: integer s_rsfe(a) cilist *a; /* start */
        !          3992: #else
        !          3993: integer s_rsfe(cilist *a) /* start */
        !          3994: #endif
        !          3995: {      int n;
        !          3996:        if(!f__init) f_init();
        !          3997:        if(n=c_sfe(a)) return(n);
        !          3998:        f__reading=1;
        !          3999:        f__sequential=1;
        !          4000:        f__formatted=1;
        !          4001:        f__external=1;
        !          4002:        f__elist=a;
        !          4003:        f__cursor=f__recpos=0;
        !          4004:        f__scale=0;
        !          4005:        f__fmtbuf=a->cifmt;
        !          4006:        f__curunit= &f__units[a->ciunit];
        !          4007:        f__cf=f__curunit->ufd;
        !          4008:        if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
        !          4009:        f__getn= x_getc;
        !          4010:        f__doed= rd_ed;
        !          4011:        f__doned= rd_ned;
        !          4012:        fmt_bg();
        !          4013:        f__doend=x_endp;
        !          4014:        f__donewrec=xrd_SL;
        !          4015:        f__dorevert=x_rev;
        !          4016:        f__cblank=f__curunit->ublnk;
        !          4017:        f__cplus=0;
        !          4018:        if(f__curunit->uwrt && f__nowreading(f__curunit))
        !          4019:                err(a->cierr,errno,"read start");
        !          4020:        return(0);
        !          4021: }
        !          4022: ./ ADD NAME=libI77/rsli.c TIME=719848232
        !          4023: #include "f2c.h"
        !          4024: #include "fio.h"
        !          4025: #include "lio.h"
        !          4026: 
        !          4027: extern flag f__lquit;
        !          4028: extern int f__lcount;
        !          4029: extern char *f__icptr;
        !          4030: extern char *f__icend;
        !          4031: extern icilist *f__svic;
        !          4032: extern int f__icnum, f__recpos;
        !          4033: 
        !          4034: int i_getc(Void)
        !          4035: {
        !          4036:        if(f__recpos >= f__svic->icirlen) {
        !          4037:                if (f__recpos++ == f__svic->icirlen)
        !          4038:                        return '\n';
        !          4039:                z_rnew();
        !          4040:                }
        !          4041:        f__recpos++;
        !          4042:        if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile");
        !          4043:        return(*f__icptr++);
        !          4044:        }
        !          4045: 
        !          4046: #ifdef KR_headers
        !          4047: int i_ungetc(ch, f) int ch; FILE *f;
        !          4048: #else
        !          4049: int i_ungetc(int ch, FILE *f)
        !          4050: #endif
        !          4051: {
        !          4052:        if (--f__recpos == f__svic->icirlen)
        !          4053:                return '\n';
        !          4054:        if (f__recpos < -1)
        !          4055:                err(f__svic->icierr,110,"recend");
        !          4056:        /* *--icptr == ch, and icptr may point to read-only memory */
        !          4057:        return *--f__icptr /* = ch */;
        !          4058:        }
        !          4059: 
        !          4060:  static void
        !          4061: #ifdef KR_headers
        !          4062: c_lir(a) icilist *a;
        !          4063: #else
        !          4064: c_lir(icilist *a)
        !          4065: #endif
        !          4066: {
        !          4067:        extern int l_eof;
        !          4068:        f__reading = 1;
        !          4069:        f__external = 0;
        !          4070:        f__formatted = 1;
        !          4071:        f__svic = a;
        !          4072:        L_len = a->icirlen;
        !          4073:        f__recpos = -1;
        !          4074:        f__icnum = f__recpos = 0;
        !          4075:        f__cursor = 0;
        !          4076:        l_getc = i_getc;
        !          4077:        l_ungetc = i_ungetc;
        !          4078:        l_eof = 0;
        !          4079:        f__icptr = a->iciunit;
        !          4080:        f__icend = f__icptr + a->icirlen*a->icirnum;
        !          4081:        f__cf = 0;
        !          4082:        f__curunit = 0;
        !          4083:        f__elist = (cilist *)a;
        !          4084:        }
        !          4085: 
        !          4086: 
        !          4087: #ifdef KR_headers
        !          4088: integer s_rsli(a) icilist *a;
        !          4089: #else
        !          4090: integer s_rsli(icilist *a)
        !          4091: #endif
        !          4092: {
        !          4093:        f__lioproc = l_read;
        !          4094:        f__lquit = 0;
        !          4095:        f__lcount = 0;
        !          4096:        c_lir(a);
        !          4097:        return(0);
        !          4098:        }
        !          4099: 
        !          4100: integer e_rsli(Void)
        !          4101: { return 0; }
        !          4102: 
        !          4103: #ifdef KR_headers
        !          4104: s_rsni(a) icilist *a;
        !          4105: #else
        !          4106: extern int x_rsne(cilist*);
        !          4107: 
        !          4108: s_rsni(icilist *a)
        !          4109: #endif
        !          4110: {
        !          4111:        cilist ca;
        !          4112:        ca.ciend = a->iciend;
        !          4113:        ca.cierr = a->icierr;
        !          4114:        ca.cifmt = a->icifmt;
        !          4115:        c_lir(a);
        !          4116:        return x_rsne(&ca);
        !          4117:        }
        !          4118: ./ ADD NAME=libI77/rsne.c TIME=719850201
        !          4119: #include "f2c.h"
        !          4120: #include "fio.h"
        !          4121: #include "lio.h"
        !          4122: 
        !          4123: #define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */
        !          4124: #define MAXDIM 20      /* maximum number of subscripts */
        !          4125: 
        !          4126:  struct dimen {
        !          4127:        ftnlen extent;
        !          4128:        ftnlen curval;
        !          4129:        ftnlen delta;
        !          4130:        ftnlen stride;
        !          4131:        };
        !          4132:  typedef struct dimen dimen;
        !          4133: 
        !          4134:  struct hashentry {
        !          4135:        struct hashentry *next;
        !          4136:        char *name;
        !          4137:        Vardesc *vd;
        !          4138:        };
        !          4139:  typedef struct hashentry hashentry;
        !          4140: 
        !          4141:  struct hashtab {
        !          4142:        struct hashtab *next;
        !          4143:        Namelist *nl;
        !          4144:        int htsize;
        !          4145:        hashentry *tab[1];
        !          4146:        };
        !          4147:  typedef struct hashtab hashtab;
        !          4148: 
        !          4149:  static hashtab *nl_cache;
        !          4150:  static n_nlcache;
        !          4151:  static hashentry **zot;
        !          4152:  extern ftnlen f__typesize[];
        !          4153: 
        !          4154:  extern flag f__lquit;
        !          4155:  extern int f__lcount, nml_read;
        !          4156:  extern t_getc(Void);
        !          4157: 
        !          4158: #ifdef KR_headers
        !          4159:  extern char *malloc(), *memset();
        !          4160: 
        !          4161: #ifdef ungetc
        !          4162:  static int
        !          4163: un_getc(x,f__cf) int x; FILE *f__cf;
        !          4164: { return ungetc(x,f__cf); }
        !          4165: #else
        !          4166: #define un_getc ungetc
        !          4167:  extern int ungetc();
        !          4168: #endif
        !          4169: 
        !          4170: #else
        !          4171: #undef abs
        !          4172: #undef min
        !          4173: #undef max
        !          4174: #include "stdlib.h"
        !          4175: #include "string.h"
        !          4176: 
        !          4177: #ifdef ungetc
        !          4178:  static int
        !          4179: un_getc(int x, FILE *f__cf)
        !          4180: { return ungetc(x,f__cf); }
        !          4181: #else
        !          4182: #define un_getc ungetc
        !          4183: #endif
        !          4184: #endif
        !          4185: 
        !          4186:  static Vardesc *
        !          4187: #ifdef KR_headers
        !          4188: hash(ht, s) hashtab *ht; register char *s;
        !          4189: #else
        !          4190: hash(hashtab *ht, register char *s)
        !          4191: #endif
        !          4192: {
        !          4193:        register int c, x;
        !          4194:        register hashentry *h;
        !          4195:        char *s0 = s;
        !          4196: 
        !          4197:        for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
        !          4198:                x += c;
        !          4199:        for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
        !          4200:                if (!strcmp(s0, h->name))
        !          4201:                        return h->vd;
        !          4202:        return 0;
        !          4203:        }
        !          4204: 
        !          4205:  hashtab *
        !          4206: #ifdef KR_headers
        !          4207: mk_hashtab(nl) Namelist *nl;
        !          4208: #else
        !          4209: mk_hashtab(Namelist *nl)
        !          4210: #endif
        !          4211: {
        !          4212:        int nht, nv;
        !          4213:        hashtab *ht;
        !          4214:        Vardesc *v, **vd, **vde;
        !          4215:        hashentry *he;
        !          4216: 
        !          4217:        hashtab **x, **x0, *y;
        !          4218:        for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
        !          4219:                if (nl == y->nl)
        !          4220:                        return y;
        !          4221:        if (n_nlcache >= MAX_NL_CACHE) {
        !          4222:                /* discard least recently used namelist hash table */
        !          4223:                y = *x0;
        !          4224:                free((char *)y->next);
        !          4225:                y->next = 0;
        !          4226:                }
        !          4227:        else
        !          4228:                n_nlcache++;
        !          4229:        nv = nl->nvars;
        !          4230:        if (nv >= 0x4000)
        !          4231:                nht = 0x7fff;
        !          4232:        else {
        !          4233:                for(nht = 1; nht < nv; nht <<= 1);
        !          4234:                nht += nht - 1;
        !          4235:                }
        !          4236:        ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
        !          4237:                                + nv*sizeof(hashentry));
        !          4238:        if (!ht)
        !          4239:                return 0;
        !          4240:        he = (hashentry *)&ht->tab[nht];
        !          4241:        ht->nl = nl;
        !          4242:        ht->htsize = nht;
        !          4243:        ht->next = nl_cache;
        !          4244:        nl_cache = ht;
        !          4245:        memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
        !          4246:        vd = nl->vars;
        !          4247:        vde = vd + nv;
        !          4248:        while(vd < vde) {
        !          4249:                v = *vd++;
        !          4250:                if (!hash(ht, v->name)) {
        !          4251:                        he->next = *zot;
        !          4252:                        *zot = he;
        !          4253:                        he->name = v->name;
        !          4254:                        he->vd = v;
        !          4255:                        he++;
        !          4256:                        }
        !          4257:                }
        !          4258:        return ht;
        !          4259:        }
        !          4260: 
        !          4261: static char Alpha[256], Alphanum[256];
        !          4262: 
        !          4263:  static VOID
        !          4264: nl_init(Void) {
        !          4265:        register char *s;
        !          4266:        register int c;
        !          4267: 
        !          4268:        if(!f__init)
        !          4269:                f_init();
        !          4270:        for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
        !          4271:                Alpha[c]
        !          4272:                = Alphanum[c]
        !          4273:                = Alpha[c + 'a' - 'A']
        !          4274:                = Alphanum[c + 'a' - 'A']
        !          4275:                = c;
        !          4276:        for(s = "0123456789_"; c = *s++; )
        !          4277:                Alphanum[c] = c;
        !          4278:        }
        !          4279: 
        !          4280: #define GETC(x) (x=(*l_getc)())
        !          4281: #define Ungetc(x,y) (*l_ungetc)(x,y)
        !          4282: 
        !          4283:  static int
        !          4284: #ifdef KR_headers
        !          4285: getname(s, slen) register char *s; int slen;
        !          4286: #else
        !          4287: getname(register char *s, int slen)
        !          4288: #endif
        !          4289: {
        !          4290:        register char *se = s + slen - 1;
        !          4291:        register int ch;
        !          4292: 
        !          4293:        GETC(ch);
        !          4294:        if (!(*s++ = Alpha[ch & 0xff])) {
        !          4295:                if (ch != EOF)
        !          4296:                        ch = 115;
        !          4297:                err(f__elist->cierr, ch, "namelist read");
        !          4298:                }
        !          4299:        while(*s = Alphanum[GETC(ch) & 0xff])
        !          4300:                if (s < se)
        !          4301:                        s++;
        !          4302:        if (ch == EOF)
        !          4303:                err(f__elist->cierr, EOF, "namelist read");
        !          4304:        if (ch > ' ')
        !          4305:                Ungetc(ch,f__cf);
        !          4306:        return *s = 0;
        !          4307:        }
        !          4308: 
        !          4309:  static int
        !          4310: #ifdef KR_headers
        !          4311: getnum(chp, val) int *chp; ftnlen *val;
        !          4312: #else
        !          4313: getnum(int *chp, ftnlen *val)
        !          4314: #endif
        !          4315: {
        !          4316:        register int ch, sign;
        !          4317:        register ftnlen x;
        !          4318: 
        !          4319:        while(GETC(ch) <= ' ' && ch >= 0);
        !          4320:        if (ch == '-') {
        !          4321:                sign = 1;
        !          4322:                GETC(ch);
        !          4323:                }
        !          4324:        else {
        !          4325:                sign = 0;
        !          4326:                if (ch == '+')
        !          4327:                        GETC(ch);
        !          4328:                }
        !          4329:        x = ch - '0';
        !          4330:        if (x < 0 || x > 9)
        !          4331:                return 115;
        !          4332:        while(GETC(ch) >= '0' && ch <= '9')
        !          4333:                x = 10*x + ch - '0';
        !          4334:        while(ch <= ' ' && ch >= 0)
        !          4335:                GETC(ch);
        !          4336:        if (ch == EOF)
        !          4337:                return EOF;
        !          4338:        *val = sign ? -x : x;
        !          4339:        *chp = ch;
        !          4340:        return 0;
        !          4341:        }
        !          4342: 
        !          4343:  static int
        !          4344: #ifdef KR_headers
        !          4345: getdimen(chp, d, delta, extent, x1)
        !          4346:  int *chp; dimen *d; ftnlen delta, extent, *x1;
        !          4347: #else
        !          4348: getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
        !          4349: #endif
        !          4350: {
        !          4351:        register int k;
        !          4352:        ftnlen x2, x3;
        !          4353: 
        !          4354:        if (k = getnum(chp, x1))
        !          4355:                return k;
        !          4356:        x3 = 1;
        !          4357:        if (*chp == ':') {
        !          4358:                if (k = getnum(chp, &x2))
        !          4359:                        return k;
        !          4360:                x2 -= *x1;
        !          4361:                if (*chp == ':') {
        !          4362:                        if (k = getnum(chp, &x3))
        !          4363:                                return k;
        !          4364:                        if (!x3)
        !          4365:                                return 123;
        !          4366:                        x2 /= x3;
        !          4367:                        }
        !          4368:                if (x2 < 0 || x2 >= extent)
        !          4369:                        return 123;
        !          4370:                d->extent = x2 + 1;
        !          4371:                }
        !          4372:        else
        !          4373:                d->extent = 1;
        !          4374:        d->curval = 0;
        !          4375:        d->delta = delta;
        !          4376:        d->stride = x3;
        !          4377:        return 0;
        !          4378:        }
        !          4379: 
        !          4380:  static char where0[] = "namelist read start ";
        !          4381: 
        !          4382: #ifdef KR_headers
        !          4383: x_rsne(a) cilist *a;
        !          4384: #else
        !          4385: x_rsne(cilist *a)
        !          4386: #endif
        !          4387: {
        !          4388:        int ch, got1, k, n, nd;
        !          4389:        Namelist *nl;
        !          4390:        static char where[] = "namelist read";
        !          4391:        char buf[64];
        !          4392:        hashtab *ht;
        !          4393:        Vardesc *v;
        !          4394:        dimen *dn, *dn0, *dn1;
        !          4395:        ftnlen *dims, *dims1;
        !          4396:        ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
        !          4397:        ftnint type;
        !          4398:        char *vaddr;
        !          4399:        long iva, ivae;
        !          4400:        dimen dimens[MAXDIM], substr;
        !          4401: 
        !          4402:        if (!Alpha['a'])
        !          4403:                nl_init();
        !          4404:        f__reading=1;
        !          4405:        f__formatted=1;
        !          4406:        got1 = 0;
        !          4407:        for(;;) switch(GETC(ch)) {
        !          4408:                case EOF:
        !          4409:                        err(a->ciend,(EOF),where0);
        !          4410:                case '&':
        !          4411:                case '$':
        !          4412:                        goto have_amp;
        !          4413:                default:
        !          4414:                        if (ch <= ' ' && ch >= 0)
        !          4415:                                continue;
        !          4416:                        err(a->cierr, 115, where0);
        !          4417:                }
        !          4418:  have_amp:
        !          4419:        if (ch = getname(buf,sizeof(buf)))
        !          4420:                return ch;
        !          4421:        nl = (Namelist *)a->cifmt;
        !          4422:        if (strcmp(buf, nl->name))
        !          4423:                err(a->cierr, 118, where0);
        !          4424:        ht = mk_hashtab(nl);
        !          4425:        if (!ht)
        !          4426:                err(f__elist->cierr, 113, where0);
        !          4427:        for(;;) {
        !          4428:                for(;;) switch(GETC(ch)) {
        !          4429:                        case EOF:
        !          4430:                                if (got1)
        !          4431:                                        return 0;
        !          4432:                                err(a->ciend,(EOF),where0);
        !          4433:                        case '/':
        !          4434:                        case '$':
        !          4435:                        case '&':
        !          4436:                                return 0;
        !          4437:                        default:
        !          4438:                                if (ch <= ' ' && ch >= 0 || ch == ',')
        !          4439:                                        continue;
        !          4440:                                Ungetc(ch,f__cf);
        !          4441:                                if (ch = getname(buf,sizeof(buf)))
        !          4442:                                        return ch;
        !          4443:                                goto havename;
        !          4444:                        }
        !          4445:  havename:
        !          4446:                v = hash(ht,buf);
        !          4447:                if (!v)
        !          4448:                        err(a->cierr, 119, where);
        !          4449:                while(GETC(ch) <= ' ' && ch >= 0);
        !          4450:                vaddr = v->addr;
        !          4451:                type = v->type;
        !          4452:                if (type < 0) {
        !          4453:                        size = -type;
        !          4454:                        type = TYCHAR;
        !          4455:                        }
        !          4456:                else
        !          4457:                        size = f__typesize[type];
        !          4458:                ivae = size;
        !          4459:                iva = 0;
        !          4460:                if (ch == '(' /*)*/ ) {
        !          4461:                        dn = dimens;
        !          4462:                        if (!(dims = v->dims)) {
        !          4463:                                if (type != TYCHAR)
        !          4464:                                        err(a->cierr, 122, where);
        !          4465:                                if (k = getdimen(&ch, dn, (ftnlen)size,
        !          4466:                                                (ftnlen)size, &b))
        !          4467:                                        err(a->cierr, k, where);
        !          4468:                                if (ch != ')')
        !          4469:                                        err(a->cierr, 115, where);
        !          4470:                                b1 = dn->extent;
        !          4471:                                if (--b < 0 || b + b1 > size)
        !          4472:                                        return 124;
        !          4473:                                iva += b;
        !          4474:                                size = b1;
        !          4475:                                while(GETC(ch) <= ' ' && ch >= 0);
        !          4476:                                goto scalar;
        !          4477:                                }
        !          4478:                        nd = dims[0];
        !          4479:                        nomax = span = dims[1];
        !          4480:                        ivae = iva + size*nomax;
        !          4481:                        if (k = getdimen(&ch, dn, size, nomax, &b))
        !          4482:                                err(a->cierr, k, where);
        !          4483:                        no = dn->extent;
        !          4484:                        b0 = dims[2];
        !          4485:                        dims1 = dims += 3;
        !          4486:                        ex = 1;
        !          4487:                        for(n = 1; n++ < nd; dims++) {
        !          4488:                                if (ch != ',')
        !          4489:                                        err(a->cierr, 115, where);
        !          4490:                                dn1 = dn + 1;
        !          4491:                                span /= *dims;
        !          4492:                                if (k = getdimen(&ch, dn1, dn->delta**dims,
        !          4493:                                                span, &b1))
        !          4494:                                        err(a->cierr, k, where);
        !          4495:                                ex *= *dims;
        !          4496:                                b += b1*ex;
        !          4497:                                no *= dn1->extent;
        !          4498:                                dn = dn1;
        !          4499:                                }
        !          4500:                        if (ch != ')')
        !          4501:                                err(a->cierr, 115, where);
        !          4502:                        b -= b0;
        !          4503:                        if (b < 0 || b >= nomax)
        !          4504:                                err(a->cierr, 125, where);
        !          4505:                        iva += size * b;
        !          4506:                        dims = dims1;
        !          4507:                        while(GETC(ch) <= ' ' && ch >= 0);
        !          4508:                        no1 = 1;
        !          4509:                        dn0 = dimens;
        !          4510:                        if (type == TYCHAR && ch == '(' /*)*/) {
        !          4511:                                if (k = getdimen(&ch, &substr, size, size, &b))
        !          4512:                                        err(a->cierr, k, where);
        !          4513:                                if (ch != ')')
        !          4514:                                        err(a->cierr, 115, where);
        !          4515:                                b1 = substr.extent;
        !          4516:                                if (--b < 0 || b + b1 > size)
        !          4517:                                        return 124;
        !          4518:                                iva += b;
        !          4519:                                b0 = size;
        !          4520:                                size = b1;
        !          4521:                                while(GETC(ch) <= ' ' && ch >= 0);
        !          4522:                                if (b1 < b0)
        !          4523:                                        goto delta_adj;
        !          4524:                                }
        !          4525:                        for(; dn0 < dn; dn0++) {
        !          4526:                                if (dn0->extent != *dims++ || dn0->stride != 1)
        !          4527:                                        break;
        !          4528:                                no1 *= dn0->extent;
        !          4529:                                }
        !          4530:                        if (dn0 == dimens && dimens[0].stride == 1) {
        !          4531:                                no1 = dimens[0].extent;
        !          4532:                                dn0++;
        !          4533:                                }
        !          4534:  delta_adj:
        !          4535:                        ex = 0;
        !          4536:                        for(dn1 = dn0; dn1 <= dn; dn1++)
        !          4537:                                ex += (dn1->extent-1)
        !          4538:                                        * (dn1->delta *= dn1->stride);
        !          4539:                        for(dn1 = dn; dn1 > dn0; dn1--) {
        !          4540:                                ex -= (dn1->extent - 1) * dn1->delta;
        !          4541:                                dn1->delta -= ex;
        !          4542:                                }
        !          4543:                        }
        !          4544:                else if (dims = v->dims) {
        !          4545:                        no = no1 = dims[1];
        !          4546:                        ivae = iva + no*size;
        !          4547:                        }
        !          4548:                else
        !          4549:  scalar:
        !          4550:                        no = no1 = 1;
        !          4551:                if (ch != '=')
        !          4552:                        err(a->cierr, 115, where);
        !          4553:                got1 = nml_read = 1;
        !          4554:                f__lcount = 0;
        !          4555:         readloop:
        !          4556:                for(;;) {
        !          4557:                        if (iva >= ivae || iva < 0) {
        !          4558:                                f__lquit = 1;
        !          4559:                                goto mustend;
        !          4560:                                }
        !          4561:                        else if (iva + no1*size > ivae)
        !          4562:                                no1 = (ivae - iva)/size;
        !          4563:                        f__lquit = 0;
        !          4564:                        l_read(&no1, vaddr + iva, size, type);
        !          4565:                        if (f__lquit == 1)
        !          4566:                                return 0;
        !          4567:  mustend:
        !          4568:                        if (GETC(ch) == '/' || ch == '$' || ch == '&') {
        !          4569:                                f__lquit = 1;
        !          4570:                                return 0;
        !          4571:                                }
        !          4572:                        else if (f__lquit) {
        !          4573:                                while(ch <= ' ' && ch >= 0)
        !          4574:                                        GETC(ch);
        !          4575:                                Ungetc(ch,f__cf);
        !          4576:                                if (!Alpha[ch & 0xff] && ch >= 0)
        !          4577:                                        err(a->cierr, 125, where);
        !          4578:                                break;
        !          4579:                                }
        !          4580:                        Ungetc(ch,f__cf);
        !          4581:                        if ((no -= no1) <= 0)
        !          4582:                                break;
        !          4583:                        for(dn1 = dn0; dn1 <= dn; dn1++) {
        !          4584:                                if (++dn1->curval < dn1->extent) {
        !          4585:                                        iva += dn1->delta;
        !          4586:                                        goto readloop;
        !          4587:                                        }
        !          4588:                                dn1->curval = 0;
        !          4589:                                }
        !          4590:                        break;
        !          4591:                        }
        !          4592:                }
        !          4593:        }
        !          4594: 
        !          4595:  integer
        !          4596: #ifdef KR_headers
        !          4597: s_rsne(a) cilist *a;
        !          4598: #else
        !          4599: s_rsne(cilist *a)
        !          4600: #endif
        !          4601: {
        !          4602:        extern int l_eof;
        !          4603:        int n;
        !          4604: 
        !          4605:        f__external=1;
        !          4606:        l_eof = 0;
        !          4607:        if(n = c_le(a))
        !          4608:                return n;
        !          4609:        if(f__curunit->uwrt && f__nowreading(f__curunit))
        !          4610:                err(a->cierr,errno,where0);
        !          4611:        l_getc = t_getc;
        !          4612:        l_ungetc = un_getc;
        !          4613:        if (n = x_rsne(a))
        !          4614:                return n;
        !          4615:        return e_rsle();
        !          4616:        }
        !          4617: ./ ADD NAME=libI77/sfe.c TIME=719848232
        !          4618: /* sequential formatted external common routines*/
        !          4619: #include "f2c.h"
        !          4620: #include "fio.h"
        !          4621: 
        !          4622: extern char *f__fmtbuf;
        !          4623: 
        !          4624: integer e_rsfe(Void)
        !          4625: {      int n;
        !          4626:        n=en_fio();
        !          4627:        if (f__cf == stdout)
        !          4628:                fflush(stdout);
        !          4629:        else if (f__cf == stderr)
        !          4630:                fflush(stderr);
        !          4631:        f__fmtbuf=NULL;
        !          4632:        return(n);
        !          4633: }
        !          4634: #ifdef KR_headers
        !          4635: c_sfe(a) cilist *a; /* check */
        !          4636: #else
        !          4637: c_sfe(cilist *a) /* check */
        !          4638: #endif
        !          4639: {      unit *p;
        !          4640:        if(a->ciunit >= MXUNIT || a->ciunit<0)
        !          4641:                err(a->cierr,101,"startio");
        !          4642:        p = &f__units[a->ciunit];
        !          4643:        if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe")
        !          4644:        if(!p->ufmt) err(a->cierr,102,"sfe")
        !          4645:        return(0);
        !          4646: }
        !          4647: integer e_wsfe(Void)
        !          4648: {      return(e_rsfe());
        !          4649: }
        !          4650: ./ ADD NAME=libI77/sue.c TIME=719848233
        !          4651: #include "f2c.h"
        !          4652: #include "fio.h"
        !          4653: extern uiolen f__reclen;
        !          4654: long f__recloc;
        !          4655: 
        !          4656: #ifdef KR_headers
        !          4657: c_sue(a) cilist *a;
        !          4658: #else
        !          4659: c_sue(cilist *a)
        !          4660: #endif
        !          4661: {
        !          4662:        if(a->ciunit >= MXUNIT || a->ciunit < 0)
        !          4663:                err(a->cierr,101,"startio");
        !          4664:        f__external=f__sequential=1;
        !          4665:        f__formatted=0;
        !          4666:        f__curunit = &f__units[a->ciunit];
        !          4667:        f__elist=a;
        !          4668:        if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit))
        !          4669:                err(a->cierr,114,"sue");
        !          4670:        f__cf=f__curunit->ufd;
        !          4671:        if(f__curunit->ufmt) err(a->cierr,103,"sue")
        !          4672:        if(!f__curunit->useek) err(a->cierr,103,"sue")
        !          4673:        return(0);
        !          4674: }
        !          4675: #ifdef KR_headers
        !          4676: integer s_rsue(a) cilist *a;
        !          4677: #else
        !          4678: integer s_rsue(cilist *a)
        !          4679: #endif
        !          4680: {
        !          4681:        int n;
        !          4682:        if(!f__init) f_init();
        !          4683:        f__reading=1;
        !          4684:        if(n=c_sue(a)) return(n);
        !          4685:        f__recpos=0;
        !          4686:        if(f__curunit->uwrt && f__nowreading(f__curunit))
        !          4687:                err(a->cierr, errno, "read start");
        !          4688:        if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf)
        !          4689:                != 1)
        !          4690:        {       if(feof(f__cf))
        !          4691:                {       f__curunit->uend = 1;
        !          4692:                        err(a->ciend, EOF, "start");
        !          4693:                }
        !          4694:                clearerr(f__cf);
        !          4695:                err(a->cierr, errno, "start");
        !          4696:        }
        !          4697:        return(0);
        !          4698: }
        !          4699: #ifdef KR_headers
        !          4700: integer s_wsue(a) cilist *a;
        !          4701: #else
        !          4702: integer s_wsue(cilist *a)
        !          4703: #endif
        !          4704: {
        !          4705:        int n;
        !          4706:        if(!f__init) f_init();
        !          4707:        if(n=c_sue(a)) return(n);
        !          4708:        f__reading=0;
        !          4709:        f__reclen=0;
        !          4710:        if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
        !          4711:                err(a->cierr, errno, "write start");
        !          4712:        f__recloc=ftell(f__cf);
        !          4713:        (void) fseek(f__cf,(long)sizeof(uiolen),SEEK_CUR);
        !          4714:        return(0);
        !          4715: }
        !          4716: integer e_wsue(Void)
        !          4717: {      long loc;
        !          4718:        (void) fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf);
        !          4719:        loc=ftell(f__cf);
        !          4720:        (void) fseek(f__cf,f__recloc,SEEK_SET);
        !          4721:        (void) fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf);
        !          4722:        (void) fseek(f__cf,loc,SEEK_SET);
        !          4723:        return(0);
        !          4724: }
        !          4725: integer e_rsue(Void)
        !          4726: {
        !          4727:        (void) fseek(f__cf,(long)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR);
        !          4728:        return(0);
        !          4729: }
        !          4730: ./ ADD NAME=libI77/typesize.c TIME=719848233
        !          4731: #include "f2c.h"
        !          4732: 
        !          4733: ftnlen f__typesize[] = { 0, 0, sizeof(shortint), sizeof(integer),
        !          4734:                        sizeof(real), sizeof(doublereal),
        !          4735:                        sizeof(complex), sizeof(doublecomplex),
        !          4736:                        sizeof(logical), sizeof(char) };
        !          4737: ./ ADD NAME=libI77/uio.c TIME=719848233
        !          4738: #include "f2c.h"
        !          4739: #include "fio.h"
        !          4740: uiolen f__reclen;
        !          4741: 
        !          4742: #ifdef KR_headers
        !          4743: do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
        !          4744: #else
        !          4745: do_us(ftnint *number, char *ptr, ftnlen len)
        !          4746: #endif
        !          4747: {
        !          4748:        if(f__reading)
        !          4749:        {
        !          4750:                f__recpos += *number * len;
        !          4751:                if(f__recpos>f__reclen)
        !          4752:                        err(f__elist->ciend, 110, "do_us");
        !          4753:                if (fread(ptr,(int)len,(int)(*number),f__cf) != *number)
        !          4754:                        err(f__elist->ciend, EOF, "do_us");
        !          4755:                return(0);
        !          4756:        }
        !          4757:        else
        !          4758:        {
        !          4759:                f__reclen += *number * len;
        !          4760:                (void) fwrite(ptr,(int)len,(int)(*number),f__cf);
        !          4761:                return(0);
        !          4762:        }
        !          4763: }
        !          4764: #ifdef KR_headers
        !          4765: integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
        !          4766: #else
        !          4767: integer do_ud(ftnint *number, char *ptr, ftnlen len)
        !          4768: #endif
        !          4769: {
        !          4770:        f__recpos += *number * len;
        !          4771:        if(f__recpos > f__curunit->url && f__curunit->url!=1)
        !          4772:                err(f__elist->cierr,110,"do_ud");
        !          4773:        if(f__reading)
        !          4774:        {
        !          4775:                if(fread(ptr,(int)len,(int)(*number),f__cf) != *number)
        !          4776:                        err(f__elist->cierr,EOF,"do_ud")
        !          4777:                else return(0);
        !          4778:        }
        !          4779:        (void) fwrite(ptr,(int)len,(int)(*number),f__cf);
        !          4780:        return(0);
        !          4781: }
        !          4782: #ifdef KR_headers
        !          4783: integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
        !          4784: #else
        !          4785: integer do_uio(ftnint *number, char *ptr, ftnlen len)
        !          4786: #endif
        !          4787: {
        !          4788:        if(f__sequential)
        !          4789:                return(do_us(number,ptr,len));
        !          4790:        else    return(do_ud(number,ptr,len));
        !          4791: }
        !          4792: ./ ADD NAME=libI77/util.c TIME=719848233
        !          4793: #ifndef MSDOS
        !          4794: #include "sys/types.h"
        !          4795: #include "sys/stat.h"
        !          4796: #endif
        !          4797: #include "f2c.h"
        !          4798: #include "fio.h"
        !          4799: 
        !          4800:  VOID
        !          4801: #ifdef KR_headers
        !          4802: g_char(a,alen,b) char *a,*b; ftnlen alen;
        !          4803: #else
        !          4804: g_char(char *a, ftnlen alen, char *b)
        !          4805: #endif
        !          4806: {
        !          4807:        char *x = a + alen, *y = b + alen;
        !          4808: 
        !          4809:        for(;; y--) {
        !          4810:                if (x <= a) {
        !          4811:                        *b = 0;
        !          4812:                        return;
        !          4813:                        }
        !          4814:                if (*--x != ' ')
        !          4815:                        break;
        !          4816:                }
        !          4817:        *y-- = 0;
        !          4818:        do *y-- = *x;
        !          4819:                while(x-- > a);
        !          4820:        }
        !          4821: 
        !          4822:  VOID
        !          4823: #ifdef KR_headers
        !          4824: b_char(a,b,blen) char *a,*b; ftnlen blen;
        !          4825: #else
        !          4826: b_char(char *a, char *b, ftnlen blen)
        !          4827: #endif
        !          4828: {      int i;
        !          4829:        for(i=0;i<blen && *a!=0;i++) *b++= *a++;
        !          4830:        for(;i<blen;i++) *b++=' ';
        !          4831: }
        !          4832: #ifndef MSDOS
        !          4833: #ifdef KR_headers
        !          4834: long f__inode(a, dev) char *a; int *dev;
        !          4835: #else
        !          4836: long f__inode(char *a, int *dev)
        !          4837: #endif
        !          4838: {      struct stat x;
        !          4839:        if(stat(a,&x)<0) return(-1);
        !          4840:        *dev = x.st_dev;
        !          4841:        return(x.st_ino);
        !          4842: }
        !          4843: #endif
        !          4844: 
        !          4845: #define INTBOUND sizeof(int)-1
        !          4846:  VOID
        !          4847: #ifdef KR_headers
        !          4848: f__mvgbt(n,len,a,b) char *a,*b;
        !          4849: #else
        !          4850: f__mvgbt(int n, int len, char *a, char *b)
        !          4851: #endif
        !          4852: {      register int num=n*len;
        !          4853:        if( ((int)a&INTBOUND)==0 && ((int)b&INTBOUND)==0 && (num&INTBOUND)==0 )
        !          4854:        {       register int *x=(int *)a,*y=(int *)b;
        !          4855:                num /= sizeof(int);
        !          4856:                if(x>y) for(;num>0;num--) *y++= *x++;
        !          4857:                else for(num--;num>=0;num--) *(y+num)= *(x+num);
        !          4858:        }
        !          4859:        else
        !          4860:        {       register char *x=a,*y=b;
        !          4861:                if(x>y) for(;num>0;num--) *y++= *x++;
        !          4862:                else for(num--;num>=0;num--) *(y+num)= *(x+num);
        !          4863:        }
        !          4864: }
        !          4865: ./ ADD NAME=libI77/wref.c TIME=719848233
        !          4866: #include "f2c.h"
        !          4867: #include "fio.h"
        !          4868: #include "fmt.h"
        !          4869: #include "fp.h"
        !          4870: #ifndef VAX
        !          4871: #include "ctype.h"
        !          4872: #endif
        !          4873: 
        !          4874: #ifndef KR_headers
        !          4875: #undef abs
        !          4876: #undef min
        !          4877: #undef max
        !          4878: #include "stdlib.h"
        !          4879: #include "string.h"
        !          4880: #endif
        !          4881: 
        !          4882: #ifdef KR_headers
        !          4883: wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
        !          4884: #else
        !          4885: wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
        !          4886: #endif
        !          4887: {
        !          4888:        char buf[FMAX+EXPMAXDIGS+4], *s, *se;
        !          4889:        int d1, delta, e1, i, sign, signspace;
        !          4890:        double dd;
        !          4891: #ifndef VAX
        !          4892:        int e0 = e;
        !          4893: #endif
        !          4894: 
        !          4895:        if(e <= 0)
        !          4896:                e = 2;
        !          4897:        if(f__scale) {
        !          4898:                if(f__scale >= d + 2 || f__scale <= -d)
        !          4899:                        goto nogood;
        !          4900:                }
        !          4901:        if(f__scale <= 0)
        !          4902:                --d;
        !          4903:        if (len == sizeof(real))
        !          4904:                dd = p->pf;
        !          4905:        else
        !          4906:                dd = p->pd;
        !          4907:        if (dd < 0.) {
        !          4908:                signspace = sign = 1;
        !          4909:                dd = -dd;
        !          4910:                }
        !          4911:        else {
        !          4912:                sign = 0;
        !          4913:                signspace = f__cplus;
        !          4914: #ifndef VAX
        !          4915:                if (!dd)
        !          4916:                        dd = 0.;        /* avoid -0 */
        !          4917: #endif
        !          4918:                }
        !          4919:        delta = w - (2 /* for the . and the d adjustment above */
        !          4920:                        + 2 /* for the E+ */ + signspace + d + e);
        !          4921:        if (delta < 0) {
        !          4922: nogood:
        !          4923:                while(--w >= 0)
        !          4924:                        PUT('*');
        !          4925:                return(0);
        !          4926:                }
        !          4927:        if (f__scale < 0)
        !          4928:                d += f__scale;
        !          4929:        if (d > FMAX) {
        !          4930:                d1 = d - FMAX;
        !          4931:                d = FMAX;
        !          4932:                }
        !          4933:        else
        !          4934:                d1 = 0;
        !          4935:        sprintf(buf,"%#.*E", d, dd);
        !          4936: #ifndef VAX
        !          4937:        /* check for NaN, Infinity */
        !          4938:        if (!isdigit(buf[0])) {
        !          4939:                switch(buf[0]) {
        !          4940:                        case 'n':
        !          4941:                        case 'N':
        !          4942:                                signspace = 0;  /* no sign for NaNs */
        !          4943:                        }
        !          4944:                delta = w - strlen(buf) - signspace;
        !          4945:                if (delta < 0)
        !          4946:                        goto nogood;
        !          4947:                while(--delta >= 0)
        !          4948:                        PUT(' ');
        !          4949:                if (signspace)
        !          4950:                        PUT(sign ? '-' : '+');
        !          4951:                for(s = buf; *s; s++)
        !          4952:                        PUT(*s);
        !          4953:                return 0;
        !          4954:                }
        !          4955: #endif
        !          4956:        se = buf + d + 3;
        !          4957:        if (f__scale != 1 && dd)
        !          4958:                sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
        !          4959:        s = ++se;
        !          4960:        if (e < 2) {
        !          4961:                if (*s != '0')
        !          4962:                        goto nogood;
        !          4963:                }
        !          4964: #ifndef VAX
        !          4965:        /* accommodate 3 significant digits in exponent */
        !          4966:        if (s[2]) {
        !          4967: #ifdef Pedantic
        !          4968:                if (!e0 && !s[3])
        !          4969:                        for(s -= 2, e1 = 2; s[0] = s[1]; s++);
        !          4970: 
        !          4971:        /* Pedantic gives the behavior that Fortran 77 specifies,       */
        !          4972:        /* i.e., requires that E be specified for exponent fields       */
        !          4973:        /* of more than 3 digits.  With Pedantic undefined, we get      */
        !          4974:        /* the behavior that Cray displays -- you get a bigger          */
        !          4975:        /* exponent field if it fits.   */
        !          4976: #else
        !          4977:                if (!e0) {
        !          4978:                        for(s -= 2, e1 = 2; s[0] = s[1]; s++)
        !          4979: #ifdef CRAY
        !          4980:                                delta--;
        !          4981:                        if ((delta += 4) < 0)
        !          4982:                                goto nogood
        !          4983: #endif
        !          4984:                                ;
        !          4985:                        }
        !          4986: #endif
        !          4987:                else if (e0 >= 0)
        !          4988:                        goto shift;
        !          4989:                else
        !          4990:                        e1 = e;
        !          4991:                }
        !          4992:        else
        !          4993:  shift:
        !          4994: #endif
        !          4995:                for(s += 2, e1 = 2; *s; ++e1, ++s)
        !          4996:                        if (e1 >= e)
        !          4997:                                goto nogood;
        !          4998:        while(--delta >= 0)
        !          4999:                PUT(' ');
        !          5000:        if (signspace)
        !          5001:                PUT(sign ? '-' : '+');
        !          5002:        s = buf;
        !          5003:        i = f__scale;
        !          5004:        if (f__scale <= 0) {
        !          5005:                PUT('.');
        !          5006:                for(; i < 0; ++i)
        !          5007:                        PUT('0');
        !          5008:                PUT(*s);
        !          5009:                s += 2;
        !          5010:                }
        !          5011:        else if (f__scale > 1) {
        !          5012:                PUT(*s);
        !          5013:                s += 2;
        !          5014:                while(--i > 0)
        !          5015:                        PUT(*s++);
        !          5016:                PUT('.');
        !          5017:                }
        !          5018:        if (d1) {
        !          5019:                se -= 2;
        !          5020:                while(s < se) PUT(*s++);
        !          5021:                se += 2;
        !          5022:                do PUT('0'); while(--d1 > 0);
        !          5023:                }
        !          5024:        while(s < se)
        !          5025:                PUT(*s++);
        !          5026:        if (e < 2)
        !          5027:                PUT(s[1]);
        !          5028:        else {
        !          5029:                while(++e1 <= e)
        !          5030:                        PUT('0');
        !          5031:                while(*s)
        !          5032:                        PUT(*s++);
        !          5033:                }
        !          5034:        return 0;
        !          5035:        }
        !          5036: 
        !          5037: #ifdef KR_headers
        !          5038: wrt_F(p,w,d,len) ufloat *p; ftnlen len;
        !          5039: #else
        !          5040: wrt_F(ufloat *p, int w, int d, ftnlen len)
        !          5041: #endif
        !          5042: {
        !          5043:        int d1, sign, n;
        !          5044:        double x;
        !          5045:        char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
        !          5046: 
        !          5047:        x= (len==sizeof(real)?p->pf:p->pd);
        !          5048:        if (d < MAXFRACDIGS)
        !          5049:                d1 = 0;
        !          5050:        else {
        !          5051:                d1 = d - MAXFRACDIGS;
        !          5052:                d = MAXFRACDIGS;
        !          5053:                }
        !          5054:        if (x < 0.)
        !          5055:                { x = -x; sign = 1; }
        !          5056:        else {
        !          5057:                sign = 0;
        !          5058: #ifndef VAX
        !          5059:                if (!x)
        !          5060:                        x = 0.;
        !          5061: #endif
        !          5062:                }
        !          5063: 
        !          5064:        if (n = f__scale)
        !          5065:                if (n > 0)
        !          5066:                        do x *= 10.; while(--n > 0);
        !          5067:                else
        !          5068:                        do x *= 0.1; while(++n < 0);
        !          5069: 
        !          5070: #ifdef USE_STRLEN
        !          5071:        sprintf(b = buf, "%#.*f", d, x);
        !          5072:        n = strlen(b) + d1;
        !          5073: #else
        !          5074:        n = sprintf(b = buf, "%#.*f", d, x) + d1;
        !          5075: #endif
        !          5076: 
        !          5077:        if (buf[0] == '0' && d)
        !          5078:                { ++b; --n; }
        !          5079:        if (sign) {
        !          5080:                /* check for all zeros */
        !          5081:                for(s = b;;) {
        !          5082:                        while(*s == '0') s++;
        !          5083:                        switch(*s) {
        !          5084:                                case '.':
        !          5085:                                        s++; continue;
        !          5086:                                case 0:
        !          5087:                                        sign = 0;
        !          5088:                                }
        !          5089:                        break;
        !          5090:                        }
        !          5091:                }
        !          5092:        if (sign || f__cplus)
        !          5093:                ++n;
        !          5094:        if (n > w) {
        !          5095:                while(--w >= 0)
        !          5096:                        PUT('*');
        !          5097:                return 0;
        !          5098:                }
        !          5099:        for(w -= n; --w >= 0; )
        !          5100:                PUT(' ');
        !          5101:        if (sign)
        !          5102:                PUT('-');
        !          5103:        else if (f__cplus)
        !          5104:                PUT('+');
        !          5105:        while(n = *b++)
        !          5106:                PUT(n);
        !          5107:        while(--d1 >= 0)
        !          5108:                PUT('0');
        !          5109:        return 0;
        !          5110:        }
        !          5111: ./ ADD NAME=libI77/wrtfmt.c TIME=719848233
        !          5112: #include "f2c.h"
        !          5113: #include "fio.h"
        !          5114: #include "fmt.h"
        !          5115: extern int f__cursor;
        !          5116: #ifdef KR_headers
        !          5117: extern char *f__icvt();
        !          5118: #else
        !          5119: extern char *f__icvt(long, int*, int*, int);
        !          5120: #endif
        !          5121: int f__hiwater;
        !          5122: icilist *f__svic;
        !          5123: char *f__icptr;
        !          5124: mv_cur(Void)   /* shouldn't use fseek because it insists on calling fflush */
        !          5125:                /* instead we know too much about stdio */
        !          5126: {
        !          5127:        if(f__external == 0) {
        !          5128:                if(f__cursor < 0) {
        !          5129:                        if(f__hiwater < f__recpos)
        !          5130:                                f__hiwater = f__recpos;
        !          5131:                        f__recpos += f__cursor;
        !          5132:                        f__icptr += f__cursor;
        !          5133:                        f__cursor = 0;
        !          5134:                        if(f__recpos < 0)
        !          5135:                                err(f__elist->cierr, 110, "left off");
        !          5136:                }
        !          5137:                else if(f__cursor > 0) {
        !          5138:                        if(f__recpos + f__cursor >= f__svic->icirlen)
        !          5139:                                err(f__elist->cierr, 110, "recend");
        !          5140:                        if(f__hiwater <= f__recpos)
        !          5141:                                for(; f__cursor > 0; f__cursor--)
        !          5142:                                        (*f__putn)(' ');
        !          5143:                        else if(f__hiwater <= f__recpos + f__cursor) {
        !          5144:                                f__cursor -= f__hiwater - f__recpos;
        !          5145:                                f__icptr += f__hiwater - f__recpos;
        !          5146:                                f__recpos = f__hiwater;
        !          5147:                                for(; f__cursor > 0; f__cursor--)
        !          5148:                                        (*f__putn)(' ');
        !          5149:                        }
        !          5150:                        else {
        !          5151:                                f__icptr += f__cursor;
        !          5152:                                f__recpos += f__cursor;
        !          5153:                        }
        !          5154:                        f__cursor = 0;
        !          5155:                }
        !          5156:                return(0);
        !          5157:        }
        !          5158:        if(f__cursor > 0) {
        !          5159:                if(f__hiwater <= f__recpos)
        !          5160:                        for(;f__cursor>0;f__cursor--) (*f__putn)(' ');
        !          5161:                else if(f__hiwater <= f__recpos + f__cursor) {
        !          5162: #ifndef NON_UNIX_STDIO
        !          5163:                        if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf))
        !          5164:                                f__cf->_ptr += f__hiwater - f__recpos;
        !          5165:                        else
        !          5166: #endif
        !          5167:                                (void) fseek(f__cf, (long) (f__hiwater - f__recpos), SEEK_CUR);
        !          5168:                        f__cursor -= f__hiwater - f__recpos;
        !          5169:                        f__recpos = f__hiwater;
        !          5170:                        for(; f__cursor > 0; f__cursor--)
        !          5171:                                (*f__putn)(' ');
        !          5172:                }
        !          5173:                else {
        !          5174: #ifndef NON_UNIX_STDIO
        !          5175:                        if(f__cf->_ptr + f__cursor < buf_end(f__cf))
        !          5176:                                f__cf->_ptr += f__cursor;
        !          5177:                        else
        !          5178: #endif
        !          5179:                                (void) fseek(f__cf, (long)f__cursor, SEEK_CUR);
        !          5180:                        f__recpos += f__cursor;
        !          5181:                }
        !          5182:        }
        !          5183:        if(f__cursor<0)
        !          5184:        {
        !          5185:                if(f__cursor+f__recpos<0) err(f__elist->cierr,110,"left off");
        !          5186: #ifndef NON_UNIX_STDIO
        !          5187:                if(f__cf->_ptr + f__cursor >= f__cf->_base)
        !          5188:                        f__cf->_ptr += f__cursor;
        !          5189:                else
        !          5190: #endif
        !          5191:                if(f__curunit && f__curunit->useek)
        !          5192:                        (void) fseek(f__cf,(long)f__cursor,SEEK_CUR);
        !          5193:                else
        !          5194:                        err(f__elist->cierr,106,"fmt");
        !          5195:                if(f__hiwater < f__recpos)
        !          5196:                        f__hiwater = f__recpos;
        !          5197:                f__recpos += f__cursor;
        !          5198:                f__cursor=0;
        !          5199:        }
        !          5200:        return(0);
        !          5201: }
        !          5202: 
        !          5203:  static int
        !          5204: #ifdef KR_headers
        !          5205: wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len;
        !          5206: #else
        !          5207: wrt_Z(Uint *n, int w, int minlen, ftnlen len)
        !          5208: #endif
        !          5209: {
        !          5210:        register char *s, *se;
        !          5211:        register i, w1;
        !          5212:        static int one = 1;
        !          5213:        static char hex[] = "0123456789ABCDEF";
        !          5214:        s = (char *)n;
        !          5215:        --len;
        !          5216:        if (*(char *)&one) {
        !          5217:                /* little endian */
        !          5218:                se = s;
        !          5219:                s += len;
        !          5220:                i = -1;
        !          5221:                }
        !          5222:        else {
        !          5223:                se = s + len;
        !          5224:                i = 1;
        !          5225:                }
        !          5226:        for(;; s += i, w1 += 2)
        !          5227:                if (s == se || *s)
        !          5228:                        break;
        !          5229:        w1 = (i*(se-s) << 1) + 1;
        !          5230:        if (*s & 0xf0)
        !          5231:                w1++;
        !          5232:        if (w1 > w)
        !          5233:                for(i = 0; i < w; i++)
        !          5234:                        (*f__putn)('*');
        !          5235:        else {
        !          5236:                if ((minlen -= w1) > 0)
        !          5237:                        w1 += minlen;
        !          5238:                while(--w >= w1)
        !          5239:                        (*f__putn)(' ');
        !          5240:                while(--minlen >= 0)
        !          5241:                        (*f__putn)('0');
        !          5242:                if (!(*s & 0xf0)) {
        !          5243:                        (*f__putn)(hex[*s & 0xf]);
        !          5244:                        if (s == se)
        !          5245:                                return 0;
        !          5246:                        s += i;
        !          5247:                        }
        !          5248:                for(;; s += i) {
        !          5249:                        (*f__putn)(hex[*s >> 4 & 0xf]);
        !          5250:                        (*f__putn)(hex[*s & 0xf]);
        !          5251:                        if (s == se)
        !          5252:                                break;
        !          5253:                        }
        !          5254:                }
        !          5255:        return 0;
        !          5256:        }
        !          5257: 
        !          5258:  static int
        !          5259: #ifdef KR_headers
        !          5260: wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base;
        !          5261: #else
        !          5262: wrt_I(Uint *n, int w, ftnlen len, register int base)
        !          5263: #endif
        !          5264: {      int ndigit,sign,spare,i;
        !          5265:        long x;
        !          5266:        char *ans;
        !          5267:        if(len==sizeof(integer)) x=n->il;
        !          5268:        else if(len == sizeof(char)) x = n->ic;
        !          5269:        else x=n->is;
        !          5270:        ans=f__icvt(x,&ndigit,&sign, base);
        !          5271:        spare=w-ndigit;
        !          5272:        if(sign || f__cplus) spare--;
        !          5273:        if(spare<0)
        !          5274:                for(i=0;i<w;i++) (*f__putn)('*');
        !          5275:        else
        !          5276:        {       for(i=0;i<spare;i++) (*f__putn)(' ');
        !          5277:                if(sign) (*f__putn)('-');
        !          5278:                else if(f__cplus) (*f__putn)('+');
        !          5279:                for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
        !          5280:        }
        !          5281:        return(0);
        !          5282: }
        !          5283:  static int
        !          5284: #ifdef KR_headers
        !          5285: wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base;
        !          5286: #else
        !          5287: wrt_IM(Uint *n, int w, int m, ftnlen len, int base)
        !          5288: #endif
        !          5289: {      int ndigit,sign,spare,i,xsign;
        !          5290:        long x;
        !          5291:        char *ans;
        !          5292:        if(sizeof(integer)==len) x=n->il;
        !          5293:        else if(len == sizeof(char)) x = n->ic;
        !          5294:        else x=n->is;
        !          5295:        ans=f__icvt(x,&ndigit,&sign, base);
        !          5296:        if(sign || f__cplus) xsign=1;
        !          5297:        else xsign=0;
        !          5298:        if(ndigit+xsign>w || m+xsign>w)
        !          5299:        {       for(i=0;i<w;i++) (*f__putn)('*');
        !          5300:                return(0);
        !          5301:        }
        !          5302:        if(x==0 && m==0)
        !          5303:        {       for(i=0;i<w;i++) (*f__putn)(' ');
        !          5304:                return(0);
        !          5305:        }
        !          5306:        if(ndigit>=m)
        !          5307:                spare=w-ndigit-xsign;
        !          5308:        else
        !          5309:                spare=w-m-xsign;
        !          5310:        for(i=0;i<spare;i++) (*f__putn)(' ');
        !          5311:        if(sign) (*f__putn)('-');
        !          5312:        else if(f__cplus) (*f__putn)('+');
        !          5313:        for(i=0;i<m-ndigit;i++) (*f__putn)('0');
        !          5314:        for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
        !          5315:        return(0);
        !          5316: }
        !          5317:  static int
        !          5318: #ifdef KR_headers
        !          5319: wrt_AP(s) char *s;
        !          5320: #else
        !          5321: wrt_AP(char *s)
        !          5322: #endif
        !          5323: {      char quote;
        !          5324:        if(f__cursor && mv_cur()) return(mv_cur());
        !          5325:        quote = *s++;
        !          5326:        for(;*s;s++)
        !          5327:        {       if(*s!=quote) (*f__putn)(*s);
        !          5328:                else if(*++s==quote) (*f__putn)(*s);
        !          5329:                else return(1);
        !          5330:        }
        !          5331:        return(1);
        !          5332: }
        !          5333:  static int
        !          5334: #ifdef KR_headers
        !          5335: wrt_H(a,s) char *s;
        !          5336: #else
        !          5337: wrt_H(int a, char *s)
        !          5338: #endif
        !          5339: {
        !          5340:        if(f__cursor && mv_cur()) return(mv_cur());
        !          5341:        while(a--) (*f__putn)(*s++);
        !          5342:        return(1);
        !          5343: }
        !          5344: #ifdef KR_headers
        !          5345: wrt_L(n,len, sz) Uint *n; ftnlen sz;
        !          5346: #else
        !          5347: wrt_L(Uint *n, int len, ftnlen sz)
        !          5348: #endif
        !          5349: {      int i;
        !          5350:        long x;
        !          5351:        if(sizeof(long)==sz) x=n->il;
        !          5352:        else if(sz == sizeof(char)) x = n->ic;
        !          5353:        else x=n->is;
        !          5354:        for(i=0;i<len-1;i++)
        !          5355:                (*f__putn)(' ');
        !          5356:        if(x) (*f__putn)('T');
        !          5357:        else (*f__putn)('F');
        !          5358:        return(0);
        !          5359: }
        !          5360:  static int
        !          5361: #ifdef KR_headers
        !          5362: wrt_A(p,len) char *p; ftnlen len;
        !          5363: #else
        !          5364: wrt_A(char *p, ftnlen len)
        !          5365: #endif
        !          5366: {
        !          5367:        while(len-- > 0) (*f__putn)(*p++);
        !          5368:        return(0);
        !          5369: }
        !          5370:  static int
        !          5371: #ifdef KR_headers
        !          5372: wrt_AW(p,w,len) char * p; ftnlen len;
        !          5373: #else
        !          5374: wrt_AW(char * p, int w, ftnlen len)
        !          5375: #endif
        !          5376: {
        !          5377:        while(w>len)
        !          5378:        {       w--;
        !          5379:                (*f__putn)(' ');
        !          5380:        }
        !          5381:        while(w-- > 0)
        !          5382:                (*f__putn)(*p++);
        !          5383:        return(0);
        !          5384: }
        !          5385: 
        !          5386:  static int
        !          5387: #ifdef KR_headers
        !          5388: wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
        !          5389: #else
        !          5390: wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
        !          5391: #endif
        !          5392: {      double up = 1,x;
        !          5393:        int i,oldscale=f__scale,n,j;
        !          5394:        x= len==sizeof(real)?p->pf:p->pd;
        !          5395:        if(x < 0 ) x = -x;
        !          5396:        if(x<.1) return(wrt_E(p,w,d,e,len));
        !          5397:        for(i=0;i<=d;i++,up*=10)
        !          5398:        {       if(x>=up) continue;
        !          5399:                f__scale=0;
        !          5400:                if(e==0) n=4;
        !          5401:                else    n=e+2;
        !          5402:                i=wrt_F(p,w-n,d-i,len);
        !          5403:                for(j=0;j<n;j++) (*f__putn)(' ');
        !          5404:                f__scale=oldscale;
        !          5405:                return(i);
        !          5406:        }
        !          5407:        return(wrt_E(p,w,d,e,len));
        !          5408: }
        !          5409: #ifdef KR_headers
        !          5410: w_ed(p,ptr,len) struct f__syl *p; char *ptr; ftnlen len;
        !          5411: #else
        !          5412: w_ed(struct f__syl *p, char *ptr, ftnlen len)
        !          5413: #endif
        !          5414: {
        !          5415:        if(f__cursor && mv_cur()) return(mv_cur());
        !          5416:        switch(p->op)
        !          5417:        {
        !          5418:        default:
        !          5419:                fprintf(stderr,"w_ed, unexpected code: %d\n", p->op);
        !          5420:                sig_die(f__fmtbuf, 1);
        !          5421:        case I: return(wrt_I((Uint *)ptr,p->p1,len, 10));
        !          5422:        case IM:
        !          5423:                return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,10));
        !          5424: 
        !          5425:                /* O and OM don't work right for character, double, complex, */
        !          5426:                /* or doublecomplex, and they differ from Fortran 90 in */
        !          5427:                /* showing a minus sign for negative values. */
        !          5428: 
        !          5429:        case O: return(wrt_I((Uint *)ptr, p->p1, len, 8));
        !          5430:        case OM:
        !          5431:                return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,8));
        !          5432:        case L: return(wrt_L((Uint *)ptr,p->p1, len));
        !          5433:        case A: return(wrt_A(ptr,len));
        !          5434:        case AW:
        !          5435:                return(wrt_AW(ptr,p->p1,len));
        !          5436:        case D:
        !          5437:        case E:
        !          5438:        case EE:
        !          5439:                return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len));
        !          5440:        case G:
        !          5441:        case GE:
        !          5442:                return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len));
        !          5443:        case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len));
        !          5444: 
        !          5445:                /* Z and ZM assume 8-bit bytes. */
        !          5446: 
        !          5447:        case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len));
        !          5448:        case ZM:
        !          5449:                return(wrt_Z((Uint *)ptr,p->p1,p->p2,len));
        !          5450:        }
        !          5451: }
        !          5452: #ifdef KR_headers
        !          5453: w_ned(p) struct f__syl *p;
        !          5454: #else
        !          5455: w_ned(struct f__syl *p)
        !          5456: #endif
        !          5457: {
        !          5458:        switch(p->op)
        !          5459:        {
        !          5460:        default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op);
        !          5461:                sig_die(f__fmtbuf, 1);
        !          5462:        case SLASH:
        !          5463:                return((*f__donewrec)());
        !          5464:        case T: f__cursor = p->p1-f__recpos - 1;
        !          5465:                return(1);
        !          5466:        case TL: f__cursor -= p->p1;
        !          5467:                if(f__cursor < -f__recpos)      /* TL1000, 1X */
        !          5468:                        f__cursor = -f__recpos;
        !          5469:                return(1);
        !          5470:        case TR:
        !          5471:        case X:
        !          5472:                f__cursor += p->p1;
        !          5473:                return(1);
        !          5474:        case APOS:
        !          5475:                return(wrt_AP(*(char **)&p->p2));
        !          5476:        case H:
        !          5477:                return(wrt_H(p->p1,*(char **)&p->p2));
        !          5478:        }
        !          5479: }
        !          5480: ./ ADD NAME=libI77/wsfe.c TIME=719848233
        !          5481: /*write sequential formatted external*/
        !          5482: #include "f2c.h"
        !          5483: #include "fio.h"
        !          5484: #include "fmt.h"
        !          5485: extern int f__hiwater;
        !          5486: 
        !          5487: #ifdef KR_headers
        !          5488: x_putc(c)
        !          5489: #else
        !          5490: x_putc(int c)
        !          5491: #endif
        !          5492: {
        !          5493:        /* this uses \n as an indicator of record-end */
        !          5494:        if(c == '\n' && f__recpos < f__hiwater) {       /* fseek calls fflush, a loss */
        !          5495: #ifndef NON_UNIX_STDIO
        !          5496:                if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf))
        !          5497:                        f__cf->_ptr += f__hiwater - f__recpos;
        !          5498:                else
        !          5499: #endif
        !          5500:                        (void) fseek(f__cf, (long)(f__hiwater - f__recpos), SEEK_CUR);
        !          5501:        }
        !          5502:        f__recpos++;
        !          5503:        return putc(c,f__cf);
        !          5504: }
        !          5505: x_wSL(Void)
        !          5506: {
        !          5507:        (*f__putn)('\n');
        !          5508:        f__recpos=0;
        !          5509:        f__cursor = 0;
        !          5510:        f__hiwater = 0;
        !          5511:        return(1);
        !          5512: }
        !          5513: xw_end(Void)
        !          5514: {
        !          5515:        if(f__nonl == 0)
        !          5516:                (*f__putn)('\n');
        !          5517:        f__hiwater = f__recpos = f__cursor = 0;
        !          5518:        return(0);
        !          5519: }
        !          5520: xw_rev(Void)
        !          5521: {
        !          5522:        if(f__workdone) (*f__putn)('\n');
        !          5523:        f__hiwater = f__recpos = f__cursor = 0;
        !          5524:        return(f__workdone=0);
        !          5525: }
        !          5526: 
        !          5527: #ifdef KR_headers
        !          5528: integer s_wsfe(a) cilist *a;   /*start*/
        !          5529: #else
        !          5530: integer s_wsfe(cilist *a)      /*start*/
        !          5531: #endif
        !          5532: {      int n;
        !          5533:        if(!f__init) f_init();
        !          5534:        if(n=c_sfe(a)) return(n);
        !          5535:        f__reading=0;
        !          5536:        f__sequential=1;
        !          5537:        f__formatted=1;
        !          5538:        f__external=1;
        !          5539:        f__elist=a;
        !          5540:        f__hiwater = f__cursor=f__recpos=0;
        !          5541:        f__nonl = 0;
        !          5542:        f__scale=0;
        !          5543:        f__fmtbuf=a->cifmt;
        !          5544:        f__curunit = &f__units[a->ciunit];
        !          5545:        f__cf=f__curunit->ufd;
        !          5546:        if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
        !          5547:        f__putn= x_putc;
        !          5548:        f__doed= w_ed;
        !          5549:        f__doned= w_ned;
        !          5550:        f__doend=xw_end;
        !          5551:        f__dorevert=xw_rev;
        !          5552:        f__donewrec=x_wSL;
        !          5553:        fmt_bg();
        !          5554:        f__cplus=0;
        !          5555:        f__cblank=f__curunit->ublnk;
        !          5556:        if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
        !          5557:                err(a->cierr,errno,"write start");
        !          5558:        return(0);
        !          5559: }
        !          5560: ./ ADD NAME=libI77/wsle.c TIME=719848233
        !          5561: #include "f2c.h"
        !          5562: #include "fio.h"
        !          5563: #include "fmt.h"
        !          5564: #include "lio.h"
        !          5565: 
        !          5566: #ifdef KR_headers
        !          5567: integer s_wsle(a) cilist *a;
        !          5568: #else
        !          5569: integer s_wsle(cilist *a)
        !          5570: #endif
        !          5571: {
        !          5572:        int n;
        !          5573:        if(!f__init) f_init();
        !          5574:        if(n=c_le(a)) return(n);
        !          5575:        f__reading=0;
        !          5576:        f__external=1;
        !          5577:        f__formatted=1;
        !          5578:        f__putn = t_putc;
        !          5579:        f__lioproc = l_write;
        !          5580:        L_len = LINE;
        !          5581:        f__donewrec = x_wSL;
        !          5582:        if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
        !          5583:                err(a->cierr, errno, "list output start");
        !          5584:        return(0);
        !          5585:        }
        !          5586: 
        !          5587: integer e_wsle(Void)
        !          5588: {
        !          5589:        t_putc('\n');
        !          5590:        f__recpos=0;
        !          5591:        if (f__cf == stdout)
        !          5592:                fflush(stdout);
        !          5593:        else if (f__cf == stderr)
        !          5594:                fflush(stderr);
        !          5595:        return(0);
        !          5596:        }
        !          5597: ./ ADD NAME=libI77/wsne.c TIME=719848234
        !          5598: #include "f2c.h"
        !          5599: #include "fio.h"
        !          5600: #include "lio.h"
        !          5601: 
        !          5602:  integer
        !          5603: #ifdef KR_headers
        !          5604: s_wsne(a) cilist *a;
        !          5605: #else
        !          5606: s_wsne(cilist *a)
        !          5607: #endif
        !          5608: {
        !          5609:        int n;
        !          5610:        extern integer e_wsle(Void);
        !          5611: 
        !          5612:        if(!f__init)
        !          5613:                f_init();
        !          5614:        if(n=c_le(a))
        !          5615:                return(n);
        !          5616:        f__reading=0;
        !          5617:        f__external=1;
        !          5618:        f__formatted=1;
        !          5619:        f__putn = t_putc;
        !          5620:        L_len = LINE;
        !          5621:        f__donewrec = x_wSL;
        !          5622:        if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
        !          5623:                err(a->cierr, errno, "namelist output start");
        !          5624:        x_wsne(a);
        !          5625:        return e_wsle();
        !          5626:        }
        !          5627: ./ ADD NAME=libI77/xwsne.c TIME=719848234
        !          5628: #include "f2c.h"
        !          5629: #include "fio.h"
        !          5630: #include "lio.h"
        !          5631: #include "fmt.h"
        !          5632: 
        !          5633: #ifdef KR_headers
        !          5634: x_wsne(a) cilist *a;
        !          5635: #else
        !          5636: #include "string.h"
        !          5637: 
        !          5638:  VOID
        !          5639: x_wsne(cilist *a)
        !          5640: #endif
        !          5641: {
        !          5642:        Namelist *nl;
        !          5643:        char *s;
        !          5644:        Vardesc *v, **vd, **vde;
        !          5645:        ftnint *number, type;
        !          5646:        ftnlen *dims;
        !          5647:        ftnlen size;
        !          5648:        static ftnint one = 1;
        !          5649:        extern ftnlen f__typesize[];
        !          5650: 
        !          5651:        nl = (Namelist *)a->cifmt;
        !          5652:        PUT('&');
        !          5653:        for(s = nl->name; *s; s++)
        !          5654:                PUT(*s);
        !          5655:        PUT(' ');
        !          5656:        vd = nl->vars;
        !          5657:        vde = vd + nl->nvars;
        !          5658:        while(vd < vde) {
        !          5659:                v = *vd++;
        !          5660:                s = v->name;
        !          5661:                if (f__recpos+strlen(s)+2 >= L_len)
        !          5662:                        (*f__donewrec)();
        !          5663:                while(*s)
        !          5664:                        PUT(*s++);
        !          5665:                PUT(' ');
        !          5666:                PUT('=');
        !          5667:                number = (dims = v->dims) ? dims + 1 : &one;
        !          5668:                type = v->type;
        !          5669:                if (type < 0) {
        !          5670:                        size = -type;
        !          5671:                        type = TYCHAR;
        !          5672:                        }
        !          5673:                else
        !          5674:                        size = f__typesize[type];
        !          5675:                l_write(number, v->addr, size, type);
        !          5676:                if (vd < vde) {
        !          5677:                        if (f__recpos+2 >= L_len)
        !          5678:                                (*f__donewrec)();
        !          5679:                        PUT(',');
        !          5680:                        PUT(' ');
        !          5681:                        }
        !          5682:                else if (f__recpos+1 >= L_len)
        !          5683:                        (*f__donewrec)();
        !          5684:                }
        !          5685:        PUT('/');
        !          5686:        }
        !          5687: ./ ENDUP

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.