Open64: osprey/libI77/lread.c Source File

00001 /*
00002 
00003   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00004 
00005   This program is free software; you can redistribute it and/or modify it
00006   under the terms of version 2.1 of the GNU Lesser General Public License 
00007   as published by the Free Software Foundation.
00008 
00009   This program is distributed in the hope that it would be useful, but
00010   WITHOUT ANY WARRANTY; without even the implied warranty of
00011   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00012 
00013   Further, this software is distributed without any warranty that it is
00014   free of the rightful claim of any third person regarding infringement 
00015   or the like.  Any license provided herein, whether implied or 
00016   otherwise, applies only to this software file.  Patent licenses, if
00017   any, provided herein do not apply to combinations of this program with 
00018   other software, or any other product whatsoever.  
00019 
00020   You should have received a copy of the GNU Lesser General Public 
00021   License along with this program; if not, write the Free Software 
00022   Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307, 
00023   USA.
00024 
00025   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00026   Mountain View, CA 94043, or:
00027 
00028   http://www.sgi.com
00029 
00030   For further information regarding this notice, see:
00031 
00032   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00033 
00034 */
00035 
00036 
00037 /* $Header: /proj/osprey/CVS/open64/osprey1.0/libI77/lread.c,v 1.1.1.1 2005/10/21 19:00:00 marcel Exp $ */
00038 
00039 #include <ctype.h>
00040 #include <mutex.h>
00041 #include <malloc.h>
00042 #include <limits.h>
00043 #include <cmplrs/fio.h>
00044 #include "cmplrs/f_errno.h"
00045 #include "fmt.h"
00046 #include "lread.h"
00047 #include "iomode.h"
00048 #include "lio.h"
00049 #include "vmsflags.h"
00050 #include "iio.h"
00051 #include "uio.h"
00052 #include "err.h"
00053 #include "util.h"
00054 #include "bcompat.h"
00055 
00056 #define isblnk(x) (f77ltab[x+1]&BX)
00057 #define issep(x) (f77ltab[x+1]&SX)
00058 #define isapos(x) (f77ltab[x+1]&AX)
00059 #define isexp(x) (f77ltab[x+1]&EX)
00060 #define issign(x) (f77ltab[x+1]&SG)
00061 #define SX 1
00062 #define BX 2
00063 #define AX 4
00064 #define EX 8
00065 #define SG 16
00066 
00067 
00068 static char     f77ltab[128 + 1] ={ /* offset one for EOF */
00069            0,
00070 /*                      \002                     \n                       */
00071        0, 0, AX, 0, 0, 0, 0, 0, 0, 0, SX, 0, 0, 0, 0, 0,
00072          0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
00073 /*          " "       \"              '            +    ,   -     /      */
00074     SX | BX, 0, AX, 0, 0, 0, 0, AX, 0, 0, 0, SG, SX, SG, 0, SX,
00075          0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
00076 /*                              D   E                                 */
00077                    0, 0, 0, 0, EX, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
00078 /*                      Q               */
00079          0, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
00080 /*                 `           d    e                                */
00081       AX, 0, 0, 0, EX, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
00082 /*                      q               */
00083          0, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
00084 };
00085 
00086 /* To avoid innumerable calls to GETC() and UNGETC() assume that there is
00087 always a one character look ahead 'ftnunit->nextch' within the function 
00088 l_read
00089 */
00090 static int l_R(unit *, double *, int);
00091 static int l_R16(unit *, long double *, int);
00092 static int l_C(unit *, void *, void *, int);
00093 static int l_L(unit *, double *, int);
00094 static int l_CHAR(unit *, ftnlen, int isnamelist);  
00095           /* make sure they are
00096            * referenced as static
00097            * functions */
00098 
00099 /* we allow users to go up to 2 ** 48 for repitition count for 64 bit I/O */
00100 /* Why not 2**64?  Because the repitition count is converted in a double
00101    and there is only 52 bits of mantissa! */
00102 #if (_MIPS_SIM == _MIPS_SIM_ABI64)
00103 #define MAX_REP 281474976710656LL /* 2 ** 48 */
00104 #else
00105 #define MAX_REP INT_MAX
00106 #endif
00107 
00108 int
00109 t_gets (unit *ftnunit, char *s, int w, char c)
00110 {
00111    register int    ch, n;
00112 
00113    for (n = 0; n < w; n++) {
00114       ch = getc (ftnunit->ufd);
00115       if (ch == EOF || ch == c || ch == '\n')
00116    break;
00117       *(s++) = c;
00118    }
00119    if (ch == c || ch == '\n')
00120       return (n);
00121    if (feof (ftnunit->ufd) && (ftnunit->ufd != stdin || !f77vms_flag_[VMS_IN]))
00122       ftnunit->uend = 1;
00123    return (EOF);
00124 }
00125 
00126 /* These two dummy flags are turned off and on but are not used at all!!
00127    Pretty good attempt at obfuscation.
00128    I changed l_first so that it is set when l_read is called for the first
00129    time i.e. when a look ahead character is needed.
00130 */
00131 
00132 int
00133 t_getc (unit *ftnunit)
00134 {
00135    int             ch;
00136 
00137    if ((ch = getc (ftnunit->ufd)) != EOF)
00138       return (ch);
00139    if (feof (ftnunit->ufd) && (ftnunit->ufd != stdin || !f77vms_flag_[VMS_IN]))
00140       ftnunit->uend = 1;
00141    return (EOF);
00142 }
00143 
00144 int
00145 t_ungetc (unit *ftnunit, int ch)
00146 {
00147    ungetc (ch, ftnunit->ufd);
00148    return 0;
00149 }
00150 
00151 int e_rsle (void)
00152 {
00153     return( e_rsle_mp( &f77curunit ) );
00154 }
00155 
00156 int e_rsle_mp (unit **fu)
00157 {
00158    unit   *ftnunit = *fu;
00159 
00160    if (ftnunit->ufmt != 2) {
00161       if (ftnunit->l_first)
00162    ftnunit->nextch = t_getc (ftnunit);
00163       while (ftnunit->nextch != '\n' && ftnunit->nextch != EOF)
00164    ftnunit->nextch = t_getc (ftnunit);
00165    }
00166    ftnunit->lock_unit = 0;
00167    return (0);
00168 }
00169 
00170 int e_rsli (void)
00171 {
00172    return (0);
00173 }
00174 
00175 int e_rsli_mp (unit **fu)
00176 {
00177    (*fu)->lock_unit = 0;
00178    return (0);
00179 }
00180 
00181 
00182  /* ltype has 3 values: NULL, TYINT and TYCHAR and is used as a
00183   * YES/NO flag to indicate a valid value has been read. Change it to
00184   * have values: NULL, TYINT, TYCHAR, or TYERROR to indicate a null
00185   * value, a numeric value, a character value, or an invalid value
00186   * has been read respectively */
00187 
00188 /* Note that type also has information about whether this is a 
00189  *  called for namelist I/O. Bit 16 is true for namelist, bit 17 for F90
00190  *  namelist.
00191  */
00192 
00193 int
00194 l_read (unit *ftnunit, XINT *number, flex *ptr, ftnlen len, ftnint type)
00195 {
00196    XINT             i;
00197    double         *yy;
00198    float          *xx;
00199    int            isnamelist;
00200    int            isnamelist90;
00201    int      n;
00202 
00203    isnamelist = (type >> 16) & 1;
00204    isnamelist90 = (type >> 17) & 1;
00205    type &= ((1<<16) - 1);
00206    if (ftnunit->l_first || isnamelist) {
00207       ftnunit->l_first = 0;
00208       GETC (ftnunit->nextch);
00209    }
00210    for (i = 0; i < *number; i++) {
00211       if (ftnunit->lquit)
00212    return 0;
00213       /* If there is an existing value, use it */
00214       if (ftnunit->lcount)
00215    goto setvalue;
00216       for (;; GETC (ftnunit->nextch)) {
00217    donext:
00218    switch (ftnunit->nextch) {
00219    case EOF:
00220       goto loopend;
00221    case ' ':
00222       /* optimize for the most common case */
00223       while (GETC (ftnunit->nextch) == ' ');
00224       goto donext;
00225    case '\t':
00226    case '\n':
00227       continue;
00228    case '/':
00229       ftnunit->lquit = 1;
00230       goto quit;
00231    case ',':
00232 /* A comma would represent a null value provided that the previous READ
00233 has skipped through a "value separator" which may have a comma in it
00234 */
00235       ftnunit->lcount = 1;
00236       GETC (ftnunit->nextch);
00237       goto bump;
00238 /* LHL 5/24/89
00239  * change it so that comment is allowed anywhere within the namelist
00240  * file
00241  */
00242    case '!':
00243       if (isnamelist) {
00244          for (; ftnunit->nextch != '\n' && ftnunit->nextch != EOF; GETC (ftnunit->nextch));
00245 
00246          if (ftnunit->nextch == EOF)
00247       goto loopend;
00248          continue;
00249       } else {
00250          ftnunit->lcount = i;
00251          err(CILISTERR, 112, "! in list input")
00252       }
00253 /* end of change */
00254          /* ^Z is the character for EOF record */
00255    case '\032':
00256          if (f77vms_flag_[VMS_EF]
00257        && GETC (ftnunit->nextch) && ftnunit->nextch == '\n') {
00258          /* endfile record: OK to return here */
00259             ftnunit->lcount = i;
00260       return (EOF);
00261          }
00262       else {
00263          ftnunit->lcount = i;
00264          err(CILISTERR, 112, "^Z in list input")
00265       }
00266 /* PFH 7/22/94
00267  * change it so that comment is allowed to start in 1st column for namelist.
00268  */
00269    case '*':
00270    case 'C':
00271    case 'c':
00272 /* This doesn't work, since no one has ever bothered to set 
00273  * f77recpos to anything other than 0.  This should be looked at later.
00274  */
00275 #if 0 /* f77recpos isn't set */
00276       if ( isnamelist && !isnamelist90 && ftnunit->f77recpos == 0 ) {
00277          for (; ftnunit->nextch != '\n' && ftnunit->nextch != EOF; GETC (ftnunit->nextch));
00278          if (ftnunit->nextch == EOF) goto loopend;
00279          continue;
00280       }
00281 #endif /* f77recpos isn't set */
00282    default:
00283       goto rddata;
00284    }
00285       }
00286 rddata:
00287       /* if there is already an existing count don't do any more
00288        * reading stuff */
00289       /* This whole thing which is supposed to
00290        * check for error doesn't do any good.  The error checking can
00291        * be done quite well, and more complete in the respective
00292        * input routine.  This is just a  waste of time */
00293       switch ((int) type) {
00294       case TYBYTE:
00295       case TYSHORT:
00296       case TYINT:
00297       case TYREAL:
00298       case TYDREAL:
00299    if (n=l_R(ftnunit, (double *) &ftnunit->lqx, 0)) {
00300       if (!isnamelist) {
00301           ftnunit->lcount = i; 
00302     return(112);
00303       }
00304       else if (isalpha( ftnunit->nextch)) {
00305       /* namelist error cause by an alphabetic character which is
00306       most likely the next namelist variable name while reading 
00307       more than one values of an array.  In this case, ignore the
00308       rest of the array elements without generating an error.
00309       */
00310          UNGETC (ftnunit->nextch);
00311          return( 0 );
00312       }
00313       else if (ftnunit->nextch != '$' && ftnunit->nextch != '&') {
00314           ftnunit->lcount = i; 
00315     return(112);
00316       }
00317       else {
00318          ftnunit->lquit = 1;
00319          UNGETC (ftnunit->nextch);
00320          goto bump;
00321       }
00322    }
00323    break;
00324       case TYQUAD:
00325       case TYLONGLONG:
00326    if (n=l_R16 (ftnunit, (long double *) &ftnunit->lqx, 0)) {
00327       if (!isnamelist) {
00328           ftnunit->lcount = i; 
00329     return(112);
00330       }
00331       else if (isalpha( ftnunit->nextch)) {
00332       /* namelist error cause by an alphabetic character which is
00333       most likely the next namelist variable name while reading 
00334       more than one values of an array.  In this case, ignore the
00335       rest of the array elements without generating an error.
00336       */
00337          UNGETC (ftnunit->nextch);
00338          return( 0 );
00339       }
00340       else if (ftnunit->nextch != '$' && ftnunit->nextch != '&') {
00341           ftnunit->lcount = i; 
00342     return(112);
00343       }
00344       else {
00345          ftnunit->lquit = 1;
00346          UNGETC (ftnunit->nextch);
00347          goto bump;
00348       }
00349    }
00350    break;
00351       case TYCOMPLEX:
00352       case TYDCOMPLEX:
00353    if (n=l_C (ftnunit, (double *) &ftnunit->lqx, &ftnunit->lqy, 0)) {
00354       if (!isnamelist) {
00355           ftnunit->lcount = i; 
00356     return(112);
00357       }
00358       else if (isalpha( ftnunit->nextch)) {
00359       /* namelist error cause by an alphabetic character which is
00360       most likely the next namelist variable name while reading 
00361       more than one values of an array.  In this case, ignore the
00362       rest of the array elements without generating an error.
00363       */
00364          UNGETC (ftnunit->nextch);
00365          return( 0 );
00366       }
00367       else if (ftnunit->nextch != '$' && ftnunit->nextch != '&') {
00368           ftnunit->lcount = i; 
00369     return(112);
00370       }
00371       else {
00372          ftnunit->lquit = 1;
00373          UNGETC (ftnunit->nextch);
00374          goto bump;
00375       }
00376    }
00377    break;
00378       case TYQUADCOMPLEX:
00379    if (n=l_C (ftnunit, (long double *) &ftnunit->lqx, &ftnunit->lqy, 1)) {
00380       if (!isnamelist) {
00381           ftnunit->lcount = i; 
00382     return(112);
00383       }
00384       else if (isalpha( ftnunit->nextch)) {
00385       /* namelist error cause by an alphabetic character which is
00386       most likely the next namelist variable name while reading 
00387       more than one values of an array.  In this case, ignore the
00388       rest of the array elements without generating an error.
00389       */
00390          UNGETC (ftnunit->nextch);
00391          return( 0 );
00392       }
00393       else if (ftnunit->nextch != '$' && ftnunit->nextch != '&') {
00394           ftnunit->lcount = i; 
00395     return(112);
00396       }
00397       else {
00398          ftnunit->lquit = 1;
00399          UNGETC (ftnunit->nextch);
00400          goto bump;
00401       }
00402    }
00403    break;
00404       case TYLOGICAL1:
00405       case TYLOGICAL2:
00406       case TYLOGICAL4:
00407       case TYLOGICAL8:
00408    if (n=l_L (ftnunit, (double *)&ftnunit->lqx, isnamelist)) {
00409       if (!isnamelist) {
00410           ftnunit->lcount = i; 
00411     return(112);
00412       }
00413       else if (isalpha( ftnunit->nextch)) {
00414       /* namelist error cause by an alphabetic character which is
00415       most likely the next namelist variable name while reading 
00416       more than one values of an array.  In this case, ignore the
00417       rest of the array elements without generating an error.
00418       */
00419          UNGETC (ftnunit->nextch);
00420          return( 0 );
00421       }
00422       else if (ftnunit->nextch != '$' && ftnunit->nextch != '&') {
00423           ftnunit->lcount = i; 
00424     return(112);
00425       }
00426       else {
00427          ftnunit->lquit = 1;
00428          UNGETC (ftnunit->nextch);
00429          goto bump;
00430       }
00431    }
00432    break;
00433       case TYCHAR:
00434    if (n=l_CHAR (ftnunit, len, isnamelist)) {
00435       if (!isnamelist) {
00436           ftnunit->lcount = i; 
00437     return(112);
00438       }
00439       else if (isalpha( ftnunit->nextch)) {
00440       /* namelist error cause by an alphabetic character which is
00441       most likely the next namelist variable name while reading 
00442       more than one values of an array.  In this case, ignore the
00443       rest of the array elements without generating an error.
00444       */
00445          UNGETC (ftnunit->nextch);
00446          return( 0 );
00447       }
00448       else if (ftnunit->nextch != '$' && ftnunit->nextch != '&') {
00449           ftnunit->lcount = i; 
00450     return(112);
00451       }
00452       else {
00453          ftnunit->lquit = 1;
00454          UNGETC (ftnunit->nextch);
00455          goto bump;
00456       }
00457    }
00458    break;
00459       }
00460 
00461       if (isnamelist) {
00462    while (ftnunit->nextch == ' ' || ftnunit->nextch == '\t' || ftnunit-> nextch == '\n' )
00463       GETC (ftnunit->nextch);
00464    if ( ftnunit->nextch == EOF ) {
00465       fseek( ftnunit->ufd, -1, SEEK_END );
00466       GETC (ftnunit->nextch);
00467    }
00468       } else {
00469       while (ftnunit->nextch == ' ' || ftnunit->nextch == '\t')
00470    GETC (ftnunit->nextch);
00471       }
00472 
00473       /* skip over the first comma which is part of a
00474        * "<SPACE>comma<SPACE>" value separator */
00475       if (ftnunit->nextch == ',')
00476    GETC (ftnunit->nextch);
00477 
00478 loopend:
00479       /* You should never get here when you quit */
00480       if (!ftnunit->f77errlist.iciunit && feof (ftnunit->ufd)) {
00481    ftnunit->lcount = i;
00482    err(ftnunit->f77errlist.ciend, (EOF), "list in")
00483       } else if (!ftnunit->f77errlist.iciunit && ftnunit->ufd && ferror (ftnunit->ufd)) {
00484    ftnunit->lcount = i;
00485    clearerr(ftnunit->ufd);
00486    err(CILISTERR, errno, "list in")
00487       } else if (ftnunit->f77errlist.iciunit && ftnunit->nextch==EOF) {
00488    ftnunit->lcount = i;
00489    err(ftnunit->f77errlist.ciend, (EOF), "list in")
00490       }
00491 
00492 setvalue:
00493       switch (ftnunit->ltype) {
00494       case NULL:    /* The data is a NULL value */
00495    goto bump;
00496       case TYINT:
00497       case TYCHAR:
00498    break;
00499       case TYERROR:             /* The data is no good */
00500    ftnunit->lcount = 0;
00501    if (isnamelist) {
00502       goto quit;
00503    } else {
00504       ftnunit->lcount = i;
00505       err(CILISTERR, 112, "list input");
00506    }
00507       default:
00508    return(ftnunit->uerror);
00509       }
00510 
00511       switch ((int) type) {
00512       case TYLOGICAL1:
00513       case TYBYTE:
00514    ptr->flbyte = (signed char) ftnunit->lqx.fldouble;
00515    break;
00516       case TYLOGICAL2:
00517       case TYSHORT:
00518    ptr->flshort = (short) ftnunit->lqx.fldouble;
00519    break;
00520       case TYLOGICAL4:
00521       case TYINT:
00522    ptr->flint = (int) ftnunit->lqx.fldouble;
00523    break;
00524       case TYLOGICAL8:
00525       case TYLONGLONG:
00526    ptr->flll = (long long) ftnunit->lqx.flquad;
00527    break;
00528       case TYREAL:
00529    ptr->flreal = (float) ftnunit->lqx.fldouble;
00530    break;
00531       case TYDREAL:
00532    ptr->fldouble = ftnunit->lqx.fldouble;
00533    break;
00534       case TYQUAD:
00535    ptr->flquad = ftnunit->lqx.flquad;
00536    break;
00537       case TYCOMPLEX:
00538    xx = (float *) ptr;
00539    *xx++ = (float) ftnunit->lqx.fldouble;
00540    *xx = (float) ftnunit->lqy.fldouble;
00541    break;
00542       case TYDCOMPLEX:
00543    yy = (double *) ptr;
00544    *yy++ = ftnunit->lqx.fldouble;
00545    *yy = ftnunit->lqy.fldouble;
00546    break;
00547       case TYQUADCOMPLEX:
00548    ptr->flquad = ftnunit->lqx.flquad;
00549    * (&ptr->flquad+1) = ftnunit->lqy.flquad;
00550    break;
00551       case TYCHAR:
00552    b_char (ftnunit->f77fio_buf, (char *) ptr, len);
00553    break;
00554       }
00555 bump:
00556       if (ftnunit->lcount > 0)
00557    ftnunit->lcount--;
00558       ptr = (flex *) ((char *) ptr + len);
00559    }
00560 quit:
00561    if (isnamelist)
00562       UNGETC (ftnunit->nextch);
00563    return (0);
00564 }
00565 
00566 
00567 static long double   f77ten_powq[] =
00568     { 1e1L, 1e2L, 1e3L, 1e4L, 1e5L, 1e6L, 1e7L, 1e8L, 1e9L, 
00569     1e10L, 1e11L, 1e12L, 1e13L, 1e14L, 1e15L, 1e16L, 1e17L, 
00570     1e18L, 1e19L, 1e20L, 1e21L, 1e22L, 1e23L, 1e24L, 1e25L, 
00571     1e26L, 1e27L, 1e28L, 1e29L, 1e30L, 1e31L, 1e32L, 1e33L, 
00572     1e34L, 1e35L };
00573 
00574 static int l_R16(unit *ftnunit, long double *qx, int skipcount)
00575 {
00576    double          b, d;
00577    long double     c;
00578    int             sign = 0, db, dd;
00579    int             nfrac, se, exp;
00580 
00581    b = d = 0;
00582    c = 0;
00583    if (issign (ftnunit->nextch)) {
00584       sign = (ftnunit->nextch == '-');
00585       GETC (ftnunit->nextch);
00586    }
00587    for (db = 0, b = 0; isdigit (ftnunit->nextch) && db<15; GETC (ftnunit->nextch), db++)
00588       b = 10 * b + ftnunit->nextch - '0';
00589    if (skipcount)
00590        goto lcount_done;
00591    ftnunit->lcount = 1;
00592    if (ftnunit->nextch == '*') {
00593       /* Give an error for count too big**31 */
00594       if (db >= 15)
00595   for ( ;isdigit (ftnunit->nextch); GETC (ftnunit->nextch))
00596       ;
00597       if (b > MAX_REP || sign || b == 0.0)
00598    err(ftnunit->f77errlist.cierr, F_ERNREP, "repetition");
00599       ftnunit->lcount = (XINT) b;
00600       GETC (ftnunit->nextch);
00601       if (issep (ftnunit->nextch)) {
00602    *qx = 0;
00603    return (ftnunit->ltype=0);   /* return with ltype==NULL */
00604       }
00605       if (issign (ftnunit->nextch)) {
00606          sign = (ftnunit->nextch == '-');
00607          GETC (ftnunit->nextch);
00608       }
00609       for (db = 0, b = 0; isdigit(ftnunit->nextch) && db < 15; GETC (ftnunit->nextch), db++)
00610          b = 10 * b + ftnunit->nextch - '0';
00611    }
00612 lcount_done:
00613    *qx = b;
00614    if (db >= 15) {
00615         /* Take care of precision for integer*8 constant */
00616   for ( ;isdigit (ftnunit->nextch); GETC (ftnunit->nextch), db++)
00617       *qx = 10* (*qx) + ftnunit->nextch - '0';
00618    }
00619 
00620    if (db > 0)
00621        ftnunit->ltype = TYINT;
00622    else
00623        ftnunit->ltype = TYERROR;
00624    if (issep(ftnunit->nextch))
00625        goto okvalue;
00626    /* Behave as in INTEGER*4 by scanning the FP values as well */
00627    /* For the case of FP constants being used as input for INTEGER*8 variables
00628      take the performance hit of using quad prevision to retain the precision
00629     */
00630    nfrac = 0;
00631    if (ftnunit->nextch == '.') {
00632       int             d, nz = 0;
00633 
00634       GETC (ftnunit->nextch);
00635       while ((d = ftnunit->nextch - '0') >= 0 && d <= 9) {
00636          if (!d) {
00637             if (++nz >= sizeof (f77ten_powq) / sizeof (double) && c) {
00638                /* Skip the rest of the digits. They will be
00639                 * ignored anyway */
00640                while (ftnunit->nextch >= '0' && ftnunit->nextch <= '9')
00641                   GETC (ftnunit->nextch);
00642                break;
00643             }
00644          } else {
00645             c = c * f77ten_powq[nz] + d;
00646             nfrac += (nz + 1);
00647             nz = 0;
00648          }
00649          GETC (ftnunit->nextch);
00650       }
00651    } else if (!db && ftnunit->ltype != TYINT) {
00652       /* something that does not start with either digit or '.' */
00653       ftnunit->lcount = 0;
00654       return( ftnunit->ltype = TYERROR );
00655    }
00656    /* Get exponent part = d */
00657    /* Character D or E */
00658    ftnunit->ltype = TYINT;
00659    se = 0;
00660    if (isexp (ftnunit->nextch) && GETC (ftnunit->nextch) || issign (ftnunit->nextch)) {
00661       if (issign (ftnunit->nextch)) {
00662          se = (ftnunit->nextch == '-');
00663          GETC (ftnunit->nextch);
00664       }
00665       for (dd = 0, d = 0; isdigit (ftnunit->nextch); GETC (ftnunit->nextch), dd++)
00666          d = 10 * d + ftnunit->nextch - '0';
00667       if (!dd)
00668          ftnunit->ltype = TYERROR;
00669    }
00670    /* Aint't got no good numeric value in the forms numval or
00671     * integer*numval */
00672    if (ftnunit->ltype == TYERROR)
00673       return (TYERROR);
00674    if (c) {
00675       /* normalize the fractional part only when it exists */
00676       if (nfrac < sizeof (f77ten_powq) / sizeof (double))
00677           c /= f77ten_powq[nfrac - 1];
00678       else {
00679          while (nfrac > 32) {
00680             c *= 1e-32L;
00681             nfrac -= 32;
00682          }
00683          c /= f77ten_powq[nfrac - 1];
00684       }
00685       c += *qx;
00686    }
00687    else
00688       c = *qx;
00689    exp = (int) (se ? -d : d);
00690    if (exp > 0) {
00691       while (exp > 32) {
00692          c *= 1e32L;
00693          exp -= 32;
00694       }
00695       c *= f77ten_powq[exp - 1];
00696    } else if (exp < 0) {
00697       exp = -exp;
00698       while (exp > 32) {
00699          c *= 1e-32L;
00700          exp -= 32;
00701       }
00702       c /= f77ten_powq[exp - 1];
00703    }
00704    *qx = c;
00705 okvalue:
00706    if (sign)
00707       *qx = -(*qx);
00708    return(0);
00709 }
00710 
00711 
00712 static double   f77ten_pow[] ={1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9, 1e10, 1e11,
00713         1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18};
00714 static int l_R(unit *ftnunit, double *lx, int skipcount)
00715 {
00716    double          b, c, d;
00717    int             sign = 0, db, dd;
00718    int             nfrac, se, exp;
00719 
00720    b = c = d = 0;
00721    /* get integral part = b */
00722    if (issign (ftnunit->nextch)) {
00723       sign = (ftnunit->nextch == '-');
00724       GETC (ftnunit->nextch);
00725    }
00726    for (db = 0, b = 0; isdigit (ftnunit->nextch); GETC (ftnunit->nextch), db++)
00727       b = 10 * b + ftnunit->nextch - '0';
00728    if (skipcount)
00729       goto lcount_done;
00730    ftnunit->lcount = 1;
00731    if (ftnunit->nextch == '*') {
00732       if (b > MAX_REP || sign || b == 0.0)
00733    err(ftnunit->f77errlist.cierr, 112, "repetition");
00734       ftnunit->lcount = (XINT) b;
00735       GETC (ftnunit->nextch);
00736       if (issep (ftnunit->nextch)) {
00737    *lx = 0.0;
00738    return (ftnunit->ltype=0);   /* return with ltype==NULL */
00739       }
00740       if (issign (ftnunit->nextch)) {
00741    sign = (ftnunit->nextch == '-');
00742    GETC (ftnunit->nextch);
00743       }
00744       for (db = 0, b = 0; ftnunit->nextch >= '0' && ftnunit->nextch <= '9'; GETC (ftnunit->nextch), db++)
00745    b = 10 * b + ftnunit->nextch - '0';
00746    }
00747 lcount_done:
00748    if (db)
00749       ftnunit->ltype = TYINT;
00750    else ftnunit->ltype = TYERROR;
00751    /* let's play on a good probability of having integer here */
00752    if (issep (ftnunit->nextch))
00753       goto okvalue;
00754    /* get fractional part = c */
00755    nfrac = 0;
00756    if (ftnunit->nextch == '.') {
00757       int             d, nz = 0;
00758 
00759       GETC (ftnunit->nextch);
00760       while ((d = ftnunit->nextch - '0') >= 0 && d <= 9) {
00761    if (!d) {
00762       if (++nz >= 19 && c) {
00763          /* Skip the rest of the digits. They will be
00764           * ignored anyway */
00765          while (ftnunit->nextch >= '0' && ftnunit->nextch <= '9')
00766       GETC (ftnunit->nextch);
00767          break;
00768       }
00769    } else {
00770       c = c * f77ten_pow[nz] + d;
00771       nfrac += (nz + 1);
00772       nz = 0;
00773    }
00774    GETC (ftnunit->nextch);
00775       }
00776    } else if (!db && ftnunit->ltype != TYINT) {
00777       /* something that does not start with either digit or '.' */
00778       ftnunit->lcount = 0;
00779       return (ftnunit->ltype = TYERROR);
00780    }
00781    /* Get exponent part = d */
00782    /* Character D or E */
00783    ftnunit->ltype = TYINT;
00784    se = 0;
00785    if (isexp (ftnunit->nextch) && GETC (ftnunit->nextch) || issign (ftnunit->nextch)) {
00786       if (issign (ftnunit->nextch)) {
00787    se = (ftnunit->nextch == '-');
00788    GETC (ftnunit->nextch);
00789       }
00790       for (dd = 0, d = 0; isdigit (ftnunit->nextch); GETC (ftnunit->nextch), dd++)
00791    d = 10 * d + ftnunit->nextch - '0';
00792       if (!dd)
00793    ftnunit->ltype = TYERROR;
00794    }
00795    /* Aint't got no good numeric value in the forms numval or
00796     * integer*numval */
00797    if (ftnunit->ltype == TYERROR)
00798       return (TYERROR);
00799    if (c) {
00800       /* normalize the fractional part only when it exists */
00801       if (nfrac < sizeof (f77ten_pow) / sizeof (double))
00802           c /= f77ten_pow[nfrac - 1];
00803       else {
00804          while (nfrac > 16) {
00805       c *= 1e-16;
00806       nfrac -= 16;
00807          }
00808          c /= f77ten_pow[nfrac - 1];
00809       }
00810       b += c;
00811    }
00812    exp = (int) (se ? -d : d);
00813    if (exp > 0) {
00814       while (exp > 16) {
00815    b *= 1e16;
00816    exp -= 16;
00817       }
00818       b *= f77ten_pow[exp - 1];
00819    } else if (exp < 0) {
00820       exp = -exp;
00821       while (exp > 16) {
00822    b *= 1e-16;
00823    exp -= 16;
00824       }
00825       b /= f77ten_pow[exp - 1];
00826    }
00827 okvalue:
00828    *lx = (sign) ? -b : b;
00829    return (0);
00830 }
00831 
00832 
00833 static int l_C(unit *ftnunit,  void *lx, void *ly, int quad)
00834 {
00835    int             dumy;
00836    char           *sbuf;
00837    int      n;
00838 
00839    /* This should have been taken care of in l_read */
00840    if (ftnunit->nextch != '(') {
00841       ftnunit->lcount = 0;
00842       while (isdigit (ftnunit->nextch)) {
00843    ftnunit->lcount = ftnunit->lcount * 10 + ftnunit->nextch - '0';
00844    GETC (ftnunit->nextch);
00845       }
00846       if (ftnunit->nextch != '*') {
00847    if (ftnunit->f77errlist.iciunit || !feof (ftnunit->ufd)) {
00848       err(ftnunit->f77errlist.cierr, 112, "complex input");
00849    } else
00850       err(ftnunit->f77errlist.cierr, (EOF), "lread");
00851       }
00852       if (GETC (ftnunit->nextch) != '(') {
00853    if (issep (ftnunit->nextch)) {
00854       if (quad)
00855           *(long double *)lx = *(long double *)ly = 0;
00856       else
00857     *(double *)lx = *(double *)ly = 0;
00858       return (ftnunit->ltype = 0);  /* return with ltype==NULL */
00859    } else {
00860       err(ftnunit->f77errlist.cierr, 112, "no ( in complex data")
00861    }
00862       }
00863    } else
00864       ftnunit->lcount = 1;
00865 
00866    ftnunit->ltype = TYINT;
00867    GETC(ftnunit->nextch);
00868    while (isspace (ftnunit->nextch)) GETC(ftnunit->nextch);
00869 
00870    if (!ftnunit->f77errlist.iciunit) {
00871       if (quad) {
00872    if (n=l_R16 (ftnunit, lx, 1)) {
00873        return(n);
00874    }
00875       } else {
00876    if (n=l_R (ftnunit, lx, 1)) {
00877        return(n);
00878    }
00879       }
00880    } else {
00881       icptr--;
00882       for (sbuf = icptr; icpos < ftnunit->f77errlist.icirlen && *icptr != ' ' && *icptr != ','; icpos++, icptr++);
00883       ftnunit->nextch = *icptr;
00884       ftnunit->f77recpos = icpos;
00885       *icptr = '\0';
00886       if (sscanf (sbuf, "%lf%c", lx, &dumy) != 1)
00887    err(ftnunit->f77errlist.cierr, 112, "illegal real part in complex data");
00888       *icptr++ = (char) ftnunit->nextch;
00889    }
00890 
00891    while (isspace (ftnunit->nextch) || ftnunit->nextch == '\n') GETC(ftnunit->nextch);
00892    if ( ftnunit->nextch == ',' ) {
00893       GETC(ftnunit->nextch);
00894    } else {
00895       err(ftnunit->f77errlist.cierr, 112, "no comma");
00896    }
00897    while (isspace (ftnunit->nextch) || ftnunit->nextch == '\n') GETC(ftnunit->nextch);
00898 
00899    if (!ftnunit->f77errlist.iciunit) {
00900       if (quad) {
00901    if (n = l_R16 (ftnunit, ly, 1)) {
00902        return(n);
00903    }
00904       } else {
00905    if (n=l_R (ftnunit, ly, 1)) {
00906        return(n);
00907    }
00908       }
00909    } else {
00910       icptr--;
00911       for (sbuf = icptr; icpos < ftnunit->f77errlist.icirlen && *icptr != ' ' && *icptr != ')'; icpos++, icptr++);
00912       ftnunit->nextch = *icptr;
00913       ftnunit->f77recpos = icpos;
00914       *icptr = '\0';
00915       if (sscanf (sbuf, "%lf%c", ly, &dumy) != 1)
00916    err(ftnunit->f77errlist.cierr, 112, "illegal imaginary part in complex data")
00917       *icptr++ = (char) ftnunit->nextch;
00918    }
00919    while (isspace (ftnunit->nextch)) GETC (ftnunit->nextch);
00920 
00921    if (ftnunit->nextch != ')') {
00922       err(ftnunit->f77errlist.cierr, 112, "no )")
00923    } else
00924       GETC (ftnunit->nextch);
00925 
00926    return (0);
00927 }
00928 
00929 static int l_L(unit *ftnunit, double *lx, int isnamelist)
00930 {
00931    ftnll             loc=0;
00932    int               savechar;
00933    int             isblank;
00934    double          lvalue;
00935    int             isfalse_or_true = -1;
00936 
00937    /* This should have been taken care of in l_read */
00938    if (isdigit (ftnunit->nextch)) {
00939       ftnunit->lcount = 0;
00940       while (isdigit (ftnunit->nextch)) {
00941    ftnunit->lcount = ftnunit->lcount * 10 + ftnunit->nextch - '0';
00942    GETC (ftnunit->nextch);
00943       }
00944       if (ftnunit->nextch != '*')
00945    if (ftnunit->f77errlist.iciunit || !feof (ftnunit->ufd)) {
00946       err(ftnunit->f77errlist.cierr, 112, "no star")
00947    } else
00948       err(ftnunit->f77errlist.cierr, (EOF), "lread")
00949          GETC (ftnunit->nextch);
00950       if (issep (ftnunit->nextch))
00951    return (ftnunit->ltype=0);   /* return with ltype==NULL */
00952    } else
00953       ftnunit->lcount = 1;
00954    if (ftnunit->nextch == '.')
00955       GETC (ftnunit->nextch);
00956    if (isnamelist) {
00957       loc = FTELL (ftnunit->ufd);
00958       savechar = ftnunit->nextch;
00959    }
00960    switch (ftnunit->nextch) {
00961    case 't':
00962    case 'T':
00963       lvalue = 1;
00964       break;
00965    case 'f':
00966    case 'F':
00967       lvalue = 0;
00968       break;
00969    default:
00970       /* it could be namelist item */
00971       return (TYERROR);
00972    }
00973    ftnunit->ltype = TYINT;
00974    if (isnamelist) {
00975       /* In order to deal with the case in which the charcater we just saw was really the
00976        * first character in a NAMELIST variable name beginning with T or F, we need to go until
00977        * we hit the first non-alphanumeric character. If it's a ' ', tab or newline, we check the
00978        * next non-blank character. If it's an '=', we have the next variable in a namelist.
00979        * Otherwise, assume it's just a logical and skip to the next separator.
00980        */
00981       while (isalnum (GETC (ftnunit->nextch)));
00982       if (ftnunit->nextch == '.')
00983    GETC (ftnunit->nextch);
00984       
00985       /* watch out for the case of namelist input where the leading
00986        * 'f' or 't' can be the name of a namelist variable followed
00987        * by '=' */
00988       if (!issep (ftnunit->nextch) &&
00989     ftnunit->nextch != '$' &&
00990     ftnunit->nextch != '!') {
00991    isfalse_or_true = 0;
00992       } else {
00993    isblank = (ftnunit->nextch == ' ' || ftnunit->nextch == '\t' ||
00994         ftnunit->nextch == '\n' || ftnunit->nextch == '!');
00995    if (!isblank) /* must be a comma or a / or a $ */ {
00996       isfalse_or_true = 1;
00997    } else {
00998       if (ftnunit->nextch == '!') {
00999          /* Skip to EOL */
01000          while (GETC(ftnunit->nextch) != '\n' &&
01001           ftnunit->nextch != EOF);
01002          GETC(ftnunit->nextch);
01003       }
01004       while (ftnunit->nextch == ' ' || ftnunit->nextch == '\t' ||
01005        ftnunit->nextch == '\n')
01006         GETC (ftnunit->nextch);
01007       if (ftnunit->nextch == '!') {
01008          /* Skip to EOL */
01009          while (GETC(ftnunit->nextch) != '\n' &&
01010           ftnunit->nextch != EOF);
01011          GETC(ftnunit->nextch);
01012       }
01013       if (ftnunit->nextch == '=' ||
01014     ftnunit->nextch == '(' ||
01015     ftnunit->nextch == '%') {
01016          isfalse_or_true = 0;
01017       } else {
01018          isfalse_or_true = 1;
01019       }
01020    }
01021       }
01022       if (isfalse_or_true) {
01023    *lx = lvalue;
01024       } else {
01025    /* ignore fseek error from a terminal which will result in
01026     * an error later */
01027    FSEEK (ftnunit->ufd, loc, SEEK_SET);
01028    ftnunit->nextch=savechar;
01029    return (TYERROR);
01030       }
01031    } else {
01032       *lx = lvalue;
01033       while (!issep (GETC (ftnunit->nextch)) && ftnunit->nextch != EOF);
01034       if (ftnunit->nextch == '.')
01035    GETC (ftnunit->nextch);
01036    }
01037    return (0);
01038 }
01039 
01040 static int l_CHAR(unit *ftnunit, ftnlen len, int isnamelist)
01041 /* there were too many changes to this function for Fortran 90 to have
01042    small sections of differences, so entire function is unfortunately
01043    duplicated.
01044 
01045    Use the I90 version which is O.K. for F77 list-directed in the fact
01046    that it doesn't require delimiters.
01047 */
01048 {
01049 
01050    int             i = 0;
01051    char            delim, *p;
01052    char firstch;
01053    XINT beginpos;
01054    XINT64 beginoff;
01055    char *beginptr;
01056 
01057    if (isdigit(ftnunit->nextch)) {
01058 
01059   firstch = ftnunit->nextch;
01060 
01061         if ( !ftnunit->f77errlist.iciunit ) {
01062       beginpos = ftnunit->f77recpos;
01063       beginoff = FTELL(ftnunit->ufd);
01064             while(isdigit(GETC(ftnunit->nextch)));
01065             FSEEK( ftnunit->ufd, beginoff, SEEK_SET );
01066       ftnunit->f77recpos = beginpos;
01067   } else {
01068       beginpos = icpos = ftnunit->f77recpos;
01069       beginptr = icptr;
01070             while(isdigit(GETC(ftnunit->nextch))) {
01071     if ( icpos == ftnunit->f77errlist.icirlen ) {
01072         ftnunit->nextch = '\n';
01073         break;
01074     }
01075       }
01076       icptr = beginptr;
01077       icpos = ftnunit->f77recpos = beginpos;
01078   }
01079 
01080         if (ftnunit->nextch != '*' ) {
01081 
01082 #ifdef I90
01083      /* Namelist I/O requires a delimiter */
01084       if (ftnunit->f90sw == 1 && !isnamelist ) { /* assumed to be non-deliminated character string */
01085 
01086     ftnunit->lcount = 1;
01087     delim = NULL;
01088     ftnunit->ltype = TYCHAR;
01089     ftnunit->nextch = firstch;
01090 
01091       } else {
01092 
01093     if (!ftnunit->f77errlist.iciunit || !feof (ftnunit->ufd)) {
01094         err(ftnunit->f77errlist.cierr, 112, "no star")
01095     } else {
01096         err(ftnunit->f77errlist.cierr, (EOF), "lread");
01097     }
01098 
01099       }
01100 #else
01101      if (!ftnunit->f77errlist.iciunit || !feof (ftnunit->ufd)) {
01102     err(ftnunit->f77errlist.cierr, 112, "no star")
01103      } else {
01104     err(ftnunit->f77errlist.cierr, (EOF), "lread");
01105      }
01106 #endif
01107 
01108   } else {  /* determining lcount should have been taken care of in l_read */
01109 
01110             ftnunit->lcount = 0;
01111       ftnunit->nextch = firstch;
01112       while (isdigit (ftnunit->nextch)) {
01113     ftnunit->lcount = ftnunit->lcount * 10 + ftnunit->nextch - '0';
01114     GETC (ftnunit->nextch);
01115       }
01116       GETC (ftnunit->nextch);  /* step over the '*' */
01117       if (issep (ftnunit->nextch)) 
01118     return (ftnunit->ltype=0);  /* return with ltype==NULL */
01119   }
01120 
01121    } else {
01122 
01123       ftnunit->lcount = 1;
01124 
01125    }
01126 
01127    if (ftnunit->nextch == '\'' || ftnunit->nextch == '"') {
01128   delim = (char) ftnunit->nextch;
01129    } else {
01130 #ifdef I90
01131       /* Namelist I/O requires a delimiter */
01132   if ( ftnunit->f90sw == 1 && !isnamelist) {
01133       delim = NULL;
01134       UNGETC(ftnunit->nextch);
01135   } else {
01136       return (TYERROR);
01137   }
01138 #else
01139   return (TYERROR);
01140 #endif
01141    }
01142 
01143    ftnunit->ltype = TYCHAR;
01144    check_buflen( ftnunit, len );
01145    p = ftnunit->f77fio_buf;
01146    if ( delim != NULL ) {
01147       for(i=0;;) {
01148           while(GETC(ftnunit->nextch)!=delim) {
01149        if (ftnunit->nextch==EOF) {
01150     return(EOF);
01151        } else if (ftnunit->nextch=='\n') {
01152 #ifdef I90
01153     if(i == 0 || *(p-1) != '\\' || ftnunit->f90sw == 1)
01154 #else
01155     if(i == 0 || *(p-1) != '\\' )
01156 #endif
01157        continue;
01158     i--;
01159     p--;
01160        } else if (++i <= len)
01161     *p++ = (char) ftnunit->nextch;
01162     }
01163     /* skip over the quote, check for two consecutive quotes */
01164     if(GETC(ftnunit->nextch)==delim) {
01165              if (++i <= len)
01166      *p++ = (char) ftnunit->nextch;
01167     } else {
01168        /* got the delimiting quote */
01169        *p++ = 0;
01170        return(0);
01171     }
01172       }
01173    } else {
01174       /* no delimiters, just read until getting a separator */
01175       while( !issep(GETC(ftnunit->nextch)) ) {
01176          if (ftnunit->nextch==EOF) {
01177           return(EOF);
01178          } else if (++i <= len)
01179           *p++ = (char) ftnunit->nextch;
01180       }
01181       *p++ = 0;
01182       return(0);
01183    }
01184 }
01185 
01186 static
01187 #if 11
01188 int s_rsle_com (cilist64 *a, unit **fu)
01189 #else
01190 int s_rsle_com (cilist *a, unit **fu)
01191 #endif
01192 {
01193    int             n;
01194    unit     *ftnunit;
01195 
01196    if (!f77init)
01197       f_init ();
01198    if (n = c_le (a, fu))
01199       return (n);
01200    ftnunit = *fu;
01201 #ifdef I90
01202    ftnunit->f90sw=0;
01203    if (ftnunit->uaction == WRITEONLY )
01204        errret(a->cierr,180,"startread");
01205 #endif
01206    ftnunit->l_first = 1;
01207    ftnunit->f77lioproc = l_read;
01208    ftnunit->f77getn = t_getc;
01209    ftnunit->f77gets = t_gets;
01210    ftnunit->f77ungetn = t_ungetc;
01211    ftnunit->lquit = 0;
01212    ftnunit->lcount = 0;
01213    if (ftnunit->ufd == stdin && feof (ftnunit->ufd) && f77vms_flag_[VMS_IN])
01214       clearerr(ftnunit->ufd);
01215    if (ftnunit->ualias->ucc == CC_FORTRAN && ftnunit->ualias->ucchar) {
01216       putc (ftnunit->ualias->ucchar, ftnunit->ualias->ufd);
01217       ftnunit->ualias->ucchar = '\0';
01218    }
01219 
01220    /* PV 291109: When iolist is empty do a GETC to check for
01221       empty file; if the file is non-empty do an UNGETC before
01222       proceeding */
01223 
01224    GETC(ftnunit->nextch);
01225    if (ftnunit->nextch == EOF)
01226      err(ftnunit->f77errlist.ciend, (EOF), "list in");
01227    UNGETC(ftnunit->nextch);
01228    return (f77nowreading (ftnunit));
01229 }
01230 
01231 int s_rsle (cilist *a)
01232 {
01233 #if 11
01234   cilist64 dst;
01235   get_cilist64(&dst, a);
01236   return s_rsle_com(&dst, &f77curunit);
01237 #else
01238     return( s_rsle_com( a, &f77curunit ) );
01239 #endif
01240 }
01241 
01242 int s_rsle_mp (cilist *a, unit **fu)
01243 {
01244 #if 11
01245   cilist64 dst;
01246   get_cilist64(&dst, a);
01247   return s_rsle_com(&dst, fu);
01248 #else
01249     return( s_rsle_com( a, fu ) );
01250 #endif
01251 }
01252 
01253 #if 11
01254 int s_rsle64 (cilist64 *a)
01255 {
01256     return( s_rsle_com( a, &f77curunit ) );
01257 }
01258 
01259 int s_rsle64_mp (cilist64 *a, unit **fu)
01260 {
01261     return( s_rsle_com( a, fu ) );
01262 }
01263 #endif
01264 
01265 static
01266 #if 11
01267 int s_rsli_com (icilist64 *a, unit **fu)
01268 #else
01269 int s_rsli_com (icilist *a, unit **fu)
01270 #endif
01271 {
01272    int             n;
01273    unit           *ftnunit;
01274 
01275    if (!f77init)
01276       f_init ();
01277    f77curunit = ftnunit = *fu = Internal_File;
01278    while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L ))
01279        ;
01280    c_li (a);
01281 #ifdef I90
01282    ftnunit->f90sw = 0;
01283 #endif
01284    ftnunit->uwrt &= ~WR_OP;
01285    ftnunit->l_first = 1;
01286    ftnunit->f77lioproc = l_read;
01287    ftnunit->f77getn = z_getc;
01288    ftnunit->f77gets = z_gets;
01289    ftnunit->f77ungetn = z_ungetc;
01290    ftnunit->lquit = 0;
01291    ftnunit->lcount = 0;
01292    return (0);
01293 }
01294 
01295 int s_rsli (icilist *a)
01296 {
01297 #if 11
01298   icilist64 dst;
01299   get_icilist64(&dst, a);
01300   return s_rsli_com(&dst, &f77curunit);
01301 #else
01302     return( s_rsli_com( a, &f77curunit ) );
01303 #endif
01304 }
01305 
01306 int s_rsli_mp (icilist *a, unit **fu)
01307 {
01308 #if 11
01309   icilist64 dst;
01310   get_icilist64(&dst, a);
01311   return s_rsli_com(&dst, fu);
01312 #else
01313     return( s_rsli_com( a, fu ) );
01314 #endif
01315 }
01316 
01317 #if 11
01318 int s_rsli64 (icilist64 *a)
01319 {
01320     return( s_rsli_com( a, &f77curunit ) );
01321 }
01322 
01323 int s_rsli64_mp (icilist64 *a, unit **fu)
01324 {
01325     return( s_rsli_com( a, fu ) );
01326 }
01327 #endif
01328 
01329 
01330 #if 11
01331 #pragma weak e_rsle64 = e_rsle
01332 #pragma weak e_rsle64_mp = e_rsle_mp
01333 #pragma weak e_rsli64 = e_rsli
01334 #pragma weak e_rsli64_mp = e_rsli_mp
01335 
01336 #endif