Return to libI77.st0 CVS log

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

Annotation of researchv10dc/cmd/f2c/libI77.st0, revision 1.1

1.1     ! root        1: ./ ADD NAME=libI77/README TIME=627747849
        !             2: If your system lacks /usr/include/local.h ,
        !             3: then you should create an appropriate local.h in
        !             4: this directory.  An appropriate local.h may simply
        !             5: be empty, or it may #define VAX or #define CRAY
        !             6: (or whatever else you must do to make fp.h work right).
        !             7: Alternatively, edit fp.h to suite your machine.
        !             8: 
        !             9: If your system's sprintf does not work the way ANSI C
        !            10: specifies -- specifically, if it does not return the
        !            11: number of characters transmitted -- then insert the line
        !            12: 
        !            13: #define USE_STRLEN
        !            14: 
        !            15: at the beginning of wref.c .  This is necessary with
        !            16: at least some versions of Sun software.
        !            17: 
        !            18: If you get error messages about references to cf->_ptr
        !            19: and cf->_base when compiling wrtfmt.c and wsfe.c or to
        !            20: stderr->_flag when compiling err.c, then insert the line
        !            21: 
        !            22: #define NON_UNIX_STDIO
        !            23: 
        !            24: at the beginning of fio.h, and recompile these modules.
        !            25: 
        !            26: You may need to supply the following non-ANSI routines:
        !            27: 
        !            28:   access(char *Name, 0) is supposed to return 0
        !            29: if file Name exists, nonzero otherwise.
        !            30: 
        !            31:   fstat(int fileds, struct stat *buf) is similar
        !            32: to stat(char *name, struct stat *buf), except that
        !            33: the first argument, fileds, is the file descriptor
        !            34: returned by open rather than the name of the file.
        !            35: fstat is used in the system-dependent routine
        !            36: canseek (in the libI77 source file err.c), which
        !            37: is supposed to return 1 if it's possible to issue
        !            38: seeks on the file in question, 0 if it's not; you may
        !            39: need to suitably modify err.c
        !            40: 
        !            41:   char * mktemp(char *buf) is supposed to replace the
        !            42: 6 trailing X's in buf with a unique number and then
        !            43: return buf.  The idea is to get a unique name for
        !            44: a temporary file.
        !            45: ./ ADD NAME=libI77/makefile TIME=628988590
        !            46: .SUFFIXES: .c .o
        !            47: 
        !            48: CFLAGS =-I. -O
        !            49: 
        !            50: # compile, then strip unnecessary symbols
        !            51: .c.o:
        !            52:        cc $(CFLAGS) -c $*.c
        !            53:        ld -r -x $*.o
        !            54:        mv a.out $*.o
        !            55: 
        !            56: OBJ =  Version.o backspace.o dfe.o due.o iio.o inquire.o rewind.o rsfe.o \
        !            57:        rdfmt.o sue.o uio.o wsfe.o sfe.o fmt.o lio.o lread.o open.o \
        !            58:        close.o util.o endfile.o wrtfmt.o wref.o err.o fmtlib.o
        !            59: 
        !            60: libI77.a:      $(OBJ)
        !            61:                ar r libI77.a $?
        !            62:                ranlib libI77.a
        !            63: install:       libI77.a
        !            64:        cp libI77.a /usr/lib/libI77.a
        !            65:        ranlib /usr/lib/libI77.a
        !            66: 
        !            67: lio.o: lio.h
        !            68: SRC=   lio.h fio.h fmt.h backspace.c dfe.c due.c iio.c inquire.c rewind.c \
        !            69:        rsfe.c rdfmt.c sue.c uio.c wsfe.c sfe.c fmt.c lio.c lread.c open.c \
        !            70:        close.c util.c endfile.c wrtfmt.c wref.c err.c fmtlib.c
        !            71: 
        !            72: Version.o: Version.c
        !            73:        cc -c Version.c
        !            74: 
        !            75: 
        !            76: clean:
        !            77:        rm -f $(OBJ) libI77.a
        !            78: 
        !            79: clobber:       clean
        !            80:        rm -f libI77.a
        !            81: 
        !            82: backspace.o:  fio.h
        !            83: close.o:  fio.h
        !            84: dfe.o:  fio.h
        !            85: dfe.o:  fmt.h
        !            86: due.o:  fio.h
        !            87: endfile.o:  fio.h
        !            88: err.o:  fio.h
        !            89: fmt.o:  fio.h
        !            90: fmt.o:  fmt.h
        !            91: ftest.o:  fio.h
        !            92: iio.o:  fio.h
        !            93: iio.o:  fmt.h
        !            94: inquire.o:  fio.h
        !            95: lib.o:  fio.h
        !            96: lio.o:  fio.h
        !            97: lio.o:  fmt.h
        !            98: lio.o:  lio.h
        !            99: lread.o:  fio.h
        !           100: lread.o:  fmt.h
        !           101: lread.o:  lio.h
        !           102: lread.o:  fp.h
        !           103: nio.o:  fio.h
        !           104: nio.o:  fmt.h
        !           105: nio.o:  lio.h
        !           106: open.o:  fio.h
        !           107: rdfmt.o:  fio.h
        !           108: rdfmt.o:  fmt.h
        !           109: rdfmt.o:  fp.h
        !           110: rewind.o:  fio.h
        !           111: rsfe.o:  fio.h
        !           112: rsfe.o:  fmt.h
        !           113: sfe.o:  fio.h
        !           114: stest.o:  fio.h
        !           115: sue.o:  fio.h
        !           116: uio.o:  fio.h
        !           117: util.o:  fio.h
        !           118: wref.o:  fio.h fmt.h fp.h
        !           119: wrtfmt.o:  fio.h
        !           120: wrtfmt.o:  fmt.h
        !           121: wsfe.o:  fio.h
        !           122: wsfe.o:  fmt.h
        !           123: namelist.o: fio.h lio.h
        !           124: ./ ADD NAME=libI77/Version.c TIME=628965828
        !           125: static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods  6 Dec. 1989\n";
        !           126: 
        !           127: /*
        !           128: 2.01   $ format added
        !           129: 2.02   Coding bug in open.c repaired
        !           130: 2.03   fixed bugs in lread.c (read * with negative f-format) and lio.c
        !           131:        and lio.h (e-format conforming to spec)
        !           132: 2.04   changed open.c and err.c (fopen and freopen respectively) to
        !           133:        update to new c-library (append mode)
        !           134: 2.05   added namelist capability
        !           135: */
        !           136: 
        !           137: /*
        !           138: close.c:
        !           139:        allow upper-case STATUS= values
        !           140: endfile.c
        !           141:        create fort.nnn if unit nnn not open;
        !           142:        else if (file length == 0) use creat() rather than copy;
        !           143:        use local copy() rather than forking /bin/cp;
        !           144:        rewind, fseek to clear buffer (for no reading past EOF)
        !           145: err.c
        !           146:        use neither setbuf nor setvbuf; make stderr buffered
        !           147: fio.h
        !           148:        #define _bufend
        !           149: inquire.c
        !           150:        upper case responses;
        !           151:        omit byfile test from SEQUENTIAL=
        !           152:        answer "YES" to DIRECT= for unopened file (open to debate)
        !           153: lio.c
        !           154:        flush stderr, stdout at end of each stmt
        !           155:        space before character strings in list output only at line start
        !           156: lio.h
        !           157:        adjust LEW, LED consistent with old libI77
        !           158: lread.c
        !           159:        use atof()
        !           160:        allow "nnn*," when reading complex constants
        !           161: open.c
        !           162:        try opening for writing when open for read fails, with
        !           163:        special uwrt value (2) delaying creat() to first write;
        !           164:        set curunit so error messages don't drop core;
        !           165:        no file name ==> fort.nnn except for STATUS='SCRATCH'
        !           166: rdfmt.c
        !           167:        use atof(); trust EOF == end-of-file (so don't read past
        !           168:        end-of-file after endfile stmt)
        !           169: sfe.c
        !           170:        flush stderr, stdout at end of each stmt
        !           171: wrtfmt.c:
        !           172:        use upper case
        !           173:        put wrt_E and wrt_F into wref.c, use sprintf()
        !           174:                rather than ecvt() and fcvt() [more accurate on VAX]
        !           175: */
        !           176: 
        !           177: /* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */
        !           178: 
        !           179: /* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */
        !           180: 
        !           181: /* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */
        !           182: /* 29 Nov. 1989: change various int return types to long for f2c */
        !           183: /* 30 Nov. 1989: various types from f2c.h */
        !           184: /* 6 Dec. 1989: types corrected various places */
        !           185: ./ ADD NAME=libI77/backspace.c TIME=628440563
        !           186: #include "f2c.h"
        !           187: #include "fio.h"
        !           188: integer f_back(a) alist *a;
        !           189: {      unit *b;
        !           190:        int n,i;
        !           191:        long x;
        !           192:        char buf[32];
        !           193:        if(a->aunit >= MXUNIT || a->aunit < 0)
        !           194:                err(a->aerr,101,"backspace")
        !           195:        b= &units[a->aunit];
        !           196:        if(b->useek==0) err(a->aerr,106,"backspace")
        !           197:        if(b->ufd==NULL) {
        !           198:                fk_open(1, 1, a->aunit);
        !           199:                return(0);
        !           200:                }
        !           201:        if(b->uend==1)
        !           202:        {       b->uend=0;
        !           203:                return(0);
        !           204:        }
        !           205:        if(b->uwrt) {
        !           206:                (void) t_runc(a);
        !           207:                if (nowreading(b))
        !           208:                        err(a->aerr,errno,"backspace")
        !           209:                }
        !           210:        if(b->url>0)
        !           211:        {       long y;
        !           212:                x=ftell(b->ufd);
        !           213:                y = x % b->url;
        !           214:                if(y == 0) x--;
        !           215:                x /= b->url;
        !           216:                x *= b->url;
        !           217:                (void) fseek(b->ufd,x,0);
        !           218:                return(0);
        !           219:        }
        !           220:        
        !           221:        if(b->ufmt==0)
        !           222:        {       (void) fseek(b->ufd,-(long)sizeof(int),1);
        !           223:                (void) fread((char *)&n,sizeof(int),1,b->ufd);
        !           224:                (void) fseek(b->ufd,-(long)n-2*sizeof(int),1);
        !           225:                return(0);
        !           226:        }
        !           227:        for(;;)
        !           228:        {       long y;
        !           229:                y = x=ftell(b->ufd);
        !           230:                if(x<sizeof(buf)) x=0;
        !           231:                else x -= sizeof(buf);
        !           232:                (void) fseek(b->ufd,x,0);
        !           233:                n=fread(buf,1,(int)(y-x), b->ufd);
        !           234:                for(i=n-2;i>=0;i--)
        !           235:                {
        !           236:                        if(buf[i]!='\n') continue;
        !           237:                        (void) fseek(b->ufd,(long)(i+1-n),1);
        !           238:                        return(0);
        !           239:                }
        !           240:                if(x==0)
        !           241:                        {
        !           242:                        (void) fseek(b->ufd, 0L, 0);
        !           243:                        return(0);
        !           244:                        }
        !           245:                else if(n<=0) err(a->aerr,(EOF),"backspace")
        !           246:                (void) fseek(b->ufd, x, 0);
        !           247:        }
        !           248: }
        !           249: ./ ADD NAME=libI77/close.c TIME=628440563
        !           250: #include "f2c.h"
        !           251: #include "fio.h"
        !           252: integer f_clos(a) cllist *a;
        !           253: {      unit *b;
        !           254:        if(a->cunit >= MXUNIT) return(0);
        !           255:        b= &units[a->cunit];
        !           256:        if(b->ufd==NULL) return(0);
        !           257:        b->uend=0;
        !           258:        if(a->csta!=0)
        !           259:                switch(*a->csta)
        !           260:                {
        !           261:                default:
        !           262:                keep:
        !           263:                case 'k':
        !           264:                case 'K':
        !           265:                        if(b->uwrt == 1) (void) t_runc((alist *)a);
        !           266:                        (void) fclose(b->ufd);  /* sys 5 has strange beliefs */
        !           267:                        if(b->ufnm!=0) free(b->ufnm);
        !           268:                        b->ufnm=NULL;
        !           269:                        b->ufd=NULL;
        !           270:                        return(0);
        !           271:                case 'd':
        !           272:                case 'D':
        !           273:                delete:
        !           274:                        (void) fclose(b->ufd);
        !           275:                        if(b->ufnm!=0)
        !           276:                        {       (void) unlink(b->ufnm); /*SYSDEP*/
        !           277:                                free(b->ufnm);
        !           278:                        }
        !           279:                        b->ufnm=NULL;
        !           280:                        b->ufd=NULL;
        !           281:                        return(0);
        !           282:                }
        !           283:        else if(b->uscrtch==1) goto delete;
        !           284:        else goto keep;
        !           285: }
        !           286:  void
        !           287: f_exit()
        !           288: {      int i;
        !           289:        static cllist xx;
        !           290:        if (!xx.cerr) {
        !           291:                xx.cerr=1;
        !           292:                xx.csta=NULL;
        !           293:                for(i=0;i<MXUNIT;i++)
        !           294:                {
        !           295:                        xx.cunit=i;
        !           296:                        (void) f_clos(&xx);
        !           297:                }
        !           298:        }
        !           299: }
        !           300: flush_()
        !           301: {      int i;
        !           302:        for(i=0;i<MXUNIT;i++)
        !           303:                if(units[i].ufd != NULL) (void) fflush(units[i].ufd);
        !           304: }
        !           305: ./ ADD NAME=libI77/dfe.c TIME=629055520
        !           306: #include "f2c.h"
        !           307: #include "fio.h"
        !           308: #include "fmt.h"
        !           309: extern int rd_ed(),rd_ned(),y_getc(),y_putc(),y_err();
        !           310: extern int y_rev(), y_rsk(), y_newrec();
        !           311: extern int w_ed(),w_ned();
        !           312: integer s_rdfe(a) cilist *a;
        !           313: {
        !           314:        int n;
        !           315:        if(!init) f_init();
        !           316:        if(n=c_dfe(a))return(n);
        !           317:        reading=1;
        !           318:        if(curunit->uwrt && nowreading(curunit))
        !           319:                err(a->cierr,errno,"read start");
        !           320:        getn = y_getc;
        !           321:        doed = rd_ed;
        !           322:        doned = rd_ned;
        !           323:        dorevert = donewrec = y_err;
        !           324:        doend = y_rsk;
        !           325:        if(pars_f(fmtbuf)<0)
        !           326:                err(a->cierr,100,"read start");
        !           327:        fmt_bg();
        !           328:        return(0);
        !           329: }
        !           330: integer s_wdfe(a) cilist *a;
        !           331: {
        !           332:        int n;
        !           333:        if(!init) f_init();
        !           334:        if(n=c_dfe(a)) return(n);
        !           335:        reading=0;
        !           336:        if(curunit->uwrt != 1 && nowwriting(curunit))
        !           337:                err(a->cierr,errno,"startwrt");
        !           338:        putn = y_putc;
        !           339:        doed = w_ed;
        !           340:        doned= w_ned;
        !           341:        dorevert = y_err;
        !           342:        donewrec = y_newrec;
        !           343:        doend = y_rev;
        !           344:        if(pars_f(fmtbuf)<0)
        !           345:                err(a->cierr,100,"startwrt");
        !           346:        fmt_bg();
        !           347:        return(0);
        !           348: }
        !           349: integer e_rdfe()
        !           350: {
        !           351:        (void) en_fio();
        !           352:        return(0);
        !           353: }
        !           354: integer e_wdfe()
        !           355: {
        !           356:        (void) en_fio();
        !           357:        return(0);
        !           358: }
        !           359: c_dfe(a) cilist *a;
        !           360: {
        !           361:        sequential=0;
        !           362:        formatted=external=1;
        !           363:        elist=a;
        !           364:        cursor=scale=recpos=0;
        !           365:        if(a->ciunit>MXUNIT || a->ciunit<0)
        !           366:                err(a->cierr,101,"startchk");
        !           367:        curunit = &units[a->ciunit];
        !           368:        if(curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit))
        !           369:                err(a->cierr,104,"dfe");
        !           370:        cf=curunit->ufd;
        !           371:        if(!curunit->ufmt) err(a->cierr,102,"dfe")
        !           372:        if(!curunit->useek) err(a->cierr,104,"dfe")
        !           373:        fmtbuf=a->cifmt;
        !           374:        (void) fseek(cf,(long)curunit->url * (a->cirec-1),0);
        !           375:        curunit->uend = 0;
        !           376:        return(0);
        !           377: }
        !           378: y_rsk()
        !           379: {
        !           380:        if(curunit->uend || curunit->url <= recpos
        !           381:                || curunit->url == 1) return 0;
        !           382:        do {
        !           383:                getc(cf);
        !           384:        } while(++recpos < curunit->url);
        !           385:        return 0;
        !           386: }
        !           387: y_getc()
        !           388: {
        !           389:        int ch;
        !           390:        if(curunit->uend) return(-1);
        !           391:        if((ch=getc(cf))!=EOF)
        !           392:        {
        !           393:                recpos++;
        !           394:                if(curunit->url>=recpos ||
        !           395:                        curunit->url==1)
        !           396:                        return(ch);
        !           397:                else    return(' ');
        !           398:        }
        !           399:        if(feof(cf))
        !           400:        {
        !           401:                curunit->uend=1;
        !           402:                errno=0;
        !           403:                return(-1);
        !           404:        }
        !           405:        err(elist->cierr,errno,"readingd");
        !           406: }
        !           407: y_putc(c)
        !           408: {
        !           409:        recpos++;
        !           410:        if(recpos <= curunit->url || curunit->url==1)
        !           411:                putc(c,cf);
        !           412:        else
        !           413:                err(elist->cierr,110,"dout");
        !           414:        return(0);
        !           415: }
        !           416: y_rev()
        !           417: {      /*what about work done?*/
        !           418:        if(curunit->url==1 || recpos==curunit->url)
        !           419:                return(0);
        !           420:        while(recpos<curunit->url)
        !           421:                (*putn)(' ');
        !           422:        recpos=0;
        !           423:        return(0);
        !           424: }
        !           425: y_err()
        !           426: {
        !           427:        err(elist->cierr, 110, "dfe");
        !           428: }
        !           429: 
        !           430: y_newrec()
        !           431: {
        !           432:        if(curunit->url == 1 || recpos == curunit->url) {
        !           433:                hiwater = recpos = cursor = 0;
        !           434:                return(1);
        !           435:        }
        !           436:        if(hiwater > recpos)
        !           437:                recpos = hiwater;
        !           438:        y_rev();
        !           439:        hiwater = cursor = 0;
        !           440:        return(1);
        !           441: }
        !           442: ./ ADD NAME=libI77/due.c TIME=628440563
        !           443: #include "f2c.h"
        !           444: #include "fio.h"
        !           445: integer s_rdue(a) cilist *a;
        !           446: {
        !           447:        int n;
        !           448:        if(n=c_due(a)) return(n);
        !           449:        reading=1;
        !           450:        if(curunit->uwrt && nowreading(curunit))
        !           451:                err(a->cierr,errno,"read start");
        !           452:        return(0);
        !           453: }
        !           454: integer s_wdue(a) cilist *a;
        !           455: {
        !           456:        int n;
        !           457:        if(n=c_due(a)) return(n);
        !           458:        reading=0;
        !           459:        if(curunit->uwrt != 1 && nowwriting(curunit))
        !           460:                err(a->cierr,errno,"write start");
        !           461:        return(0);
        !           462: }
        !           463: c_due(a) cilist *a;
        !           464: {
        !           465:        if(!init) f_init();
        !           466:        if(a->ciunit>=MXUNIT || a->ciunit<0)
        !           467:                err(a->cierr,101,"startio");
        !           468:        recpos=sequential=formatted=0;
        !           469:        external=1;
        !           470:        curunit = &units[a->ciunit];
        !           471:        elist=a;
        !           472:        if(curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due");
        !           473:        cf=curunit->ufd;
        !           474:        if(curunit->ufmt) err(a->cierr,102,"cdue")
        !           475:        if(!curunit->useek) err(a->cierr,104,"cdue")
        !           476:        if(curunit->ufd==NULL) err(a->cierr,114,"cdue")
        !           477:        (void) fseek(cf,(long)(a->cirec-1)*curunit->url,0);
        !           478:        curunit->uend = 0;
        !           479:        return(0);
        !           480: }
        !           481: integer e_rdue()
        !           482: {
        !           483:        if(curunit->url==1 || recpos==curunit->url)
        !           484:                return(0);
        !           485:        (void) fseek(cf,(long)(curunit->url-recpos),1);
        !           486:        if(ftell(cf)%curunit->url)
        !           487:                err(elist->cierr,200,"syserr");
        !           488:        return(0);
        !           489: }
        !           490: integer e_wdue()
        !           491: {
        !           492:        return(e_rdue());
        !           493: }
        !           494: ./ ADD NAME=libI77/endfile.c TIME=628440563
        !           495: #include "f2c.h"
        !           496: #include "fio.h"
        !           497: extern char *mktemp(), *strcpy();
        !           498: integer f_end(a) alist *a;
        !           499: {
        !           500:        unit *b;
        !           501:        if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
        !           502:        b = &units[a->aunit];
        !           503:        if(b->ufd==NULL) {
        !           504:                char nbuf[10];
        !           505:                (void) sprintf(nbuf,"fort.%ld",a->aunit);
        !           506:                close(creat(nbuf, 0666));
        !           507:                return(0);
        !           508:                }
        !           509:        b->uend=1;
        !           510:        return(b->useek ? t_runc(a) : 0);
        !           511: }
        !           512: 
        !           513:  static int
        !           514: copy(from, len, to)
        !           515:  char *from, *to;
        !           516:  register long len;
        !           517: {
        !           518:        register int n;
        !           519:        int k, rc = 0, tmp;
        !           520:        char buf[BUFSIZ];
        !           521: 
        !           522:        if ((k = open(from, 0)) < 0)
        !           523:                return 1;
        !           524:        if ((tmp = creat(to,0666)) < 0)
        !           525:                return 1;
        !           526:        while((n = read(k, buf, len > BUFSIZ ? BUFSIZ : (int)len)) > 0) {
        !           527:                if (write(tmp, buf, n) != n)
        !           528:                        { rc = 1; break; }
        !           529:                if ((len -= n) <= 0)
        !           530:                        break;
        !           531:                }
        !           532:        close(k);
        !           533:        close(tmp);
        !           534:        return n < 0 ? 1 : rc;
        !           535:        }
        !           536: 
        !           537: t_runc(a) alist *a;
        !           538: {
        !           539:        char nm[16];
        !           540:        long loc, len;
        !           541:        unit *b;
        !           542:        int rc = 0;
        !           543: 
        !           544:        b = &units[a->aunit];
        !           545:        if(b->url) return(0);   /*don't truncate direct files*/
        !           546:        loc=ftell(b->ufd);
        !           547:        (void) fseek(b->ufd,0L,2);
        !           548:        len=ftell(b->ufd);
        !           549:        if (loc >= len || b->useek == 0 || b->ufnm == NULL)
        !           550:                return(0);
        !           551:        rewind(b->ufd); /* empty buffer */
        !           552:        if (!loc) {
        !           553:                if (close(creat(b->ufnm,0666)))
        !           554:                        { rc = 1; goto done; }
        !           555:                if (b->uwrt)
        !           556:                        b->uwrt = 1;
        !           557:                return 0;
        !           558:                }
        !           559:        (void) strcpy(nm,"tmp.FXXXXXX");
        !           560:        (void) mktemp(nm);
        !           561:        if (copy(b->ufnm, loc, nm)
        !           562:         || copy(nm, loc, b->ufnm))
        !           563:                rc = 1;
        !           564:        unlink(nm);
        !           565: done:
        !           566:        fseek(b->ufd, loc, 0);
        !           567:        if (rc)
        !           568:                err(a->aerr,111,"endfile");
        !           569:        return 0;
        !           570:        }
        !           571: ./ ADD NAME=libI77/err.c TIME=628473361
        !           572: #include "sys/types.h"
        !           573: #include "sys/stat.h"
        !           574: #include "f2c.h"
        !           575: #include "fio.h"
        !           576: 
        !           577: extern FILE *fdopen();
        !           578: 
        !           579: /*global definitions*/
        !           580: unit units[MXUNIT];    /*unit table*/
        !           581: flag init;     /*0 on entry, 1 after initializations*/
        !           582: cilist *elist; /*active external io list*/
        !           583: flag reading;  /*1 if reading, 0 if writing*/
        !           584: flag cplus,cblank;
        !           585: char *fmtbuf;
        !           586: flag external; /*1 if external io, 0 if internal */
        !           587: int (*doed)(),(*doned)();
        !           588: int (*doend)(),(*donewrec)(),(*dorevert)();
        !           589: flag sequential;       /*1 if sequential io, 0 if direct*/
        !           590: flag formatted;        /*1 if formatted io, 0 if unformatted*/
        !           591: int (*getn)(),(*putn)();       /*for formatted io*/
        !           592: FILE *cf;      /*current file*/
        !           593: unit *curunit; /*current unit*/
        !           594: int recpos;    /*place in current record*/
        !           595: int cursor,scale;
        !           596: 
        !           597: /*error messages*/
        !           598: char *F_err[] =
        !           599: {
        !           600:        "error in format",                              /* 100 */
        !           601:        "illegal unit number",                          /* 101 */
        !           602:        "formatted io not allowed",                     /* 102 */
        !           603:        "unformatted io not allowed",                   /* 103 */
        !           604:        "direct io not allowed",                        /* 104 */
        !           605:        "sequential io not allowed",                    /* 105 */
        !           606:        "can't backspace file",                         /* 106 */
        !           607:        "null file name",                               /* 107 */
        !           608:        "can't stat file",                              /* 108 */
        !           609:        "unit not connected",                           /* 109 */
        !           610:        "off end of record",                            /* 110 */
        !           611:        "truncation failed in endfile",                 /* 111 */
        !           612:        "incomprehensible list input",                  /* 112 */
        !           613:        "out of free space",                            /* 113 */
        !           614:        "unit not connected",                           /* 114 */
        !           615:        "read unexpected character",                    /* 115 */
        !           616:        "blank logical input field",                    /* 116 */
        !           617:        "bad variable type",                            /* 117 */
        !           618:        "bad namelist name",                            /* 118 */
        !           619:        "variable not in namelist",                     /* 119 */
        !           620:        "no end record",                                /* 120 */
        !           621:        "variable count incorrect"                      /* 121 */
        !           622: };
        !           623: #define MAXERR (sizeof(F_err)/sizeof(char *)+100)
        !           624: fatal(n,s) char *s;
        !           625: {
        !           626:        if(n<100 && n>=0) perror(s); /*SYSDEP*/
        !           627:        else if(n >= (int)MAXERR || n < -1)
        !           628:        {       fprintf(stderr,"%s: illegal error number %d\n",s,n);
        !           629:        }
        !           630:        else if(n == -1) fprintf(stderr,"%s: end of file\n",s);
        !           631:        else
        !           632:                fprintf(stderr,"%s: %s\n",s,F_err[n-100]);
        !           633:        fprintf(stderr,"apparent state: unit %d ",curunit-units);
        !           634:        fprintf(stderr, curunit->ufnm ? "named %s\n" : "(unnamed)\n",
        !           635:                curunit->ufnm);
        !           636:        if (fmtbuf)
        !           637:                fprintf(stderr,"last format: %s\n",fmtbuf);
        !           638:        fprintf(stderr,"lately %s %s %s %s IO\n",reading?"reading":"writing",
        !           639:                sequential?"sequential":"direct",formatted?"formatted":"unformatted",
        !           640:                external?"external":"internal");
        !           641:        _cleanup();
        !           642:        abort();
        !           643: }
        !           644: /*initialization routine*/
        !           645: f_init()
        !           646: {      unit *p;
        !           647: 
        !           648:        init=1;
        !           649:        p= &units[0];
        !           650:        p->ufd=stderr;
        !           651:        p->useek=canseek(stderr);
        !           652: #ifdef COMMENTED_OUT
        !           653:        if(isatty(fileno(stderr))) {
        !           654:                extern char *malloc();
        !           655:                setbuf(stderr, malloc(BUFSIZ));
        !           656:                /* setvbuf(stderr, _IOLBF, 0, 0); */
        !           657:        }       /* wastes space, but win for debugging in windows */
        !           658: #endif
        !           659: #ifdef NON_UNIX_STDIO
        !           660:        {extern char *malloc(); setbuf(stderr, malloc(BUFSIZ));}
        !           661: #else
        !           662:        stderr->_flag &= ~_IONBF;
        !           663: #endif
        !           664:        p->ufmt=1;
        !           665:        p->uwrt=1;
        !           666:        p = &units[5];
        !           667:        p->ufd=stdin;
        !           668:        p->useek=canseek(stdin);
        !           669:        p->ufmt=1;
        !           670:        p->uwrt=0;
        !           671:        p= &units[6];
        !           672:        p->ufd=stdout;
        !           673:        p->useek=canseek(stdout);
        !           674:        /* IOLBUF and setvbuf only in system 5+ */
        !           675: #ifdef COMMENTED_OUT
        !           676:        if(isatty(fileno(stdout))) {
        !           677:                extern char _sobuf[];
        !           678:                setbuf(stdout, _sobuf);
        !           679:                /* setvbuf(stdout, _IOLBF, 0, 0);       /* the buf arg in setvbuf? */
        !           680:                p->useek = 1;   /* only within a record no bigger than BUFSIZ */
        !           681:        }
        !           682: #endif
        !           683:        p->ufmt=1;
        !           684:        p->uwrt=1;
        !           685: }
        !           686: canseek(f) FILE *f; /*SYSDEP*/
        !           687: {      struct stat x;
        !           688:        if(fstat(fileno(f),&x) < 0)
        !           689:                return(0);
        !           690:        switch(x.st_mode & S_IFMT) {
        !           691:        case S_IFDIR:
        !           692:        case S_IFREG:
        !           693:                if(x.st_nlink > 0)      /* !pipe */
        !           694:                        return(1);
        !           695:                else
        !           696:                        return(0);
        !           697:        case S_IFCHR:
        !           698:                if(isatty(fileno(f)))
        !           699:                        return(0);
        !           700:                return(1);
        !           701: #ifdef S_IFBLK
        !           702:        case S_IFBLK:
        !           703:                return(1);
        !           704: #endif
        !           705:        }
        !           706:        return(0);      /* who knows what it is? */
        !           707: }
        !           708: nowreading(x) unit *x;
        !           709: {
        !           710:        long loc;
        !           711:        x->uwrt=0;
        !           712:        loc=ftell(x->ufd);
        !           713:        if(freopen(x->ufnm,"r",x->ufd) == NULL)
        !           714:                return(1);
        !           715:        (void) fseek(x->ufd,loc,0);
        !           716:        return(0);
        !           717: }
        !           718: nowwriting(x) unit *x;
        !           719: {
        !           720:        long loc;
        !           721:        int k;
        !           722: 
        !           723:        if (x->uwrt == 3) { /* just did write, rewind */
        !           724:                if (close(creat(x->ufnm,0666)))
        !           725:                        return(1);
        !           726:                }
        !           727:        else {  
        !           728:                loc=ftell(x->ufd);
        !           729:                if (fclose(x->ufd) < 0
        !           730:                || (k = x->uwrt == 2 ? creat(x->ufnm,0666) : open(x->ufnm,1)) < 0
        !           731:                || (x->ufd = fdopen(k,"w")) == NULL) {
        !           732:                        x->ufd = NULL;
        !           733:                        return(1);
        !           734:                        }
        !           735:                (void) fseek(x->ufd,loc,0);
        !           736:                }
        !           737:        x->uwrt = 1;
        !           738:        return(0);
        !           739: }
        !           740: ./ ADD NAME=libI77/fio.h TIME=628474795
        !           741: #include "stdio.h"
        !           742: #ifndef NULL
        !           743: /* ANSI C */
        !           744: #include "stddef.h"
        !           745: #endif
        !           746: 
        !           747: /*units*/
        !           748: typedef struct
        !           749: {      FILE *ufd;      /*0=unconnected*/
        !           750:        char *ufnm;
        !           751:        long uinode;
        !           752:        int url;        /*0=sequential*/
        !           753:        flag useek;     /*true=can backspace, use dir, ...*/
        !           754:        flag ufmt;
        !           755:        flag uprnt;
        !           756:        flag ublnk;
        !           757:        flag uend;
        !           758:        flag uwrt;      /*last io was write*/
        !           759:        flag uscrtch;
        !           760: } unit;
        !           761: 
        !           762: extern int errno;
        !           763: extern flag init;
        !           764: extern cilist *elist;  /*active external io list*/
        !           765: extern flag reading,external,sequential,formatted;
        !           766: extern int (*getn)(),(*putn)();        /*for formatted io*/
        !           767: extern FILE *cf;       /*current file*/
        !           768: extern unit *curunit;  /*current unit*/
        !           769: extern unit units[];
        !           770: #define err(f,m,s) {if(f) errno= m; else fatal(m,s); return(m);}
        !           771: 
        !           772: /*Table sizes*/
        !           773: #define MXUNIT 100
        !           774: 
        !           775: extern int recpos;     /*position in current record*/
        !           776: extern int cursor;     /* offset to move to */
        !           777: extern int hiwater;    /* so TL doesn't confuse us */
        !           778: 
        !           779: #define WRITE  1
        !           780: #define READ   2
        !           781: #define SEQ    3
        !           782: #define DIR    4
        !           783: #define FMT    5
        !           784: #define UNF    6
        !           785: #define EXT    7
        !           786: #define INT    8
        !           787: 
        !           788: #define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ)
        !           789: ./ ADD NAME=libI77/fmt.c TIME=628440861
        !           790: #include "f2c.h"
        !           791: #include "fio.h"
        !           792: #include "fmt.h"
        !           793: #define skip(s) while(*s==' ') s++
        !           794: #ifdef interdata
        !           795: #define SYLMX 300
        !           796: #endif
        !           797: #ifdef pdp11
        !           798: #define SYLMX 300
        !           799: #endif
        !           800: #ifdef vax
        !           801: #define SYLMX 300
        !           802: #endif
        !           803: #ifndef SYLMX
        !           804: #define SYLMX 300
        !           805: #endif
        !           806: #define GLITCH '\2'
        !           807:        /* special quote character for stu */
        !           808: extern int cursor,scale;
        !           809: extern flag cblank,cplus;      /*blanks in I and compulsory plus*/
        !           810: struct syl syl[SYLMX];
        !           811: int parenlvl,pc,revloc;
        !           812: 
        !           813: char *f_s(),*f_list(),*i_tem(),*gt_num();
        !           814: 
        !           815: pars_f(s) char *s;
        !           816: {
        !           817:        parenlvl=revloc=pc=0;
        !           818:        if(f_s(s,0) == NULL)
        !           819:        {
        !           820:                return(-1);
        !           821:        }
        !           822:        return(0);
        !           823: }
        !           824: char *f_s(s,curloc) char *s;
        !           825: {
        !           826:        skip(s);
        !           827:        if(*s++!='(')
        !           828:        {
        !           829:                return(NULL);
        !           830:        }
        !           831:        if(parenlvl++ ==1) revloc=curloc;
        !           832:        if(op_gen(RET,curloc,0,0)<0 ||
        !           833:                (s=f_list(s))==NULL)
        !           834:        {
        !           835:                return(NULL);
        !           836:        }
        !           837:        skip(s);
        !           838:        return(s);
        !           839: }
        !           840: char *f_list(s) char *s;
        !           841: {
        !           842:        for(;*s!=0;)
        !           843:        {       skip(s);
        !           844:                if((s=i_tem(s))==NULL) return(NULL);
        !           845:                skip(s);
        !           846:                if(*s==',') s++;
        !           847:                else if(*s==')')
        !           848:                {       if(--parenlvl==0)
        !           849:                        {
        !           850:                                (void) op_gen(REVERT,revloc,0,0);
        !           851:                                return(++s);
        !           852:                        }
        !           853:                        (void) op_gen(GOTO,0,0,0);
        !           854:                        return(++s);
        !           855:                }
        !           856:        }
        !           857:        return(NULL);
        !           858: }
        !           859: char *i_tem(s) char *s;
        !           860: {      char *t;
        !           861:        int n,curloc;
        !           862:        if(*s==')') return(s);
        !           863:        if(ne_d(s,&t)) return(t);
        !           864:        if(e_d(s,&t)) return(t);
        !           865:        s=gt_num(s,&n);
        !           866:        if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
        !           867:        return(f_s(s,curloc));
        !           868: }
        !           869: ne_d(s,p) char *s,**p;
        !           870: {      int n,x,sign=0;
        !           871:        char *ap_end();
        !           872:        struct syl *sp;
        !           873:        switch(*s)
        !           874:        {
        !           875:        default:
        !           876:                return(0);
        !           877:        case ':': (void) op_gen(COLON,0,0,0); break;
        !           878:        case '$':
        !           879:                (void) op_gen(NONL, 0, 0, 0); break;
        !           880:        case 'B':
        !           881:        case 'b':
        !           882:                if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0);
        !           883:                else (void) op_gen(BN,0,0,0);
        !           884:                break;
        !           885:        case 'S':
        !           886:        case 's':
        !           887:                if(*(s+1)=='s' || *(s+1) == 'S')
        !           888:                {       x=SS;
        !           889:                        s++;
        !           890:                }
        !           891:                else if(*(s+1)=='p' || *(s+1) == 'P')
        !           892:                {       x=SP;
        !           893:                        s++;
        !           894:                }
        !           895:                else x=S;
        !           896:                (void) op_gen(x,0,0,0);
        !           897:                break;
        !           898:        case '/': (void) op_gen(SLASH,0,0,0); break;
        !           899:        case '-': sign=1;
        !           900:        case '+':       s++;    /*OUTRAGEOUS CODING TRICK*/
        !           901:        case '0': case '1': case '2': case '3': case '4':
        !           902:        case '5': case '6': case '7': case '8': case '9':
        !           903:                s=gt_num(s,&n);
        !           904:                switch(*s)
        !           905:                {
        !           906:                default:
        !           907:                        return(0);
        !           908:                case 'P':
        !           909:                case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break;
        !           910:                case 'X':
        !           911:                case 'x': (void) op_gen(X,n,0,0); break;
        !           912:                case 'H':
        !           913:                case 'h':
        !           914:                        sp = &syl[op_gen(H,n,0,0)];
        !           915:                        *(char **)&sp->p2 = s + 1;
        !           916:                        s+=n;
        !           917:                        break;
        !           918:                }
        !           919:                break;
        !           920:        case GLITCH:
        !           921:        case '"':
        !           922:        case '\'':
        !           923:                sp = &syl[op_gen(APOS,0,0,0)];
        !           924:                *(char **)&sp->p2 = s;
        !           925:                if((*p = ap_end(s)) == NULL)
        !           926:                        return(0);
        !           927:                return(1);
        !           928:        case 'T':
        !           929:        case 't':
        !           930:                if(*(s+1)=='l' || *(s+1) == 'L')
        !           931:                {       x=TL;
        !           932:                        s++;
        !           933:                }
        !           934:                else if(*(s+1)=='r'|| *(s+1) == 'R')
        !           935:                {       x=TR;
        !           936:                        s++;
        !           937:                }
        !           938:                else x=T;
        !           939:                s=gt_num(s+1,&n);
        !           940:                s--;
        !           941:                (void) op_gen(x,n,0,0);
        !           942:                break;
        !           943:        case 'X':
        !           944:        case 'x': (void) op_gen(X,1,0,0); break;
        !           945:        case 'P':
        !           946:        case 'p': (void) op_gen(P,1,0,0); break;
        !           947:        }
        !           948:        s++;
        !           949:        *p=s;
        !           950:        return(1);
        !           951: }
        !           952: e_d(s,p) char *s,**p;
        !           953: {      int n,w,d,e,found=0,x=0;
        !           954:        char *sv=s;
        !           955:        s=gt_num(s,&n);
        !           956:        (void) op_gen(STACK,n,0,0);
        !           957:        switch(*s++)
        !           958:        {
        !           959:        default: break;
        !           960:        case 'E':
        !           961:        case 'e':       x=1;
        !           962:        case 'G':
        !           963:        case 'g':
        !           964:                found=1;
        !           965:                s=gt_num(s,&w);
        !           966:                if(w==0) break;
        !           967:                if(*s=='.')
        !           968:                {       s++;
        !           969:                        s=gt_num(s,&d);
        !           970:                }
        !           971:                else d=0;
        !           972:                if(*s!='E' && *s != 'e')
        !           973:                        (void) op_gen(x==1?E:G,w,d,0);  /* default is Ew.dE2 */
        !           974:                else
        !           975:                {       s++;
        !           976:                        s=gt_num(s,&e);
        !           977:                        (void) op_gen(x==1?EE:GE,w,d,e);
        !           978:                }
        !           979:                break;
        !           980:        case 'O':
        !           981:        case 'o':
        !           982:                found = 1;
        !           983:                s = gt_num(s, &w);
        !           984:                if(w==0) break;
        !           985:                (void) op_gen(O, w, 0, 0);
        !           986:                break;
        !           987:        case 'L':
        !           988:        case 'l':
        !           989:                found=1;
        !           990:                s=gt_num(s,&w);
        !           991:                if(w==0) break;
        !           992:                (void) op_gen(L,w,0,0);
        !           993:                break;
        !           994:        case 'A':
        !           995:        case 'a':
        !           996:                found=1;
        !           997:                skip(s);
        !           998:                if(*s>='0' && *s<='9')
        !           999:                {       s=gt_num(s,&w);
        !          1000:                        if(w==0) break;
        !          1001:                        (void) op_gen(AW,w,0,0);
        !          1002:                        break;
        !          1003:                }
        !          1004:                (void) op_gen(A,0,0,0);
        !          1005:                break;
        !          1006:        case 'F':
        !          1007:        case 'f':
        !          1008:                found=1;
        !          1009:                s=gt_num(s,&w);
        !          1010:                if(w==0) break;
        !          1011:                if(*s=='.')
        !          1012:                {       s++;
        !          1013:                        s=gt_num(s,&d);
        !          1014:                }
        !          1015:                else d=0;
        !          1016:                (void) op_gen(F,w,d,0);
        !          1017:                break;
        !          1018:        case 'D':
        !          1019:        case 'd':
        !          1020:                found=1;
        !          1021:                s=gt_num(s,&w);
        !          1022:                if(w==0) break;
        !          1023:                if(*s=='.')
        !          1024:                {       s++;
        !          1025:                        s=gt_num(s,&d);
        !          1026:                }
        !          1027:                else d=0;
        !          1028:                (void) op_gen(D,w,d,0);
        !          1029:                break;
        !          1030:        case 'I':
        !          1031:        case 'i':
        !          1032:                found=1;
        !          1033:                s=gt_num(s,&w);
        !          1034:                if(w==0) break;
        !          1035:                if(*s!='.')
        !          1036:                {       (void) op_gen(I,w,0,0);
        !          1037:                        break;
        !          1038:                }
        !          1039:                s++;
        !          1040:                s=gt_num(s,&d);
        !          1041:                (void) op_gen(IM,w,d,0);
        !          1042:                break;
        !          1043:        }
        !          1044:        if(found==0)
        !          1045:        {       pc--; /*unSTACK*/
        !          1046:                *p=sv;
        !          1047:                return(0);
        !          1048:        }
        !          1049:        *p=s;
        !          1050:        return(1);
        !          1051: }
        !          1052: op_gen(a,b,c,d)
        !          1053: {      struct syl *p= &syl[pc];
        !          1054:        if(pc>=SYLMX)
        !          1055:        {       fprintf(stderr,"format too complicated:\n%s\n",
        !          1056:                        fmtbuf);
        !          1057:                abort();
        !          1058:        }
        !          1059:        p->op=a;
        !          1060:        p->p1=b;
        !          1061:        p->p2=c;
        !          1062:        p->p3=d;
        !          1063:        return(pc++);
        !          1064: }
        !          1065: char *gt_num(s,n) char *s; int *n;
        !          1066: {      int m=0,cnt=0;
        !          1067:        char c;
        !          1068:        for(c= *s;;c = *s)
        !          1069:        {       if(c==' ')
        !          1070:                {       s++;
        !          1071:                        continue;
        !          1072:                }
        !          1073:                if(c>'9' || c<'0') break;
        !          1074:                m=10*m+c-'0';
        !          1075:                cnt++;
        !          1076:                s++;
        !          1077:        }
        !          1078:        if(cnt==0) *n=1;
        !          1079:        else *n=m;
        !          1080:        return(s);
        !          1081: }
        !          1082: #define STKSZ 10
        !          1083: int cnt[STKSZ],ret[STKSZ],cp,rp;
        !          1084: flag workdone, nonl;
        !          1085: 
        !          1086: integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
        !          1087: {      struct syl *p;
        !          1088:        int n,i;
        !          1089:        for(i=0;i<*number;i++,ptr+=len)
        !          1090:        {
        !          1091: loop:  switch(type_f((p= &syl[pc])->op))
        !          1092:        {
        !          1093:        default:
        !          1094:                fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
        !          1095:                        p->op,fmtbuf);
        !          1096:                err(elist->cierr,100,"do_fio");
        !          1097:        case NED:
        !          1098:                if((*doned)(p))
        !          1099:                {       pc++;
        !          1100:                        goto loop;
        !          1101:                }
        !          1102:                pc++;
        !          1103:                continue;
        !          1104:        case ED:
        !          1105:                if(cnt[cp]<=0)
        !          1106:                {       cp--;
        !          1107:                        pc++;
        !          1108:                        goto loop;
        !          1109:                }
        !          1110:                if(ptr==NULL)
        !          1111:                        return((*doend)());
        !          1112:                cnt[cp]--;
        !          1113:                workdone=1;
        !          1114:                if((n=(*doed)(p,ptr,len))>0) err(elist->cierr,errno,"fmt");
        !          1115:                if(n<0) err(elist->ciend,(EOF),"fmt");
        !          1116:                continue;
        !          1117:        case STACK:
        !          1118:                cnt[++cp]=p->p1;
        !          1119:                pc++;
        !          1120:                goto loop;
        !          1121:        case RET:
        !          1122:                ret[++rp]=p->p1;
        !          1123:                pc++;
        !          1124:                goto loop;
        !          1125:        case GOTO:
        !          1126:                if(--cnt[cp]<=0)
        !          1127:                {       cp--;
        !          1128:                        rp--;
        !          1129:                        pc++;
        !          1130:                        goto loop;
        !          1131:                }
        !          1132:                pc=1+ret[rp--];
        !          1133:                goto loop;
        !          1134:        case REVERT:
        !          1135:                rp=cp=0;
        !          1136:                pc = p->p1;
        !          1137:                if(ptr==NULL)
        !          1138:                        return((*doend)());
        !          1139:                if(!workdone) return(0);
        !          1140:                if((n=(*dorevert)()) != 0) return(n);
        !          1141:                goto loop;
        !          1142:        case COLON:
        !          1143:                if(ptr==NULL)
        !          1144:                        return((*doend)());
        !          1145:                pc++;
        !          1146:                goto loop;
        !          1147:        case NONL:
        !          1148:                nonl = 1;
        !          1149:                pc++;
        !          1150:                goto loop;
        !          1151:        case S:
        !          1152:        case SS:
        !          1153:                cplus=0;
        !          1154:                pc++;
        !          1155:                goto loop;
        !          1156:        case SP:
        !          1157:                cplus = 1;
        !          1158:                pc++;
        !          1159:                goto loop;
        !          1160:        case P: scale=p->p1;
        !          1161:                pc++;
        !          1162:                goto loop;
        !          1163:        case BN:
        !          1164:                cblank=0;
        !          1165:                pc++;
        !          1166:                goto loop;
        !          1167:        case BZ:
        !          1168:                cblank=1;
        !          1169:                pc++;
        !          1170:                goto loop;
        !          1171:        }
        !          1172:        }
        !          1173:        return(0);
        !          1174: }
        !          1175: en_fio()
        !          1176: {      ftnint one=1;
        !          1177:        return(do_fio(&one,(char *)NULL,0l));
        !          1178: }
        !          1179: fmt_bg()
        !          1180: {
        !          1181:        workdone=cp=rp=pc=cursor=0;
        !          1182:        cnt[0]=ret[0]=0;
        !          1183: }
        !          1184: type_f(n)
        !          1185: {
        !          1186:        switch(n)
        !          1187:        {
        !          1188:        default:
        !          1189:                return(n);
        !          1190:        case RET:
        !          1191:                return(RET);
        !          1192:        case REVERT: return(REVERT);
        !          1193:        case GOTO: return(GOTO);
        !          1194:        case STACK: return(STACK);
        !          1195:        case X:
        !          1196:        case SLASH:
        !          1197:        case APOS: case H:
        !          1198:        case T: case TL: case TR:
        !          1199:                return(NED);
        !          1200:        case F:
        !          1201:        case I:
        !          1202:        case IM:
        !          1203:        case A: case AW:
        !          1204:        case O:
        !          1205:        case L:
        !          1206:        case E: case EE: case D:
        !          1207:        case G: case GE:
        !          1208:                return(ED);
        !          1209:        }
        !          1210: }
        !          1211: char *ap_end(s) char *s;
        !          1212: {      char quote;
        !          1213:        quote= *s++;
        !          1214:        for(;*s;s++)
        !          1215:        {       if(*s!=quote) continue;
        !          1216:                if(*++s!=quote) return(s);
        !          1217:        }
        !          1218:        if(elist->cierr) {
        !          1219:                errno = 100;
        !          1220:                return(NULL);
        !          1221:        }
        !          1222:        fatal(100, "bad string");
        !          1223:        /*NOTREACHED*/ return 0;
        !          1224: }
        !          1225: ./ ADD NAME=libI77/fmt.h TIME=628555644
        !          1226: struct syl
        !          1227: {      int op,p1,p2,p3;
        !          1228: };
        !          1229: #define RET 1
        !          1230: #define REVERT 2
        !          1231: #define GOTO 3
        !          1232: #define X 4
        !          1233: #define SLASH 5
        !          1234: #define STACK 6
        !          1235: #define I 7
        !          1236: #define ED 8
        !          1237: #define NED 9
        !          1238: #define IM 10
        !          1239: #define APOS 11
        !          1240: #define H 12
        !          1241: #define TL 13
        !          1242: #define TR 14
        !          1243: #define T 15
        !          1244: #define COLON 16
        !          1245: #define S 17
        !          1246: #define SP 18
        !          1247: #define SS 19
        !          1248: #define P 20
        !          1249: #define BN 21
        !          1250: #define BZ 22
        !          1251: #define F 23
        !          1252: #define E 24
        !          1253: #define EE 25
        !          1254: #define D 26
        !          1255: #define G 27
        !          1256: #define GE 28
        !          1257: #define L 29
        !          1258: #define A 30
        !          1259: #define AW 31
        !          1260: #define O 32
        !          1261: #define NONL 33
        !          1262: extern struct syl syl[];
        !          1263: extern int pc,parenlvl,revloc;
        !          1264: extern int (*doed)(),(*doned)();
        !          1265: extern int (*dorevert)(),(*donewrec)(),(*doend)();
        !          1266: extern flag cblank,cplus,workdone, nonl;
        !          1267: extern int dummy();
        !          1268: extern char *fmtbuf;
        !          1269: extern int scale;
        !          1270: typedef union
        !          1271: {      real pf;
        !          1272:        doublereal pd;
        !          1273: } ufloat;
        !          1274: typedef union
        !          1275: {      short is;
        !          1276:        char ic;
        !          1277:        long il;
        !          1278: } uint;
        !          1279: #define GET(x) if((x=(*getn)())<0) return(x)
        !          1280: #define VAL(x) (x!='\n'?x:' ')
        !          1281: #define PUT(x) (*putn)(x)
        !          1282: extern int cursor;
        !          1283: ./ ADD NAME=libI77/fmtlib.c TIME=628440563
        !          1284: /*     @(#)fmtlib.c    1.2     */
        !          1285: #define MAXINTLENGTH 23
        !          1286: char *icvt(value,ndigit,sign, base) long value; int *ndigit,*sign;
        !          1287: register int base;
        !          1288: {      static char buf[MAXINTLENGTH+1];
        !          1289:        register int i;
        !          1290:        if(value>0) *sign=0;
        !          1291:        else if(value<0)
        !          1292:        {       value = -value;
        !          1293:                *sign= 1;
        !          1294:        }
        !          1295:        else
        !          1296:        {       *sign=0;
        !          1297:                *ndigit=1;
        !          1298:                buf[MAXINTLENGTH]='0';
        !          1299:                return(&buf[MAXINTLENGTH]);
        !          1300:        }
        !          1301:        for(i=MAXINTLENGTH-1;value>0;i--)
        !          1302:        {       *(buf+i)=(int)(value%base)+'0';
        !          1303:                value /= base;
        !          1304:        }
        !          1305:        *ndigit=MAXINTLENGTH-1-i;
        !          1306:        return(&buf[i+1]);
        !          1307: }
        !          1308: ./ ADD NAME=libI77/fp.h TIME=580998005
        !          1309: #define FMAX 40
        !          1310: #define EXPMAXDIGS 8
        !          1311: #define EXPMAX 99999999
        !          1312: /* FMAX = max number of nonzero digits passed to atof() */
        !          1313: /* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */
        !          1314: 
        !          1315: #include "local.h"
        !          1316: 
        !          1317: /* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily
        !          1318:    tight) on the maximum number of digits to the right and left of
        !          1319:  * the decimal point.
        !          1320:  */
        !          1321: 
        !          1322: #ifdef VAX
        !          1323: #define MAXFRACDIGS 56
        !          1324: #define MAXINTDIGS 38
        !          1325: #else
        !          1326: #ifdef CRAY
        !          1327: #define MAXFRACDIGS 9880
        !          1328: #define MAXINTDIGS 9864
        !          1329: #else
        !          1330: /* values that suffice for IEEE double */
        !          1331: #define MAXFRACDIGS 344
        !          1332: #define MAXINTDIGS 308
        !          1333: #endif
        !          1334: #endif
        !          1335: ./ ADD NAME=libI77/iio.c TIME=629054420
        !          1336: #include "f2c.h"
        !          1337: #include "fio.h"
        !          1338: #include "fmt.h"
        !          1339: extern char *icptr;
        !          1340: char *icend;
        !          1341: extern icilist *svic;
        !          1342: extern int rd_ed(),rd_ned(),w_ed(),w_ned(),y_ierr();
        !          1343: extern int z_wnew();
        !          1344: int icnum;
        !          1345: extern int hiwater;
        !          1346: z_getc()
        !          1347: {
        !          1348:        if(icptr >= icend) err(svic->iciend,(EOF),"endfile");
        !          1349:        if(recpos++ < svic->icirlen)
        !          1350:                return(*icptr++);
        !          1351:        else    err(svic->icierr,110,"recend");
        !          1352: }
        !          1353: z_putc(c)
        !          1354: {
        !          1355:        if(icptr >= icend) err(svic->icierr,110,"inwrite");
        !          1356:        if(recpos++ < svic->icirlen)
        !          1357:                *icptr++ = c;
        !          1358:        else    err(svic->icierr,110,"recend");
        !          1359:        return 0;
        !          1360: }
        !          1361: z_rnew()
        !          1362: {
        !          1363:        icptr = svic->iciunit + (++icnum)*svic->icirlen;
        !          1364:        recpos = 0;
        !          1365:        cursor = 0;
        !          1366:        hiwater = 0;
        !          1367:        return 1;
        !          1368: }
        !          1369: integer s_rsfi(a) icilist *a;
        !          1370: {      int n;
        !          1371:        if(n=c_si(a)) return(n);
        !          1372:        reading=1;
        !          1373:        doed=rd_ed;
        !          1374:        doned=rd_ned;
        !          1375:        getn=z_getc;
        !          1376:        dorevert = y_ierr;
        !          1377:        donewrec = doend = z_rnew;
        !          1378:        return(0);
        !          1379: }
        !          1380: integer s_wsfi(a) icilist *a;
        !          1381: {      int n;
        !          1382:        if(n=c_si(a)) return(n);
        !          1383:        reading=0;
        !          1384:        doed=w_ed;
        !          1385:        doned=w_ned;
        !          1386:        putn=z_putc;
        !          1387:        dorevert = y_ierr;
        !          1388:        donewrec = doend = z_wnew;
        !          1389:        return(0);
        !          1390: }
        !          1391: c_si(a) icilist *a;
        !          1392: {
        !          1393:        fmtbuf=a->icifmt;
        !          1394:        if(pars_f(fmtbuf)<0)
        !          1395:                err(a->icierr,100,"startint");
        !          1396:        fmt_bg();
        !          1397:        sequential=formatted=1;
        !          1398:        external=0;
        !          1399:        cblank=cplus=scale=0;
        !          1400:        svic=a;
        !          1401:        icnum=recpos=0;
        !          1402:        cursor = 0;
        !          1403:        hiwater = 0;
        !          1404:        icptr=svic->iciunit;
        !          1405:        icend=icptr+svic->icirlen*svic->icirnum;
        !          1406:        return(0);
        !          1407: }
        !          1408: z_wnew()
        !          1409: {
        !          1410:        while(recpos++ < svic->icirlen)
        !          1411:                *icptr++ = ' ';
        !          1412:        recpos = 0;
        !          1413:        cursor = 0;
        !          1414:        hiwater = 0;
        !          1415:        icnum++;
        !          1416:        return 1;
        !          1417: }
        !          1418: integer e_rsfi()
        !          1419: {      int n;
        !          1420:        n = en_fio();
        !          1421:        fmtbuf = NULL;
        !          1422:        return(n);
        !          1423: }
        !          1424: integer e_wsfi()
        !          1425: {
        !          1426:        int n;
        !          1427:        n = en_fio();
        !          1428:        fmtbuf = NULL;
        !          1429:        if(icnum >= svic->icirnum)
        !          1430:                return(n);
        !          1431:        while(recpos++ < svic->icirlen)
        !          1432:                *icptr++ = ' ';
        !          1433:        return(n);
        !          1434: }
        !          1435: y_ierr()
        !          1436: {
        !          1437:        err(elist->cierr, 110, "iio");
        !          1438: }
        !          1439: ./ ADD NAME=libI77/inquire.c TIME=628440563
        !          1440: #include "f2c.h"
        !          1441: #include "fio.h"
        !          1442: integer f_inqu(a) inlist *a;
        !          1443: {      flag byfile;
        !          1444:        int i;
        !          1445:        unit *p;
        !          1446:        char buf[256];
        !          1447:        long x;
        !          1448:        if(a->infile!=NULL)
        !          1449:        {       byfile=1;
        !          1450:                g_char(a->infile,a->infilen,buf);
        !          1451:                x=inode(buf);
        !          1452:                for(i=0,p=NULL;i<MXUNIT;i++)
        !          1453:                        if(units[i].uinode==x && units[i].ufd!=NULL)
        !          1454:                                p = &units[i];
        !          1455:        }
        !          1456:        else
        !          1457:        {
        !          1458:                byfile=0;
        !          1459:                if(a->inunit<MXUNIT && a->inunit>=0)
        !          1460:                {
        !          1461:                        p= &units[a->inunit];
        !          1462:                }
        !          1463:                else
        !          1464:                {
        !          1465:                        p=NULL;
        !          1466:                }
        !          1467:        }
        !          1468:        if(a->inex!=NULL)
        !          1469:                if(byfile && x != -1 || !byfile && p!=NULL)
        !          1470:                        *a->inex=1;
        !          1471:                else *a->inex=0;
        !          1472:        if(a->inopen!=NULL)
        !          1473:                if(byfile) *a->inopen=(p!=NULL);
        !          1474:                else *a->inopen=(p!=NULL && p->ufd!=NULL);
        !          1475:        if(a->innum!=NULL) *a->innum= p-units;
        !          1476:        if(a->innamed!=NULL)
        !          1477:                if(byfile || p!=NULL && p->ufnm!=NULL)
        !          1478:                        *a->innamed=1;
        !          1479:                else    *a->innamed=0;
        !          1480:        if(a->inname!=NULL)
        !          1481:                if(byfile)
        !          1482:                        b_char(buf,a->inname,a->innamlen);
        !          1483:                else if(p!=NULL && p->ufnm!=NULL)
        !          1484:                        b_char(p->ufnm,a->inname,a->innamlen);
        !          1485:        if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL)
        !          1486:                if(p->url)
        !          1487:                        b_char("DIRECT",a->inacc,a->inacclen);
        !          1488:                else    b_char("SEQUENTIAL",a->inacc,a->inacclen);
        !          1489:        if(a->inseq!=NULL)
        !          1490:                if(p!=NULL && p->url)
        !          1491:                        b_char("NO",a->inseq,a->inseqlen);
        !          1492:                else    b_char("YES",a->inseq,a->inseqlen);
        !          1493:        if(a->indir!=NULL)
        !          1494:                if(p==NULL || p->url)
        !          1495:                        b_char("YES",a->indir,a->indirlen);
        !          1496:                else    b_char("NO",a->indir,a->indirlen);
        !          1497:        if(a->infmt!=NULL)
        !          1498:                if(p!=NULL && p->ufmt==0)
        !          1499:                        b_char("UNFORMATTED",a->infmt,a->infmtlen);
        !          1500:                else    b_char("FORMATTED",a->infmt,a->infmtlen);
        !          1501:        if(a->inform!=NULL)
        !          1502:                if(p!=NULL && p->ufmt==0)
        !          1503:                b_char("NO",a->inform,a->informlen);
        !          1504:                else b_char("YES",a->inform,a->informlen);
        !          1505:        if(a->inunf)
        !          1506:                if(p!=NULL && p->ufmt==0)
        !          1507:                        b_char("YES",a->inunf,a->inunflen);
        !          1508:                else if (p!=NULL) b_char("NO",a->inunf,a->inunflen);
        !          1509:                else b_char("UNKNOWN",a->inunf,a->inunflen);
        !          1510:        if(a->inrecl!=NULL && p!=NULL)
        !          1511:                *a->inrecl=p->url;
        !          1512:        if(a->innrec!=NULL && p!=NULL && p->url>0)
        !          1513:                *a->innrec=ftell(p->ufd)/p->url+1;
        !          1514:        if(a->inblank && p!=NULL && p->ufmt)
        !          1515:                if(p->ublnk)
        !          1516:                        b_char("ZERO",a->inblank,a->inblanklen);
        !          1517:                else    b_char("NULL",a->inblank,a->inblanklen);
        !          1518:        return(0);
        !          1519: }
        !          1520: ./ ADD NAME=libI77/lio.c TIME=628950337
        !          1521: #include "f2c.h"
        !          1522: #include "fio.h"
        !          1523: #include "fmt.h"
        !          1524: #include "lio.h"
        !          1525: extern int l_write();
        !          1526: int t_putc();
        !          1527: 
        !          1528: integer s_wsle(a) cilist *a;
        !          1529: {
        !          1530:        int n;
        !          1531:        if(!init) f_init();
        !          1532:        if(n=c_le(a)) return(n);
        !          1533:        reading=0;
        !          1534:        external=1;
        !          1535:        formatted=1;
        !          1536:        putn = t_putc;
        !          1537:        lioproc = l_write;
        !          1538:        if(curunit->uwrt != 1 && nowwriting(curunit))
        !          1539:                err(a->cierr, errno, "list output start");
        !          1540:        return(0);
        !          1541: }
        !          1542: integer e_wsle()
        !          1543: {
        !          1544:        t_putc('\n');
        !          1545:        recpos=0;
        !          1546:        if (cf == stdout)
        !          1547:                fflush(stdout);
        !          1548:        else if (cf == stderr)
        !          1549:                fflush(stderr);
        !          1550:        return(0);
        !          1551: }
        !          1552: t_putc(c)
        !          1553: {
        !          1554:        recpos++;
        !          1555:        putc(c,cf);
        !          1556:        return(0);
        !          1557: }
        !          1558: lwrt_I(n) ftnint n;
        !          1559: {
        !          1560:        char buf[LINTW],*p;
        !          1561:        (void) sprintf(buf," %ld",(long)n);
        !          1562:        if(recpos+strlen(buf)>=LINE)
        !          1563:        {       t_putc('\n');
        !          1564:                recpos=0;
        !          1565:        }
        !          1566:        for(p=buf;*p;t_putc(*p++));
        !          1567: }
        !          1568: lwrt_L(n, len) ftnint n; ftnlen len;
        !          1569: {
        !          1570:        if(recpos+LLOGW>=LINE)
        !          1571:        {       t_putc('\n');
        !          1572:                recpos=0;
        !          1573:        }
        !          1574:        (void) wrt_L((uint *)&n,LLOGW, len);
        !          1575: }
        !          1576: lwrt_A(p,len) char *p; ftnlen len;
        !          1577: {
        !          1578:        int i;
        !          1579:        if(recpos+len>=LINE)
        !          1580:        {
        !          1581:                t_putc('\n');
        !          1582:                recpos=0;
        !          1583:        }
        !          1584:        if (!recpos)
        !          1585:                { t_putc(' '); ++recpos; }
        !          1586:        for(i=0;i<len;i++) t_putc(*p++);
        !          1587: }
        !          1588: lwrt_F(absn) double absn;
        !          1589: {
        !          1590:        doublereal n;
        !          1591: 
        !          1592:        n = absn;
        !          1593:        if (absn < 0)
        !          1594:                absn = -absn;
        !          1595:        if (LLOW <= absn && absn < LHIGH)
        !          1596:        {
        !          1597:                if(recpos+LFW>=LINE)
        !          1598:                {
        !          1599:                        t_putc('\n');
        !          1600:                        recpos=0;
        !          1601:                }
        !          1602:                scale=0;
        !          1603:                (void) wrt_F((ufloat *)&n,LFW,LFD,(ftnlen)sizeof(n));
        !          1604:        }
        !          1605:        else
        !          1606:        {
        !          1607:                if(recpos+LEW>=LINE)
        !          1608:                {       t_putc('\n');
        !          1609:                        recpos=0;
        !          1610:                }
        !          1611:                scale = 1;
        !          1612:                (void) wrt_E((ufloat *)&n,LEW,LED,-1,(ftnlen)sizeof(n));
        !          1613:        }
        !          1614: }
        !          1615: lwrt_C(a,b) double a,b;
        !          1616: {
        !          1617:        if(recpos+2*LFW+3>=LINE)
        !          1618:        {       t_putc('\n');
        !          1619:                recpos=0;
        !          1620:        }
        !          1621:        t_putc(' ');
        !          1622:        t_putc('(');
        !          1623:        lwrt_F(a);
        !          1624:        t_putc(',');
        !          1625:        lwrt_F(b);
        !          1626:        t_putc(')');
        !          1627: }
        !          1628: l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
        !          1629: {
        !          1630: #define Ptr ((flex *)ptr)
        !          1631:        int i;
        !          1632:        ftnint x;
        !          1633:        double y,z;
        !          1634:        real *xx;
        !          1635:        doublereal *yy;
        !          1636:        for(i=0;i< *number; i++)
        !          1637:        {
        !          1638:                switch((int)type)
        !          1639:                {
        !          1640:                default: fatal(204,"unknown type in lio");
        !          1641:                case TYSHORT:
        !          1642:                        x=Ptr->flshort;
        !          1643:                        goto xint;
        !          1644:                case TYLONG:
        !          1645:                        x=Ptr->flint;
        !          1646:                xint:   lwrt_I(x);
        !          1647:                        break;
        !          1648:                case TYREAL:
        !          1649:                        y=Ptr->flreal;
        !          1650:                        goto xfloat;
        !          1651:                case TYDREAL:
        !          1652:                        y=Ptr->fldouble;
        !          1653:                xfloat: lwrt_F(y);
        !          1654:                        break;
        !          1655:                case TYCOMPLEX:
        !          1656:                        xx= &Ptr->flreal;
        !          1657:                        y = *xx++;
        !          1658:                        z = *xx;
        !          1659:                        goto xcomplex;
        !          1660:                case TYDCOMPLEX:
        !          1661:                        yy = &Ptr->fldouble;
        !          1662:                        y= *yy++;
        !          1663:                        z = *yy;
        !          1664:                xcomplex:
        !          1665:                        lwrt_C(y,z);
        !          1666:                        break;
        !          1667:                case TYLOGICAL:
        !          1668:                        lwrt_L(Ptr->flint, len);
        !          1669:                        break;
        !          1670:                case TYCHAR:
        !          1671:                        lwrt_A(ptr,len);
        !          1672:                        break;
        !          1673:                }
        !          1674:                ptr += len;
        !          1675:        }
        !          1676:        return(0);
        !          1677: }
        !          1678: ./ ADD NAME=libI77/lio.h TIME=628801084
        !          1679: /*     copy of ftypes from the compiler */
        !          1680: /* variable types
        !          1681:  * numeric assumptions:
        !          1682:  *     int < reals < complexes
        !          1683:  *     TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
        !          1684:  */
        !          1685: 
        !          1686: #define TYUNKNOWN 0
        !          1687: #define TYADDR 1
        !          1688: #define TYSHORT 2
        !          1689: #define TYLONG 3
        !          1690: #define TYREAL 4
        !          1691: #define TYDREAL 5
        !          1692: #define TYCOMPLEX 6
        !          1693: #define TYDCOMPLEX 7
        !          1694: #define TYLOGICAL 8
        !          1695: #define TYCHAR 9
        !          1696: #define TYSUBR 10
        !          1697: #define TYERROR 11
        !          1698: 
        !          1699: #define NTYPES (TYERROR+1)
        !          1700:  
        !          1701: #define        LINTW   12
        !          1702: #define        LINE    80
        !          1703: #define        LLOGW   2
        !          1704: #define        LLOW    1.0
        !          1705: #define        LHIGH   10.0
        !          1706: #define        LFW     12
        !          1707: #define        LFD     8
        !          1708: #define        LEW     16
        !          1709: #define        LED     8
        !          1710: 
        !          1711: typedef union
        !          1712: {      short   flshort;
        !          1713:        ftnint  flint;
        !          1714:        real    flreal;
        !          1715:        doublereal      fldouble;
        !          1716: } flex;
        !          1717: extern int scale;
        !          1718: extern int (*lioproc)();
        !          1719: ./ ADD NAME=libI77/lread.c TIME=628950338
        !          1720: #include "f2c.h"
        !          1721: #include "fio.h"
        !          1722: #include "fmt.h"
        !          1723: #include "lio.h"
        !          1724: #include "ctype.h"
        !          1725: #include "fp.h"
        !          1726: 
        !          1727: extern char *fmtbuf;
        !          1728: extern char *malloc(), *realloc();
        !          1729: int (*lioproc)();
        !          1730: 
        !          1731: #define isblnk(x) (ltab[x+1]&B)
        !          1732: #define issep(x) (ltab[x+1]&SX)
        !          1733: #define isapos(x) (ltab[x+1]&AX)
        !          1734: #define isexp(x) (ltab[x+1]&EX)
        !          1735: #define issign(x) (ltab[x+1]&SG)
        !          1736: #define SX 1
        !          1737: #define B 2
        !          1738: #define AX 4
        !          1739: #define EX 8
        !          1740: #define SG 16
        !          1741: char ltab[128+1] = {   /* offset one for EOF */
        !          1742:        0,
        !          1743:        0,0,AX,0,0,0,0,0,0,0,SX,0,0,0,0,0,
        !          1744:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
        !          1745:        SX|B,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
        !          1746:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
        !          1747:        0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
        !          1748:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
        !          1749:        AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
        !          1750:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
        !          1751: };
        !          1752: 
        !          1753: t_getc()
        !          1754: {      int ch;
        !          1755:        if(curunit->uend) return(EOF);
        !          1756:        if((ch=getc(cf))!=EOF) return(ch);
        !          1757:        if(feof(cf)) curunit->uend = 1;
        !          1758:        return(EOF);
        !          1759: }
        !          1760: integer e_rsle()
        !          1761: {
        !          1762:        int ch;
        !          1763:        if(curunit->uend) return(0);
        !          1764:        while((ch=t_getc())!='\n' && ch!=EOF);
        !          1765:        return(0);
        !          1766: }
        !          1767: 
        !          1768: flag lquit;
        !          1769: int lcount,ltype;
        !          1770: char *lchar;
        !          1771: double lx,ly;
        !          1772: #define ERR(x) if(n=(x)) return(n)
        !          1773: #define GETC(x) (x=t_getc())
        !          1774: 
        !          1775: l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
        !          1776: {
        !          1777: #define Ptr ((flex *)ptr)
        !          1778:        int i,n,ch;
        !          1779:        doublereal *yy;
        !          1780:        real *xx;
        !          1781:        for(i=0;i<*number;i++)
        !          1782:        {
        !          1783:                if(lquit) return(0);
        !          1784:                if(curunit->uend) err(elist->ciend, EOF, "list in")
        !          1785:                if(lcount == 0) {
        !          1786:                        ltype = 0;
        !          1787:                        for(;;)  {
        !          1788:                                GETC(ch);
        !          1789:                                switch(ch) {
        !          1790:                                case EOF:
        !          1791:                                        goto loopend;
        !          1792:                                case ' ':
        !          1793:                                case '\n':
        !          1794:                                        continue;
        !          1795:                                case '/':
        !          1796:                                        lquit = 1;
        !          1797:                                        goto loopend;
        !          1798:                                case ',':
        !          1799:                                        lcount = 1;
        !          1800:                                        goto loopend;
        !          1801:                                default:
        !          1802:                                        (void) ungetc(ch, cf);
        !          1803:                                        goto rddata;
        !          1804:                                }
        !          1805:                        }
        !          1806:                }
        !          1807:        rddata:
        !          1808:                switch((int)type)
        !          1809:                {
        !          1810:                case TYSHORT:
        !          1811:                case TYLONG:
        !          1812:                case TYREAL:
        !          1813:                case TYDREAL:
        !          1814:                        ERR(l_R());
        !          1815:                        break;
        !          1816:                case TYCOMPLEX:
        !          1817:                case TYDCOMPLEX:
        !          1818:                        ERR(l_C());
        !          1819:                        break;
        !          1820:                case TYLOGICAL:
        !          1821:                        ERR(l_L());
        !          1822:                        break;
        !          1823:                case TYCHAR:
        !          1824:                        ERR(l_CHAR());
        !          1825:                        break;
        !          1826:                }
        !          1827:        while ((ch=t_getc())==' '); if (ch!=',') ungetc(ch,cf);
        !          1828:        loopend:
        !          1829:                if(lquit) return(0);
        !          1830:                if(feof(cf)) err(elist->ciend,(EOF),"list in")
        !          1831:                else if(ferror(cf))
        !          1832:                {       clearerr(cf);
        !          1833:                        err(elist->cierr,errno,"list in")
        !          1834:                }
        !          1835:                if(ltype==0) goto bump;
        !          1836:                switch((int)type)
        !          1837:                {
        !          1838:                case TYSHORT:
        !          1839:                        Ptr->flshort=lx;
        !          1840:                        break;
        !          1841:                case TYLOGICAL:
        !          1842:                case TYLONG:
        !          1843:                        Ptr->flint=lx;
        !          1844:                        break;
        !          1845:                case TYREAL:
        !          1846:                        Ptr->flreal=lx;
        !          1847:                        break;
        !          1848:                case TYDREAL:
        !          1849:                        Ptr->fldouble=lx;
        !          1850:                        break;
        !          1851:                case TYCOMPLEX:
        !          1852:                        xx=(real *)ptr;
        !          1853:                        *xx++ = lx;
        !          1854:                        *xx = ly;
        !          1855:                        break;
        !          1856:                case TYDCOMPLEX:
        !          1857:                        yy=(doublereal *)ptr;
        !          1858:                        *yy++ = lx;
        !          1859:                        *yy = ly;
        !          1860:                        break;
        !          1861:                case TYCHAR:
        !          1862:                        b_char(lchar,ptr,len);
        !          1863:                        break;
        !          1864:                }
        !          1865:        bump:
        !          1866:                if(lcount>0) lcount--;
        !          1867:                ptr += len;
        !          1868:        }
        !          1869:        return(0);
        !          1870: #undef Ptr
        !          1871: }
        !          1872: l_R()
        !          1873: {
        !          1874:        char s[FMAX+EXPMAXDIGS+4];
        !          1875:        register int ch;
        !          1876:        register char *sp, *spe, *sp1;
        !          1877:        long e, exp;
        !          1878:        double atof();
        !          1879:        int havenum, poststar, se;
        !          1880: 
        !          1881:        if (lcount > 0)
        !          1882:                return(0);
        !          1883:        ltype = 0;
        !          1884:        lcount = 1;
        !          1885:        exp = 0;
        !          1886:        poststar = 0;
        !          1887: retry:
        !          1888:        sp1 = sp = s;
        !          1889:        spe = sp + FMAX;
        !          1890:        havenum = 0;
        !          1891: 
        !          1892:        switch(GETC(ch)) {
        !          1893:                case '-': *sp++ = ch; sp1++; spe++;
        !          1894:                case '+':
        !          1895:                        GETC(ch);
        !          1896:                }
        !          1897:        while(ch == '0') {
        !          1898:                ++havenum;
        !          1899:                GETC(ch);
        !          1900:                }
        !          1901:        while(isdigit(ch)) {
        !          1902:                if (sp < spe) *sp++ = ch;
        !          1903:                else ++exp;
        !          1904:                GETC(ch);
        !          1905:                }
        !          1906:        if (ch == '*' && !poststar) {
        !          1907:                if (sp == sp1 || exp || *s == '-') {
        !          1908:                        err(elist->cierr,112,"bad repetition count")
        !          1909:                        }
        !          1910:                poststar = 1;
        !          1911:                *sp = 0;
        !          1912:                lcount = atoi(s);
        !          1913:                goto retry;
        !          1914:                }
        !          1915:        if (ch == '.') {
        !          1916:                GETC(ch);
        !          1917:                if (sp == sp1)
        !          1918:                        while(ch == '0') {
        !          1919:                                ++havenum;
        !          1920:                                --exp;
        !          1921:                                GETC(ch);
        !          1922:                                }
        !          1923:                while(isdigit(ch)) {
        !          1924:                        if (sp < spe)
        !          1925:                                { *sp++ = ch; --exp; }
        !          1926:                        GETC(ch);
        !          1927:                        }
        !          1928:                }
        !          1929:        se = 0;
        !          1930:        if (issign(ch)) 
        !          1931:                goto signonly;
        !          1932:        if (isexp(ch)) {
        !          1933:                GETC(ch);
        !          1934:                if (issign(ch)) {
        !          1935: signonly:
        !          1936:                        if (ch == '-') se = 1;
        !          1937:                        GETC(ch);
        !          1938:                        }
        !          1939:                if (!isdigit(ch)) {
        !          1940: bad:
        !          1941:                        err(elist->cierr,112,"exponent field")
        !          1942:                        }
        !          1943:                
        !          1944:                e = ch - '0';
        !          1945:                while(isdigit(GETC(ch))) {
        !          1946:                        e = 10*e + ch - '0';
        !          1947:                        if (e > EXPMAX)
        !          1948:                                goto bad;
        !          1949:                        }
        !          1950:                if (se)
        !          1951:                        exp -= e;
        !          1952:                else
        !          1953:                        exp += e;
        !          1954:                }
        !          1955:        (void) ungetc(ch, cf);
        !          1956:        if (sp > sp1) {
        !          1957:                ++havenum;
        !          1958:                while(*--sp == '0')
        !          1959:                        ++exp;
        !          1960:                if (exp)
        !          1961:                        sprintf(sp+1, "e%ld", exp);
        !          1962:                else
        !          1963:                        sp[1] = 0;
        !          1964:                lx = atof(s);
        !          1965:                }
        !          1966:        else
        !          1967:                lx = 0.;
        !          1968:        if (havenum)
        !          1969:                ltype = TYLONG;
        !          1970:        else
        !          1971:                switch(ch) {
        !          1972:                        case ',':
        !          1973:                        case '/':
        !          1974:                                break;
        !          1975:                        default:
        !          1976:                                err(elist->cierr,112,"invalid number")
        !          1977:                        }
        !          1978:        return 0;
        !          1979:        }
        !          1980: 
        !          1981: l_C()
        !          1982: {      int ch;
        !          1983:        if(lcount>0) return(0);
        !          1984:        ltype=0;
        !          1985:        GETC(ch);
        !          1986:        if(ch!='(')
        !          1987:        {
        !          1988:                (void) ungetc(ch,cf);
        !          1989:                if(fscanf(cf,"%d",&lcount)!=1)
        !          1990:                        if(!feof(cf)) err(elist->cierr,112,"complex format")
        !          1991:                        else err(elist->cierr,(EOF),"lread");
        !          1992:                if(GETC(ch)!='*')
        !          1993:                {
        !          1994:                        if(!feof(cf)) err(elist->cierr,112,"no star")
        !          1995:                        else err(elist->cierr,(EOF),"lread");
        !          1996:                }
        !          1997:                if(GETC(ch)!='(')
        !          1998:                {       (void) ungetc(ch,cf);
        !          1999:                        return(0);
        !          2000:                }
        !          2001:        }
        !          2002:        lcount = 1;
        !          2003:        ltype=TYLONG;
        !          2004:        (void) fscanf(cf,"%lf",&lx);
        !          2005:        while(isblnk(GETC(ch)) || (ch == '\n'));
        !          2006:        if(ch!=',')
        !          2007:        {       (void) ungetc(ch,cf);
        !          2008:                err(elist->cierr,112,"no comma");
        !          2009:        }
        !          2010:        while(isblnk(GETC(ch)));
        !          2011:        (void) ungetc(ch,cf);
        !          2012:        (void) fscanf(cf,"%lf",&ly);
        !          2013:        while(isblnk(GETC(ch)));
        !          2014:        if(ch!=')') err(elist->cierr,112,"no )");
        !          2015:        return(0);
        !          2016: }
        !          2017: l_L()
        !          2018: {
        !          2019:        int ch;
        !          2020:        if(lcount>0) return(0);
        !          2021:        ltype=0;
        !          2022:        GETC(ch);
        !          2023:        if(isdigit(ch))
        !          2024:        {       (void) ungetc(ch,cf);
        !          2025:                (void) fscanf(cf,"%d",&lcount);
        !          2026:                if(GETC(ch)!='*')
        !          2027:                        if(!feof(cf)) err(elist->cierr,112,"no star")
        !          2028:                        else err(elist->cierr,(EOF),"lread");
        !          2029:        }
        !          2030:        else    (void) ungetc(ch,cf);
        !          2031:        if(GETC(ch)=='.') GETC(ch);
        !          2032:        switch(ch)
        !          2033:        {
        !          2034:        case 't':
        !          2035:        case 'T':
        !          2036:                lx=1;
        !          2037:                break;
        !          2038:        case 'f':
        !          2039:        case 'F':
        !          2040:                lx=0;
        !          2041:                break;
        !          2042:        default:
        !          2043:                if(isblnk(ch) || issep(ch) || ch==EOF)
        !          2044:                {       (void) ungetc(ch,cf);
        !          2045:                        return(0);
        !          2046:                }
        !          2047:                else    err(elist->cierr,112,"logical");
        !          2048:        }
        !          2049:        ltype=TYLONG;
        !          2050:        lcount = 1;
        !          2051:        while(!issep(GETC(ch)) && ch!=EOF);
        !          2052:        (void) ungetc(ch, cf);
        !          2053:        return(0);
        !          2054: }
        !          2055: #define BUFSIZE        128
        !          2056: l_CHAR()
        !          2057: {      int ch,size,i;
        !          2058:        char quote,*p;
        !          2059:        if(lcount>0) return(0);
        !          2060:        ltype=0;
        !          2061: 
        !          2062:        GETC(ch);
        !          2063:        if(isdigit(ch))
        !          2064:        {       (void) ungetc(ch,cf);
        !          2065:                (void) fscanf(cf,"%d",&lcount);
        !          2066:                if(GETC(ch)!='*') err(elist->cierr,112,"no star");
        !          2067:        }
        !          2068:        else    (void) ungetc(ch,cf);
        !          2069:        if(GETC(ch)=='\'' || ch=='"') quote=ch;
        !          2070:        else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
        !          2071:        {       (void) ungetc(ch,cf);
        !          2072:                return(0);
        !          2073:        }
        !          2074:        else err(elist->cierr,112,"no quote");
        !          2075:        ltype=TYCHAR;
        !          2076:        if(lchar!=NULL) free(lchar);
        !          2077:        size=BUFSIZE;
        !          2078:        p=lchar=malloc((unsigned int)size);
        !          2079:        if(lchar==NULL) err(elist->cierr,113,"no space");
        !          2080:        for(i=0;;)
        !          2081:        {       while(GETC(ch)!=quote && ch!='\n'
        !          2082:                        && ch!=EOF && ++i<size) *p++ = ch;
        !          2083:                if(i==size)
        !          2084:                {
        !          2085:                newone:
        !          2086:                        lchar= realloc(lchar, (unsigned int)(size += BUFSIZE));
        !          2087:                        p=lchar+i-1;
        !          2088:                        *p++ = ch;
        !          2089:                }
        !          2090:                else if(ch==EOF) return(EOF);
        !          2091:                else if(ch=='\n')
        !          2092:                {       if(*(p-1) != '\\') continue;
        !          2093:                        i--;
        !          2094:                        p--;
        !          2095:                        if(++i<size) *p++ = ch;
        !          2096:                        else goto newone;
        !          2097:                }
        !          2098:                else if(GETC(ch)==quote)
        !          2099:                {       if(++i<size) *p++ = ch;
        !          2100:                        else goto newone;
        !          2101:                }
        !          2102:                else
        !          2103:                {       (void) ungetc(ch,cf);
        !          2104:                        *p = 0;
        !          2105:                        return(0);
        !          2106:                }
        !          2107:        }
        !          2108: }
        !          2109: integer s_rsle(a) cilist *a;
        !          2110: {
        !          2111:        int n;
        !          2112:        if(!init) f_init();
        !          2113:        if(n=c_le(a)) return(n);
        !          2114:        reading=1;
        !          2115:        external=1;
        !          2116:        formatted=1;
        !          2117:        lioproc = l_read;
        !          2118:        lquit = 0;
        !          2119:        lcount = 0;
        !          2120:        if(curunit->uwrt && nowreading(curunit))
        !          2121:                err(a->cierr,errno,"read start");
        !          2122:        return(0);
        !          2123: }
        !          2124: c_le(a) cilist *a;
        !          2125: {
        !          2126:        fmtbuf="list io";
        !          2127:        if(a->ciunit>=MXUNIT || a->ciunit<0)
        !          2128:                err(a->cierr,101,"stler");
        !          2129:        scale=recpos=0;
        !          2130:        elist=a;
        !          2131:        curunit = &units[a->ciunit];
        !          2132:        if(curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
        !          2133:                err(a->cierr,102,"lio");
        !          2134:        cf=curunit->ufd;
        !          2135:        if(!curunit->ufmt) err(a->cierr,103,"lio")
        !          2136:        return(0);
        !          2137: }
        !          2138: integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len;
        !          2139: {
        !          2140:        return((*lioproc)(number,ptr,len,*type));
        !          2141: }
        !          2142: ./ ADD NAME=libI77/open.c TIME=628440564
        !          2143: #include       "sys/types.h"
        !          2144: #include       "sys/stat.h"
        !          2145: #include "f2c.h"
        !          2146: #include "fio.h"
        !          2147: extern char *mktemp(), *malloc(), *strcpy();
        !          2148: extern FILE *fdopen();
        !          2149: extern integer f_clos();
        !          2150: 
        !          2151: integer f_open(a) olist *a;
        !          2152: {      unit *b;
        !          2153:        int n;
        !          2154:        char buf[256];
        !          2155:        cllist x;
        !          2156:        if(a->ounit>=MXUNIT || a->ounit<0)
        !          2157:                err(a->oerr,101,"open")
        !          2158:        curunit = b = &units[a->ounit];
        !          2159:        if(b->ufd) {
        !          2160:                if(a->ofnm==0)
        !          2161:                {
        !          2162:                same:   if(a->oblnk!= 0) b->ublnk= *a->oblnk== 'z'?1:0;
        !          2163:                        return(0);
        !          2164:                }
        !          2165:                g_char(a->ofnm,a->ofnmlen,buf);
        !          2166:                if(inode(buf)==b->uinode) goto same;
        !          2167:                x.cunit=a->ounit;
        !          2168:                x.csta=0;
        !          2169:                x.cerr=a->oerr;
        !          2170:                if((n=f_clos(&x))!=0) return(n);
        !          2171:                }
        !          2172:        b->url=a->orl;
        !          2173:        if(a->oblnk && (*a->oblnk=='z' || *a->oblnk == 'Z')) b->ublnk=1;
        !          2174:        else b->ublnk=0;
        !          2175:        if(a->ofm==0)
        !          2176:        {       if(b->url>0) b->ufmt=0;
        !          2177:                else b->ufmt=1;
        !          2178:        }
        !          2179:        else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1;
        !          2180:        else b->ufmt=0;
        !          2181:        if (a->ofnm) {
        !          2182:                g_char(a->ofnm,a->ofnmlen,buf);
        !          2183:                if (!buf[0])
        !          2184:                        err(a->oerr,107,"open")
        !          2185:                }
        !          2186:        else
        !          2187:                sprintf(buf, "fort.%ld", a->ounit);
        !          2188:        b->uscrtch = 0;
        !          2189:        switch(a->osta ? *a->osta : 'u')
        !          2190:        {
        !          2191:        case 'o':
        !          2192:        case 'O':
        !          2193:                if(!a->ofnm) err(a->oerr,107,"open")
        !          2194:                if(access(buf,0))
        !          2195:                        err(a->oerr,errno,"open")
        !          2196:                break;
        !          2197:         case 's':
        !          2198:         case 'S':
        !          2199:                b->uscrtch=1;
        !          2200:                (void) strcpy(buf,"tmp.FXXXXXX");
        !          2201:                (void) mktemp(buf);
        !          2202:                (void) close(creat(buf, 0666));
        !          2203:                break;
        !          2204:        case 'n':
        !          2205:        case 'N':
        !          2206:                if(a->ofnm==0) err(a->oerr,107,"open")
        !          2207:                (void) close(creat(buf, 0666));
        !          2208:                break;
        !          2209:        }
        !          2210: done:
        !          2211:        b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1));
        !          2212:        if(b->ufnm==NULL) err(a->oerr,113,"no space");
        !          2213:        (void) strcpy(b->ufnm,buf);
        !          2214:        b->uend=0;
        !          2215:        if(isdev(buf))
        !          2216:        {       b->ufd = fopen(buf,"r");
        !          2217:                if(b->ufd==NULL) err(a->oerr,errno,buf)
        !          2218:                else    b->uwrt = 0;
        !          2219:        }
        !          2220:        else {
        !          2221:                b->uwrt = 0;
        !          2222:                if((b->ufd = fopen(buf, "r")) == NULL) {
        !          2223:                        if ((n = open(buf,1)) >= 0) {
        !          2224:                                b->uwrt = 2;
        !          2225:                                }
        !          2226:                        else {
        !          2227:                                n = creat(buf, 0666);
        !          2228:                                b->uwrt = 1;
        !          2229:                                }
        !          2230:                        if (n < 0
        !          2231:                        || (b->ufd = fdopen(n, "w")) == NULL)
        !          2232:                                err(a->oerr, errno, "open");
        !          2233:                        }
        !          2234:                if(b->url > 0)  /* one can more easily find the end */
        !          2235:                        (void) fseek(b->ufd, 0L, 0);
        !          2236:        }
        !          2237:        b->useek=canseek(b->ufd);
        !          2238:        if((b->uinode=inode(buf))==-1)
        !          2239:                err(a->oerr,108,"open")
        !          2240:        if(a->orl && b->useek) rewind(b->ufd);
        !          2241:        return(0);
        !          2242: }
        !          2243: fk_open(seq,fmt,n) ftnint n;
        !          2244: {      char nbuf[10];
        !          2245:        olist a;
        !          2246:        (void) sprintf(nbuf,"fort.%ld",n);
        !          2247:        a.oerr=1;
        !          2248:        a.ounit=n;
        !          2249:        a.ofnm=nbuf;
        !          2250:        a.ofnmlen=strlen(nbuf);
        !          2251:        a.osta=NULL;
        !          2252:        a.oacc= seq==SEQ?"s":"d";
        !          2253:        a.ofm = fmt==FMT?"f":"u";
        !          2254:        a.orl = seq==DIR?1:0;
        !          2255:        a.oblnk=NULL;
        !          2256:        return(f_open(&a));
        !          2257: }
        !          2258: isdev(s) char *s;
        !          2259: {      struct stat x;
        !          2260:        int j;
        !          2261:        if(stat(s, &x) == -1) return(0);
        !          2262:        if((j = (x.st_mode&S_IFMT)) == S_IFREG || j == S_IFDIR) return(0);
        !          2263:        else    return(1);
        !          2264: }
        !          2265: ./ ADD NAME=libI77/rdfmt.c TIME=629051101
        !          2266: #include "f2c.h"
        !          2267: #include "fio.h"
        !          2268: #include "fmt.h"
        !          2269: #include "fp.h"
        !          2270: 
        !          2271: extern int cursor;
        !          2272: rd_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
        !          2273: {      int ch;
        !          2274:        for(;cursor>0;cursor--) if((ch=(*getn)())<0) return(ch);
        !          2275:        if(cursor<0)
        !          2276:        {       if(recpos+cursor < 0) /*err(elist->cierr,110,"fmt")*/
        !          2277:                        cursor = -recpos;       /* is this in the standard? */
        !          2278:                if(external == 0) {
        !          2279:                        extern char *icptr;
        !          2280:                        icptr += cursor;
        !          2281:                }
        !          2282:                else if(curunit->useek) (void) fseek(cf,(long) cursor,1);
        !          2283:                else err(elist->cierr,106,"fmt");
        !          2284:                recpos += cursor;
        !          2285:                cursor=0;
        !          2286:        }
        !          2287:        switch(p->op)
        !          2288:        {
        !          2289:        default: fprintf(stderr,"rd_ed, unexpected code: %d\n%s\n",
        !          2290:                        p->op,fmtbuf);
        !          2291:                abort();
        !          2292:        case I: ch = (rd_I((uint *)ptr,p->p1,len, 10));
        !          2293:                break;
        !          2294:        case IM: ch = (rd_I((uint *)ptr,p->p1,len, 10));
        !          2295:                break;
        !          2296:        case O: ch = (rd_I((uint *)ptr, p->p1, len, 8));
        !          2297:                break;
        !          2298:        case L: ch = (rd_L((ftnint *)ptr,p->p1));
        !          2299:                break;
        !          2300:        case A: ch = (rd_A(ptr,len));
        !          2301:                break;
        !          2302:        case AW:
        !          2303:                ch = (rd_AW(ptr,p->p1,len));
        !          2304:                break;
        !          2305:        case E: case EE:
        !          2306:        case D:
        !          2307:        case G:
        !          2308:        case GE:
        !          2309:        case F: ch = (rd_F((ufloat *)ptr,p->p1,p->p2,len));
        !          2310:                break;
        !          2311:        }
        !          2312:        if(ch == 0) return(ch);
        !          2313:        else if(ch == EOF) return(EOF);
        !          2314:        clearerr(cf);
        !          2315:        return(errno);
        !          2316: }
        !          2317: rd_ned(p) struct syl *p;
        !          2318: {
        !          2319:        switch(p->op)
        !          2320:        {
        !          2321:        default: fprintf(stderr,"rd_ned, unexpected code: %d\n%s\n",
        !          2322:                        p->op,fmtbuf);
        !          2323:                abort();
        !          2324:        case APOS:
        !          2325:                return(rd_POS(*(char **)&p->p2));
        !          2326:        case H: return(rd_H(p->p1,*(char **)&p->p2));
        !          2327:        case SLASH: return((*donewrec)());
        !          2328:        case TR:
        !          2329:        case X: cursor += p->p1;
        !          2330:                return(1);
        !          2331:        case T: cursor=p->p1-recpos - 1;
        !          2332:                return(1);
        !          2333:        case TL: cursor -= p->p1;
        !          2334:                if(cursor < -recpos)    /* TL1000, 1X */
        !          2335:                        cursor = -recpos;
        !          2336:                return(1);
        !          2337:        }
        !          2338: }
        !          2339: rd_I(n,w,len, base) ftnlen len; uint *n; register int base;
        !          2340: {      long x;
        !          2341:        int sign,ch;
        !          2342:        char s[84], *ps;
        !          2343:        ps=s; x=0;
        !          2344:        while (w)
        !          2345:        {
        !          2346:                GET(ch);
        !          2347:                if (ch==',' || ch=='\n') break;
        !          2348:                *ps=ch; ps++; w--;
        !          2349:        }
        !          2350:        *ps='\0';
        !          2351:        ps=s;
        !          2352:        while (*ps==' ') ps++;
        !          2353:        if (*ps=='-') { sign=1; ps++; }
        !          2354:        else { sign=0; if (*ps=='+') ps++; }
        !          2355: loop:  while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
        !          2356:        if (*ps==' ') {if (cblank) x *= base; ps++; goto loop;}
        !          2357:        if(sign) x = -x;
        !          2358:        if(len==sizeof(integer)) n->il=x;
        !          2359:        else if(len == sizeof(char)) n->ic = x;
        !          2360:        else n->is=x;
        !          2361:        if (*ps) return(errno=115); else return(0);
        !          2362: }
        !          2363: rd_L(n,w) ftnint *n;
        !          2364: {      int ch;
        !          2365:        char s[84], *ps;
        !          2366:        ps=s;
        !          2367:        while (w) {
        !          2368:                GET(ch);
        !          2369:                if (ch==','||ch=='\n') break;
        !          2370:                *ps=ch;
        !          2371:                ps++; w--;
        !          2372:                }
        !          2373:        *ps='\0';
        !          2374:        ps=s; while (*ps==' ') ps++;
        !          2375:        if (*ps=='.') ps++;
        !          2376:        if (*ps=='t' || *ps == 'T') { *n=1; return(0); }
        !          2377:        else if (*ps='f' || *ps == 'F') { *n=0; return(0); }
        !          2378:        else return(errno=116);
        !          2379: }
        !          2380: 
        !          2381: #include "ctype.h"
        !          2382: 
        !          2383: rd_F(p, w, d, len) 
        !          2384: ftnlen len; 
        !          2385: ufloat *p;
        !          2386: {
        !          2387:        char s[FMAX+EXPMAXDIGS+4];
        !          2388:        register int ch;
        !          2389:        register char *sp, *spe, *sp1;
        !          2390:        double atof(), x;
        !          2391:        int scale1, se;
        !          2392:        long e, exp;
        !          2393: 
        !          2394:        sp1 = sp = s;
        !          2395:        spe = sp + FMAX;
        !          2396:        exp = -d;
        !          2397:        x = 0.;
        !          2398: 
        !          2399:        do {
        !          2400:                GET(ch); 
        !          2401:                w--;
        !          2402:                } while (ch == ' ' && w);
        !          2403:        switch(ch) {
        !          2404:                case '-': *sp++ = ch; sp1++; spe++;
        !          2405:                case '+':
        !          2406:                        if (!w) goto zero;
        !          2407:                        --w;
        !          2408:                        GET(ch);
        !          2409:                }
        !          2410:        while(ch == ' ') {
        !          2411: blankdrop:
        !          2412:                if (!w--) goto zero; GET(ch); }
        !          2413:        while(ch == '0')
        !          2414:                { if (!w--) goto zero; GET(ch); }
        !          2415:        if (ch == ' ' && cblank)
        !          2416:                goto blankdrop;
        !          2417:        scale1 = scale;
        !          2418:        while(isdigit(ch)) {
        !          2419: digloop1:
        !          2420:                if (sp < spe) *sp++ = ch;
        !          2421:                else ++exp;
        !          2422: digloop1e:
        !          2423:                if (!w--) goto done;
        !          2424:                GET(ch);
        !          2425:                }
        !          2426:        if (ch == ' ') {
        !          2427:                if (cblank)
        !          2428:                        { ch = '0'; goto digloop1; }
        !          2429:                goto digloop1e;
        !          2430:                }
        !          2431:        if (ch == '.') {
        !          2432:                exp += d;
        !          2433:                if (!w--) goto done;
        !          2434:                GET(ch);
        !          2435:                if (sp == sp1) { /* no digits yet */
        !          2436:                        while(ch == '0') {
        !          2437: skip01:
        !          2438:                                --exp;
        !          2439: skip0:
        !          2440:                                if (!w--) goto done;
        !          2441:                                GET(ch);
        !          2442:                                }
        !          2443:                        if (ch == ' ') {
        !          2444:                                if (cblank) goto skip01;
        !          2445:                                goto skip0;
        !          2446:                                }
        !          2447:                        }
        !          2448:                while(isdigit(ch)) {
        !          2449: digloop2:
        !          2450:                        if (sp < spe)
        !          2451:                                { *sp++ = ch; --exp; }
        !          2452: digloop2e:
        !          2453:                        if (!w--) goto done;
        !          2454:                        GET(ch);
        !          2455:                        }
        !          2456:                if (ch == ' ') {
        !          2457:                        if (cblank)
        !          2458:                                { ch = '0'; goto digloop2; }
        !          2459:                        goto digloop2e;
        !          2460:                        }
        !          2461:                }
        !          2462:        switch(ch) {
        !          2463:          default:
        !          2464:                break;
        !          2465:          case '-': se = 1; goto signonly;
        !          2466:          case '+': se = 0; goto signonly;
        !          2467:          case 'e':
        !          2468:          case 'E':
        !          2469:          case 'd':
        !          2470:          case 'D':
        !          2471:                if (!w--)
        !          2472:                        goto bad;
        !          2473:                GET(ch);
        !          2474:                while(ch == ' ') {
        !          2475:                        if (!w--)
        !          2476:                                goto bad;
        !          2477:                        GET(ch);
        !          2478:                        }
        !          2479:                se = 0;
        !          2480:                switch(ch) {
        !          2481:                  case '-': se = 1;
        !          2482:                  case '+':
        !          2483: signonly:
        !          2484:                        if (!w--)
        !          2485:                                goto bad;
        !          2486:                        GET(ch);
        !          2487:                        }
        !          2488:                while(ch == ' ') {
        !          2489:                        if (!w--)
        !          2490:                                goto bad;
        !          2491:                        GET(ch);
        !          2492:                        }
        !          2493:                if (!isdigit(ch))
        !          2494:                        goto bad;
        !          2495:                
        !          2496:                e = ch - '0';
        !          2497:                for(;;) {
        !          2498:                        if (!w--)
        !          2499:                                { ch = '\n'; break; }
        !          2500:                        GET(ch);
        !          2501:                        if (!isdigit(ch)) {
        !          2502:                                if (ch == ' ') {
        !          2503:                                        if (cblank)
        !          2504:                                                ch = '0';
        !          2505:                                        else continue;
        !          2506:                                        }
        !          2507:                                else
        !          2508:                                        break;
        !          2509:                                }
        !          2510:                        e = 10*e + ch - '0';
        !          2511:                        if (e > EXPMAX && sp > sp1)
        !          2512:                                goto bad;
        !          2513:                        }
        !          2514:                if (se)
        !          2515:                        exp -= e;
        !          2516:                else
        !          2517:                        exp += e;
        !          2518:                scale1 = 0;
        !          2519:                }
        !          2520:        switch(ch) {
        !          2521:          case '\n':
        !          2522:          case ',':
        !          2523:                break;
        !          2524:          default:
        !          2525: bad:
        !          2526:                return (errno = 115);
        !          2527:                }
        !          2528: done:
        !          2529:        if (sp > sp1) {
        !          2530:                while(*--sp == '0')
        !          2531:                        ++exp;
        !          2532:                if (exp -= scale1)
        !          2533:                        sprintf(sp+1, "e%ld", exp);
        !          2534:                else
        !          2535:                        sp[1] = 0;
        !          2536:                x = atof(s);
        !          2537:                }
        !          2538: zero:  
        !          2539:        if (len == sizeof(real)) 
        !          2540:                p->pf = x; 
        !          2541:        else 
        !          2542:                p->pd = x;
        !          2543:        return(0);
        !          2544:        }
        !          2545: 
        !          2546: 
        !          2547: rd_A(p,len) char *p; ftnlen len;
        !          2548: {      int i,ch;
        !          2549:        for(i=0;i<len;i++)
        !          2550:        {       GET(ch);
        !          2551:                *p++=VAL(ch);
        !          2552:        }
        !          2553:        return(0);
        !          2554: }
        !          2555: rd_AW(p,w,len) char *p; ftnlen len;
        !          2556: {      int i,ch;
        !          2557:        if(w>=len)
        !          2558:        {       for(i=0;i<w-len;i++)
        !          2559:                        GET(ch);
        !          2560:                for(i=0;i<len;i++)
        !          2561:                {       GET(ch);
        !          2562:                        *p++=VAL(ch);
        !          2563:                }
        !          2564:                return(0);
        !          2565:        }
        !          2566:        for(i=0;i<w;i++)
        !          2567:        {       GET(ch);
        !          2568:                *p++=VAL(ch);
        !          2569:        }
        !          2570:        for(i=0;i<len-w;i++) *p++=' ';
        !          2571:        return(0);
        !          2572: }
        !          2573: rd_H(n,s) char *s;
        !          2574: {      int i,ch;
        !          2575:        for(i=0;i<n;i++)
        !          2576:                if((ch=(*getn)())<0) return(ch);
        !          2577:                else *s++ = ch=='\n'?' ':ch;
        !          2578:        return(1);
        !          2579: }
        !          2580: rd_POS(s) char *s;
        !          2581: {      char quote;
        !          2582:        int ch;
        !          2583:        quote= *s++;
        !          2584:        for(;*s;s++)
        !          2585:                if(*s==quote && *(s+1)!=quote) break;
        !          2586:                else if((ch=(*getn)())<0) return(ch);
        !          2587:                else *s = ch=='\n'?' ':ch;
        !          2588:        return(1);
        !          2589: }
        !          2590: ./ ADD NAME=libI77/rewind.c TIME=628440564
        !          2591: #include "f2c.h"
        !          2592: #include "fio.h"
        !          2593: integer f_rew(a) alist *a;
        !          2594: {
        !          2595:        unit *b;
        !          2596:        if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"rewind");
        !          2597:        b = &units[a->aunit];
        !          2598:        if(b->ufd == NULL) return(0);
        !          2599:        if(!b->useek) err(a->aerr,106,"rewind")
        !          2600:        if(b->uwrt) {
        !          2601:                (void) t_runc(a);
        !          2602:                b->uwrt = 3;
        !          2603:                }
        !          2604:        rewind(b->ufd);
        !          2605:        b->uend=0;
        !          2606:        return(0);
        !          2607: }
        !          2608: ./ ADD NAME=libI77/rsfe.c TIME=628440564
        !          2609: /* read sequential formatted external */
        !          2610: #include "f2c.h"
        !          2611: #include "fio.h"
        !          2612: #include "fmt.h"
        !          2613: extern int x_getc(),rd_ed(),rd_ned();
        !          2614: extern int x_endp(),x_rev(),xrd_SL();
        !          2615: integer s_rsfe(a) cilist *a; /* start */
        !          2616: {      int n;
        !          2617:        if(!init) f_init();
        !          2618:        if(n=c_sfe(a)) return(n);
        !          2619:        reading=1;
        !          2620:        sequential=1;
        !          2621:        formatted=1;
        !          2622:        external=1;
        !          2623:        elist=a;
        !          2624:        cursor=recpos=0;
        !          2625:        scale=0;
        !          2626:        fmtbuf=a->cifmt;
        !          2627:        curunit= &units[a->ciunit];
        !          2628:        cf=curunit->ufd;
        !          2629:        if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio");
        !          2630:        getn= x_getc;
        !          2631:        doed= rd_ed;
        !          2632:        doned= rd_ned;
        !          2633:        fmt_bg();
        !          2634:        doend=x_endp;
        !          2635:        donewrec=xrd_SL;
        !          2636:        dorevert=x_rev;
        !          2637:        cblank=curunit->ublnk;
        !          2638:        cplus=0;
        !          2639:        if(curunit->uwrt && nowreading(curunit))
        !          2640:                err(a->cierr,errno,"read start");
        !          2641:        return(0);
        !          2642: }
        !          2643: xrd_SL()
        !          2644: {      int ch;
        !          2645:        if(!curunit->uend)
        !          2646:                while((ch=getc(cf))!='\n' && ch!=EOF);
        !          2647:        cursor=recpos=0;
        !          2648:        return(1);
        !          2649: }
        !          2650: x_getc()
        !          2651: {      int ch;
        !          2652:        if(curunit->uend) return(EOF);
        !          2653:        ch = getc(cf);
        !          2654:        if(ch!=EOF && ch!='\n')
        !          2655:        {       recpos++;
        !          2656:                return(ch);
        !          2657:        }
        !          2658:        if(ch=='\n')
        !          2659:        {       (void) ungetc(ch,cf);
        !          2660:                return(ch);
        !          2661:        }
        !          2662:        if(curunit->uend || feof(cf))
        !          2663:        {       errno=0;
        !          2664:                curunit->uend=1;
        !          2665:                return(-1);
        !          2666:        }
        !          2667:        return(-1);
        !          2668: }
        !          2669: x_endp()
        !          2670: {
        !          2671:        (void) xrd_SL();
        !          2672:        return(0);
        !          2673: }
        !          2674: x_rev()
        !          2675: {
        !          2676:        (void) xrd_SL();
        !          2677:        return(0);
        !          2678: }
        !          2679: ./ ADD NAME=libI77/sfe.c TIME=628440564
        !          2680: /* sequential formatted external common routines*/
        !          2681: #include "f2c.h"
        !          2682: #include "fio.h"
        !          2683: 
        !          2684: extern char *fmtbuf;
        !          2685: 
        !          2686: integer e_rsfe()
        !          2687: {      int n;
        !          2688:        n=en_fio();
        !          2689:        if (cf == stdout)
        !          2690:                fflush(stdout);
        !          2691:        else if (cf == stderr)
        !          2692:                fflush(stderr);
        !          2693:        fmtbuf=NULL;
        !          2694:        return(n);
        !          2695: }
        !          2696: c_sfe(a) cilist *a; /* check */
        !          2697: {      unit *p;
        !          2698:        if(a->ciunit >= MXUNIT || a->ciunit<0)
        !          2699:                err(a->cierr,101,"startio");
        !          2700:        p = &units[a->ciunit];
        !          2701:        if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe")
        !          2702:        if(!p->ufmt) err(a->cierr,102,"sfe")
        !          2703:        return(0);
        !          2704: }
        !          2705: integer e_wsfe()
        !          2706: {      return(e_rsfe());
        !          2707: }
        !          2708: ./ ADD NAME=libI77/sue.c TIME=628440564
        !          2709: #include "f2c.h"
        !          2710: #include "fio.h"
        !          2711: extern int reclen;
        !          2712: long recloc;
        !          2713: 
        !          2714: integer s_rsue(a) cilist *a;
        !          2715: {
        !          2716:        int n;
        !          2717:        if(!init) f_init();
        !          2718:        reading=1;
        !          2719:        if(n=c_sue(a)) return(n);
        !          2720:        recpos=0;
        !          2721:        if(curunit->uwrt && nowreading(curunit))
        !          2722:                err(a->cierr, errno, "read start");
        !          2723:        if(fread((char *)&reclen,sizeof(int),1,cf)
        !          2724:                != 1)
        !          2725:        {       if(feof(cf))
        !          2726:                {       curunit->uend = 1;
        !          2727:                        err(a->ciend, EOF, "start");
        !          2728:                }
        !          2729:                clearerr(cf);
        !          2730:                err(a->cierr, errno, "start");
        !          2731:        }
        !          2732:        return(0);
        !          2733: }
        !          2734: integer s_wsue(a) cilist *a;
        !          2735: {
        !          2736:        int n;
        !          2737:        if(!init) f_init();
        !          2738:        if(n=c_sue(a)) return(n);
        !          2739:        reading=0;
        !          2740:        reclen=0;
        !          2741:        if(curunit->uwrt != 1 && nowwriting(curunit))
        !          2742:                err(a->cierr, errno, "write start");
        !          2743:        recloc=ftell(cf);
        !          2744:        (void) fseek(cf,(long)sizeof(int),1);
        !          2745:        return(0);
        !          2746: }
        !          2747: c_sue(a) cilist *a;
        !          2748: {
        !          2749:        if(a->ciunit >= MXUNIT || a->ciunit < 0)
        !          2750:                err(a->cierr,101,"startio");
        !          2751:        external=sequential=1;
        !          2752:        formatted=0;
        !          2753:        curunit = &units[a->ciunit];
        !          2754:        elist=a;
        !          2755:        if(curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit))
        !          2756:                err(a->cierr,114,"sue");
        !          2757:        cf=curunit->ufd;
        !          2758:        if(curunit->ufmt) err(a->cierr,103,"sue")
        !          2759:        if(!curunit->useek) err(a->cierr,103,"sue")
        !          2760:        return(0);
        !          2761: }
        !          2762: integer e_wsue()
        !          2763: {      long loc;
        !          2764:        (void) fwrite((char *)&reclen,sizeof(int),1,cf);
        !          2765:        loc=ftell(cf);
        !          2766:        (void) fseek(cf,recloc,0);
        !          2767:        (void) fwrite((char *)&reclen,sizeof(int),1,cf);
        !          2768:        (void) fseek(cf,loc,0);
        !          2769:        return(0);
        !          2770: }
        !          2771: integer e_rsue()
        !          2772: {
        !          2773:        (void) fseek(cf,(long)(reclen-recpos+sizeof(int)),1);
        !          2774:        return(0);
        !          2775: }
        !          2776: ./ ADD NAME=libI77/uio.c TIME=628440564
        !          2777: #include "f2c.h"
        !          2778: #include "fio.h"
        !          2779: int reclen;
        !          2780: do_us(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
        !          2781: {
        !          2782:        if(reading)
        !          2783:        {
        !          2784:                recpos += *number * len;
        !          2785:                if(recpos>reclen)
        !          2786:                {
        !          2787:                        err(elist->ciend,(-1), "eof/uio");
        !          2788:                }
        !          2789:                (void) fread(ptr,(int)len,(int)(*number),cf);
        !          2790:                return(0);
        !          2791:        }
        !          2792:        else
        !          2793:        {
        !          2794:                reclen += *number * len;
        !          2795:                (void) fwrite(ptr,(int)len,(int)(*number),cf);
        !          2796:                return(0);
        !          2797:        }
        !          2798: }
        !          2799: integer do_uio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
        !          2800: {
        !          2801:        if(sequential)
        !          2802:                return(do_us(number,ptr,len));
        !          2803:        else    return(do_ud(number,ptr,len));
        !          2804: }
        !          2805: do_ud(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
        !          2806: {
        !          2807:        recpos += *number * len;
        !          2808:        if(recpos > curunit->url && curunit->url!=1)
        !          2809:                err(elist->cierr,110,"eof/uio");
        !          2810:        if(reading)
        !          2811:        {
        !          2812:                if(fread(ptr,(int)len,(int)(*number),cf)
        !          2813:                        != *number)
        !          2814:                        err(elist->cierr,27,"eof/uio")
        !          2815:                else return(0);
        !          2816:        }
        !          2817:        (void) fwrite(ptr,(int)len,(int)(*number),cf);
        !          2818:        return(0);
        !          2819: }
        !          2820: ./ ADD NAME=libI77/util.c TIME=628473389
        !          2821: #include "sys/types.h"
        !          2822: #include "sys/stat.h"
        !          2823: #include "f2c.h"
        !          2824: #include "fio.h"
        !          2825: 
        !          2826: g_char(a,alen,b) char *a,*b; ftnlen alen;
        !          2827: {      char *x=a+alen-1,*y=b+alen-1;
        !          2828:        *(y+1)=0;
        !          2829:        for(;x>=a && *x==' ';x--) *y--=0;
        !          2830:        for(;x>=a;*y--= *x--);
        !          2831: }
        !          2832: b_char(a,b,blen) char *a,*b; ftnlen blen;
        !          2833: {      int i;
        !          2834:        for(i=0;i<blen && *a!=0;i++) *b++= *a++;
        !          2835:        for(;i<blen;i++) *b++=' ';
        !          2836: }
        !          2837: inode(a) char *a;
        !          2838: {      struct stat x;
        !          2839:        if(stat(a,&x)<0) return(-1);
        !          2840:        return(x.st_ino);
        !          2841: }
        !          2842: #define DONE {*bufpos++=0; (void) close(file); return;}
        !          2843: #define INTBOUND sizeof(int)-1
        !          2844: mvgbt(n,len,a,b) char *a,*b;
        !          2845: {      register int num=n*len;
        !          2846:        if( ((int)a&INTBOUND)==0 && ((int)b&INTBOUND)==0 && (num&INTBOUND)==0 )
        !          2847:        {       register int *x=(int *)a,*y=(int *)b;
        !          2848:                num /= sizeof(int);
        !          2849:                if(x>y) for(;num>0;num--) *y++= *x++;
        !          2850:                else for(num--;num>=0;num--) *(y+num)= *(x+num);
        !          2851:        }
        !          2852:        else
        !          2853:        {       register char *x=a,*y=b;
        !          2854:                if(x>y) for(;num>0;num--) *y++= *x++;
        !          2855:                else for(num--;num>=0;num--) *(y+num)= *(x+num);
        !          2856:        }
        !          2857: }
        !          2858: ./ ADD NAME=libI77/wref.c TIME=628965453
        !          2859: #include "f2c.h"
        !          2860: #include "fio.h"
        !          2861: #include "fmt.h"
        !          2862: #include "fp.h"
        !          2863: #ifndef VAX
        !          2864: #include "ctype.h"
        !          2865: #endif
        !          2866: 
        !          2867: wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
        !          2868: {
        !          2869:        char buf[FMAX+EXPMAXDIGS+4], *s, *se;
        !          2870:        int d1, delta, e1, i, sign, signspace;
        !          2871:        double dd;
        !          2872: #ifndef VAX
        !          2873:        int e0 = e;
        !          2874: #endif
        !          2875: 
        !          2876:        if(e <= 0)
        !          2877:                e = 2;
        !          2878:        if(scale) {
        !          2879:                if(scale >= d + 2 || scale <= -d)
        !          2880:                        goto nogood;
        !          2881:                }
        !          2882:        if(scale <= 0)
        !          2883:                --d;
        !          2884:        if (len == sizeof(real))
        !          2885:                dd = p->pf;
        !          2886:        else
        !          2887:                dd = p->pd;
        !          2888:        if (dd >= 0.) {
        !          2889:                sign = 0;
        !          2890:                signspace = cplus;
        !          2891: #ifndef VAX
        !          2892:                if (!dd)
        !          2893:                        dd = 0.;        /* avoid -0 */
        !          2894: #endif
        !          2895:                }
        !          2896:        else {
        !          2897:                signspace = sign = 1;
        !          2898:                dd = -dd;
        !          2899:                }
        !          2900:        delta = w - (2 /* for the . and the d adjustment above */
        !          2901:                        + 2 /* for the E+ */ + signspace + d + e);
        !          2902:        if (delta < 0) {
        !          2903: nogood:
        !          2904:                while(--w >= 0)
        !          2905:                        PUT('*');
        !          2906:                return(0);
        !          2907:                }
        !          2908:        if (scale < 0)
        !          2909:                d += scale;
        !          2910:        if (d > FMAX) {
        !          2911:                d1 = d - FMAX;
        !          2912:                d = FMAX;
        !          2913:                }
        !          2914:        else
        !          2915:                d1 = 0;
        !          2916:        sprintf(buf,"%#.*E", d, dd);
        !          2917: #ifndef VAX
        !          2918:        /* check for NaN, Infinity */
        !          2919:        if (!isdigit(buf[0])) {
        !          2920:                delta = w - strlen(buf) - signspace;
        !          2921:                if (delta < 0)
        !          2922:                        goto nogood;
        !          2923:                while(--delta >= 0)
        !          2924:                        PUT(' ');
        !          2925:                if (signspace)
        !          2926:                        PUT(sign ? '-' : '+');
        !          2927:                for(s = buf; *s; s++)
        !          2928:                        PUT(*s);
        !          2929:                return 0;
        !          2930:                }
        !          2931: #endif
        !          2932:        se = buf + d + 3;
        !          2933:        if (scale != 1 && dd)
        !          2934:                sprintf(se, "%+.2d", atoi(se) + 1 - scale);
        !          2935:        s = ++se;
        !          2936:        if (e < 2) {
        !          2937:                if (*s != '0')
        !          2938:                        goto nogood;
        !          2939:                }
        !          2940: #ifndef VAX
        !          2941:        /* accommodate 3 significant digits in exponent */
        !          2942:        if (s[2]) {
        !          2943: #ifdef Pedantic
        !          2944:                if (!e0 && !s[3])
        !          2945:                        for(s -= 2, e1 = 2; s[0] = s[1]; s++);
        !          2946:                        
        !          2947:        /* Pedantic gives the behavior that Fortran 77 specifies,       */
        !          2948:        /* i.e., requires that E be specified for exponent fields       */
        !          2949:        /* of more than 3 digits.  With Pedantic undefined, we get      */
        !          2950:        /* the behavior that Cray displays -- you get a bigger          */
        !          2951:        /* exponent field if it fits.   */
        !          2952: #else
        !          2953:                if (!e0) {
        !          2954:                        for(s -= 2, e1 = 2; s[0] = s[1]; s++)
        !          2955: #ifdef CRAY
        !          2956:                                delta--;
        !          2957:                        if ((delta += 4) < 0)
        !          2958:                                goto nogood
        !          2959: #endif
        !          2960:                                ;
        !          2961:                        }
        !          2962: #endif
        !          2963:                else if (e0 >= 0)
        !          2964:                        goto shift;
        !          2965:                else
        !          2966:                        e1 = e;
        !          2967:                }
        !          2968:        else
        !          2969:  shift:        
        !          2970: #endif
        !          2971:                for(s += 2, e1 = 2; *s; ++e1, ++s)
        !          2972:                        if (e1 >= e)
        !          2973:                                goto nogood;
        !          2974:        while(--delta >= 0)
        !          2975:                PUT(' ');
        !          2976:        if (signspace)
        !          2977:                PUT(sign ? '-' : '+');
        !          2978:        s = buf;
        !          2979:        i = scale;
        !          2980:        if (scale <= 0) {
        !          2981:                PUT('.');
        !          2982:                for(; i < 0; ++i)
        !          2983:                        PUT('0');
        !          2984:                PUT(*s);
        !          2985:                s += 2;
        !          2986:                }
        !          2987:        else if (scale > 1) {
        !          2988:                PUT(*s);
        !          2989:                s += 2;
        !          2990:                while(--i > 0)
        !          2991:                        PUT(*s++);
        !          2992:                PUT('.');
        !          2993:                }
        !          2994:        if (d1) {
        !          2995:                se -= 2;
        !          2996:                while(s < se) PUT(*s++);
        !          2997:                se += 2;
        !          2998:                do PUT('0'); while(--d1 > 0);
        !          2999:                }
        !          3000:        while(s < se)
        !          3001:                PUT(*s++);
        !          3002:        if (e < 2)
        !          3003:                PUT(s[1]);
        !          3004:        else {
        !          3005:                while(++e1 <= e)
        !          3006:                        PUT('0');
        !          3007:                while(*s)
        !          3008:                        PUT(*s++);
        !          3009:                }
        !          3010:        return 0;
        !          3011:        }
        !          3012: 
        !          3013: wrt_F(p,w,d,len) ufloat *p; ftnlen len;
        !          3014: {
        !          3015:        int d1, sign, n;
        !          3016:        double x;
        !          3017:        char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
        !          3018: 
        !          3019:        x= (len==sizeof(real)?p->pf:p->pd);
        !          3020:        if (d < MAXFRACDIGS)
        !          3021:                d1 = 0;
        !          3022:        else {
        !          3023:                d1 = d - MAXFRACDIGS;
        !          3024:                d = MAXFRACDIGS;
        !          3025:                }
        !          3026:        if (x < 0.)
        !          3027:                { x = -x; sign = 1; }
        !          3028:        else {
        !          3029:                sign = 0;
        !          3030: #ifndef VAX
        !          3031:                if (!x)
        !          3032:                        x = 0.;
        !          3033: #endif
        !          3034:                }
        !          3035: 
        !          3036:        if (n = scale)
        !          3037:                if (n > 0)
        !          3038:                        do x *= 10.; while(--n > 0);
        !          3039:                else
        !          3040:                        do x *= 0.1; while(++n < 0);
        !          3041: 
        !          3042: #ifdef USE_STRLEN
        !          3043:        sprintf(b = buf, "%#.*f", d, x);
        !          3044:        n = strlen(b) + d1;
        !          3045: #else
        !          3046:        n = sprintf(b = buf, "%#.*f", d, x) + d1;
        !          3047: #endif
        !          3048:        
        !          3049:        if (buf[0] == '0' && d)
        !          3050:                { ++b; --n; }
        !          3051:        if (sign) {
        !          3052:                /* check for all zeros */
        !          3053:                for(s = b;;) {
        !          3054:                        while(*s == '0') s++;
        !          3055:                        switch(*s) {
        !          3056:                                case '.':
        !          3057:                                        s++; continue;
        !          3058:                                case 0:
        !          3059:                                        sign = 0;
        !          3060:                                }
        !          3061:                        break;
        !          3062:                        }
        !          3063:                }
        !          3064:        if (sign || cplus)
        !          3065:                ++n;
        !          3066:        if (n > w) {
        !          3067:                while(--w >= 0)
        !          3068:                        PUT('*');
        !          3069:                return 0;
        !          3070:                }
        !          3071:        for(w -= n; --w >= 0; )
        !          3072:                PUT(' ');
        !          3073:        if (sign)
        !          3074:                PUT('-');
        !          3075:        else if (cplus)
        !          3076:                PUT('+');
        !          3077:        while(n = *b++)
        !          3078:                PUT(n);
        !          3079:        while(--d1 >= 0)
        !          3080:                PUT('0');
        !          3081:        return 0;
        !          3082:        }
        !          3083: ./ ADD NAME=libI77/wrtfmt.c TIME=629040813
        !          3084: #include "f2c.h"
        !          3085: #include "fio.h"
        !          3086: #include "fmt.h"
        !          3087: extern int cursor;
        !          3088: extern char *icvt(), *ecvt();
        !          3089: int hiwater;
        !          3090: icilist *svic;
        !          3091: char *icptr;
        !          3092: mv_cur()       /* shouldn't use fseek because it insists on calling fflush */
        !          3093:                /* instead we know too much about stdio */
        !          3094: {
        !          3095:        if(external == 0) {
        !          3096:                if(cursor < 0) {
        !          3097:                        if(hiwater < recpos)
        !          3098:                                hiwater = recpos;
        !          3099:                        recpos += cursor;
        !          3100:                        icptr += cursor;
        !          3101:                        cursor = 0;
        !          3102:                        if(recpos < 0)
        !          3103:                                err(elist->cierr, 110, "left off");
        !          3104:                }
        !          3105:                else if(cursor > 0) {
        !          3106:                        if(recpos + cursor >= svic->icirlen)
        !          3107:                                err(elist->cierr, 110, "recend");
        !          3108:                        if(hiwater <= recpos)
        !          3109:                                for(; cursor > 0; cursor--)
        !          3110:                                        (*putn)(' ');
        !          3111:                        else if(hiwater <= recpos + cursor) {
        !          3112:                                cursor -= hiwater - recpos;
        !          3113:                                icptr += hiwater - recpos;
        !          3114:                                recpos = hiwater;
        !          3115:                                for(; cursor > 0; cursor--)
        !          3116:                                        (*putn)(' ');
        !          3117:                        }
        !          3118:                        else {
        !          3119:                                icptr += cursor;
        !          3120:                                recpos += cursor;
        !          3121:                        }
        !          3122:                        cursor = 0;
        !          3123:                }
        !          3124:                return(0);
        !          3125:        }
        !          3126:        if(cursor > 0) {
        !          3127:                if(hiwater <= recpos)
        !          3128:                        for(;cursor>0;cursor--) (*putn)(' ');
        !          3129:                else if(hiwater <= recpos + cursor) {
        !          3130: #ifndef NON_UNIX_STDIO
        !          3131:                        if(cf->_ptr + hiwater - recpos < buf_end(cf))
        !          3132:                                cf->_ptr += hiwater - recpos;
        !          3133:                        else
        !          3134: #endif
        !          3135:                                (void) fseek(cf, (long) (hiwater - recpos), 1);
        !          3136:                        cursor -= hiwater - recpos;
        !          3137:                        recpos = hiwater;
        !          3138:                        for(; cursor > 0; cursor--)
        !          3139:                                (*putn)(' ');
        !          3140:                }
        !          3141:                else {
        !          3142: #ifndef NON_UNIX_STDIO
        !          3143:                        if(cf->_ptr + cursor < buf_end(cf))
        !          3144:                                cf->_ptr += cursor;
        !          3145:                        else
        !          3146: #endif
        !          3147:                                (void) fseek(cf, (long)cursor, 1);
        !          3148:                        recpos += cursor;
        !          3149:                }
        !          3150:        }
        !          3151:        if(cursor<0)
        !          3152:        {
        !          3153:                if(cursor+recpos<0) err(elist->cierr,110,"left off");
        !          3154: #ifndef NON_UNIX_STDIO
        !          3155:                if(cf->_ptr + cursor >= cf->_base)
        !          3156:                        cf->_ptr += cursor;
        !          3157:                else
        !          3158: #endif
        !          3159:                     if(curunit->useek) (void) fseek(cf,(long)cursor,1);
        !          3160:                else err(elist->cierr,106,"fmt");
        !          3161:                if(hiwater < recpos)
        !          3162:                        hiwater = recpos;
        !          3163:                recpos += cursor;
        !          3164:                cursor=0;
        !          3165:        }
        !          3166:        return(0);
        !          3167: }
        !          3168: w_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
        !          3169: {
        !          3170:        if(cursor && mv_cur()) return(mv_cur());
        !          3171:        switch(p->op)
        !          3172:        {
        !          3173:        default:
        !          3174:                fprintf(stderr,"w_ed, unexpected code: %d\n%s\n",
        !          3175:                        p->op,fmtbuf);
        !          3176:                abort();
        !          3177:        case I: return(wrt_I((uint *)ptr,p->p1,len, 10));
        !          3178:        case IM:
        !          3179:                return(wrt_IM((uint *)ptr,p->p1,p->p2,len));
        !          3180:        case O: return(wrt_I((uint *)ptr, p->p1, len, 8));
        !          3181:        case L: return(wrt_L((uint *)ptr,p->p1, len));
        !          3182:        case A: return(wrt_A(ptr,len));
        !          3183:        case AW:
        !          3184:                return(wrt_AW(ptr,p->p1,len));
        !          3185:        case D:
        !          3186:        case E:
        !          3187:        case EE:
        !          3188:                return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len));
        !          3189:        case G:
        !          3190:        case GE:
        !          3191:                return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len));
        !          3192:        case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len));
        !          3193:        }
        !          3194: }
        !          3195: w_ned(p) struct syl *p;
        !          3196: {
        !          3197:        switch(p->op)
        !          3198:        {
        !          3199:        default: fprintf(stderr,"w_ned, unexpected code: %d\n%s\n",
        !          3200:                        p->op,fmtbuf);
        !          3201:                abort();
        !          3202:        case SLASH:
        !          3203:                return((*donewrec)());
        !          3204:        case T: cursor = p->p1-recpos - 1;
        !          3205:                return(1);
        !          3206:        case TL: cursor -= p->p1;
        !          3207:                if(cursor < -recpos)    /* TL1000, 1X */
        !          3208:                        cursor = -recpos;
        !          3209:                return(1);
        !          3210:        case TR:
        !          3211:        case X:
        !          3212:                cursor += p->p1;
        !          3213:                return(1);
        !          3214:        case APOS:
        !          3215:                return(wrt_AP(*(char **)&p->p2));
        !          3216:        case H:
        !          3217:                return(wrt_H(p->p1,*(char **)&p->p2));
        !          3218:        }
        !          3219: }
        !          3220: wrt_I(n,w,len, base) uint *n; ftnlen len; register int base;
        !          3221: {      int ndigit,sign,spare,i;
        !          3222:        long x;
        !          3223:        char *ans;
        !          3224:        if(len==sizeof(integer)) x=n->il;
        !          3225:        else if(len == sizeof(char)) x = n->ic;
        !          3226:        else x=n->is;
        !          3227:        ans=icvt(x,&ndigit,&sign, base);
        !          3228:        spare=w-ndigit;
        !          3229:        if(sign || cplus) spare--;
        !          3230:        if(spare<0)
        !          3231:                for(i=0;i<w;i++) (*putn)('*');
        !          3232:        else
        !          3233:        {       for(i=0;i<spare;i++) (*putn)(' ');
        !          3234:                if(sign) (*putn)('-');
        !          3235:                else if(cplus) (*putn)('+');
        !          3236:                for(i=0;i<ndigit;i++) (*putn)(*ans++);
        !          3237:        }
        !          3238:        return(0);
        !          3239: }
        !          3240: wrt_IM(n,w,m,len) uint *n; ftnlen len;
        !          3241: {      int ndigit,sign,spare,i,xsign;
        !          3242:        long x;
        !          3243:        char *ans;
        !          3244:        if(sizeof(integer)==len) x=n->il;
        !          3245:        else if(len == sizeof(char)) x = n->ic;
        !          3246:        else x=n->is;
        !          3247:        ans=icvt(x,&ndigit,&sign, 10);
        !          3248:        if(sign || cplus) xsign=1;
        !          3249:        else xsign=0;
        !          3250:        if(ndigit+xsign>w || m+xsign>w)
        !          3251:        {       for(i=0;i<w;i++) (*putn)('*');
        !          3252:                return(0);
        !          3253:        }
        !          3254:        if(x==0 && m==0)
        !          3255:        {       for(i=0;i<w;i++) (*putn)(' ');
        !          3256:                return(0);
        !          3257:        }
        !          3258:        if(ndigit>=m)
        !          3259:                spare=w-ndigit-xsign;
        !          3260:        else
        !          3261:                spare=w-m-xsign;
        !          3262:        for(i=0;i<spare;i++) (*putn)(' ');
        !          3263:        if(sign) (*putn)('-');
        !          3264:        else if(cplus) (*putn)('+');
        !          3265:        for(i=0;i<m-ndigit;i++) (*putn)('0');
        !          3266:        for(i=0;i<ndigit;i++) (*putn)(*ans++);
        !          3267:        return(0);
        !          3268: }
        !          3269: wrt_AP(s)
        !          3270:  char *s;
        !          3271: {      char quote;
        !          3272:        if(cursor && mv_cur()) return(mv_cur());
        !          3273:        quote = *s++;
        !          3274:        for(;*s;s++)
        !          3275:        {       if(*s!=quote) (*putn)(*s);
        !          3276:                else if(*++s==quote) (*putn)(*s);
        !          3277:                else return(1);
        !          3278:        }
        !          3279:        return(1);
        !          3280: }
        !          3281: wrt_H(a,s)
        !          3282:  char *s;
        !          3283: {
        !          3284:        if(cursor && mv_cur()) return(mv_cur());
        !          3285:        while(a--) (*putn)(*s++);
        !          3286:        return(1);
        !          3287: }
        !          3288: wrt_L(n,len, sz) uint *n; ftnlen sz;
        !          3289: {      int i;
        !          3290:        long x;
        !          3291:        if(sizeof(integer)==sz) x=n->il;
        !          3292:        else if(sz == sizeof(char)) x = n->ic;
        !          3293:        else x=n->is;
        !          3294:        for(i=0;i<len-1;i++)
        !          3295:                (*putn)(' ');
        !          3296:        if(x) (*putn)('T');
        !          3297:        else (*putn)('F');
        !          3298:        return(0);
        !          3299: }
        !          3300: wrt_A(p,len) char *p; ftnlen len;
        !          3301: {
        !          3302:        while(len-- > 0) (*putn)(*p++);
        !          3303:        return(0);
        !          3304: }
        !          3305: wrt_AW(p,w,len) char * p; ftnlen len;
        !          3306: {
        !          3307:        while(w>len)
        !          3308:        {       w--;
        !          3309:                (*putn)(' ');
        !          3310:        }
        !          3311:        while(w-- > 0)
        !          3312:                (*putn)(*p++);
        !          3313:        return(0);
        !          3314: }
        !          3315: 
        !          3316: wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
        !          3317: {      double up = 1,x;
        !          3318:        int i,oldscale=scale,n,j;
        !          3319:        x= len==sizeof(real)?p->pf:p->pd;
        !          3320:        if(x < 0 ) x = -x;
        !          3321:        if(x<.1) return(wrt_E(p,w,d,e,len));
        !          3322:        for(i=0;i<=d;i++,up*=10)
        !          3323:        {       if(x>=up) continue;
        !          3324:                scale=0;
        !          3325:                if(e==0) n=4;
        !          3326:                else    n=e+2;
        !          3327:                i=wrt_F(p,w-n,d-i,len);
        !          3328:                for(j=0;j<n;j++) (*putn)(' ');
        !          3329:                scale=oldscale;
        !          3330:                return(i);
        !          3331:        }
        !          3332:        return(wrt_E(p,w,d,e,len));
        !          3333: }
        !          3334: ./ ADD NAME=libI77/wsfe.c TIME=628440564
        !          3335: /*write sequential formatted external*/
        !          3336: #include "f2c.h"
        !          3337: #include "fio.h"
        !          3338: #include "fmt.h"
        !          3339: extern int x_putc(),w_ed(),w_ned();
        !          3340: extern int xw_end(),xw_rev(),x_wSL();
        !          3341: extern int hiwater;
        !          3342: integer s_wsfe(a) cilist *a;   /*start*/
        !          3343: {      int n;
        !          3344:        if(!init) f_init();
        !          3345:        if(n=c_sfe(a)) return(n);
        !          3346:        reading=0;
        !          3347:        sequential=1;
        !          3348:        formatted=1;
        !          3349:        external=1;
        !          3350:        elist=a;
        !          3351:        hiwater = cursor=recpos=0;
        !          3352:        nonl = 0;
        !          3353:        scale=0;
        !          3354:        fmtbuf=a->cifmt;
        !          3355:        curunit = &units[a->ciunit];
        !          3356:        cf=curunit->ufd;
        !          3357:        if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio");
        !          3358:        putn= x_putc;
        !          3359:        doed= w_ed;
        !          3360:        doned= w_ned;
        !          3361:        doend=xw_end;
        !          3362:        dorevert=xw_rev;
        !          3363:        donewrec=x_wSL;
        !          3364:        fmt_bg();
        !          3365:        cplus=0;
        !          3366:        cblank=curunit->ublnk;
        !          3367:        if(curunit->uwrt != 1 && nowwriting(curunit))
        !          3368:                err(a->cierr,errno,"write start");
        !          3369:        return(0);
        !          3370: }
        !          3371: x_putc(c)
        !          3372: {
        !          3373:        /* this uses \n as an indicator of record-end */
        !          3374:        if(c == '\n' && recpos < hiwater) {     /* fseek calls fflush, a loss */
        !          3375: #ifndef NON_UNIX_STDIO
        !          3376:                if(cf->_ptr + hiwater - recpos < buf_end(cf))
        !          3377:                        cf->_ptr += hiwater - recpos;
        !          3378:                else
        !          3379: #endif
        !          3380:                        (void) fseek(cf, (long)(hiwater - recpos), 1);
        !          3381:        }
        !          3382:        putc(c,cf);
        !          3383:        recpos++;
        !          3384: }
        !          3385: pr_put(c)
        !          3386: {      static flag new = 1;
        !          3387:        recpos++;
        !          3388:        if(c=='\n')
        !          3389:        {       new=1;
        !          3390:                putc(c,cf);
        !          3391:        }
        !          3392:        else if(new==1)
        !          3393:        {       new=0;
        !          3394:                if(c=='0') putc('\n',cf);
        !          3395:                else if(c=='1') putc('\f',cf);
        !          3396:        }
        !          3397:        else putc(c,cf);
        !          3398: }
        !          3399: x_wSL()
        !          3400: {
        !          3401:        (*putn)('\n');
        !          3402:        recpos=0;
        !          3403:        cursor = 0;
        !          3404:        hiwater = 0;
        !          3405:        return(1);
        !          3406: }
        !          3407: xw_end()
        !          3408: {
        !          3409:        if(nonl == 0)
        !          3410:                (*putn)('\n');
        !          3411:        hiwater = recpos = cursor = 0;
        !          3412:        return(0);
        !          3413: }
        !          3414: xw_rev()
        !          3415: {
        !          3416:        if(workdone) (*putn)('\n');
        !          3417:        hiwater = recpos = cursor = 0;
        !          3418:        return(workdone=0);
        !          3419: }
        !          3420: ./ ADD NAME=libI77/namelist.c TIME=628989101
        !          3421: #include "f2c.h"
        !          3422: #include "fio.h"
        !          3423: 
        !          3424: s_rsne(a)
        !          3425:  cilist *a;
        !          3426: {
        !          3427:        int n;
        !          3428:        if(!init)
        !          3429:                f_init();
        !          3430:        if(n=c_le(a))
        !          3431:                return(n);
        !          3432:        reading=1;
        !          3433:        external=1;
        !          3434:        formatted=1;
        !          3435: 
        !          3436:        err(a->cierr, 118, "namelist read -- not yet implemented");
        !          3437:        }
        !          3438: 
        !          3439: s_wsne(a)
        !          3440:  cilist *a;
        !          3441: {
        !          3442:        int n;
        !          3443:        if(!init)
        !          3444:                f_init();
        !          3445:        if(n=c_le(a))
        !          3446:                return(n);
        !          3447:        reading=0;
        !          3448:        external=1;
        !          3449:        formatted=1;
        !          3450: 
        !          3451:        err(a->cierr, 118, "namelist write -- not yet implemented");
        !          3452:        }
        !          3453: ./ ENDUP

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