rnl90.c

Go to the documentation of this file.

/*

  Copyright (C) 2000, 2001, Silicon Graphics, Inc.  All Rights Reserved.

  This program is free software; you can redistribute it and/or modify it
  under the terms of version 2.1 of the GNU Lesser General Public License 
  as published by the Free Software Foundation.

  This program is distributed in the hope that it would be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  

  Further, this software is distributed without any warranty that it is
  free of the rightful claim of any third person regarding infringement 
  or the like.  Any license provided herein, whether implied or 
  otherwise, applies only to this software file.  Patent licenses, if
  any, provided herein do not apply to combinations of this program with 
  other software, or any other product whatsoever.  

  You should have received a copy of the GNU Lesser General Public 
  License along with this program; if not, write the Free Software 
  Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307, 
  USA.

  Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
  Mountain View, CA 94043, or:

  http://www.sgi.com

  For further information regarding this notice, see:

  http://oss.sgi.com/projects/GenInfo/NoticeExplan

*/



#pragma ident "@(#) libf/fio/rnl90.c    92.9    10/12/99 13:16:22"

#include <stdio.h>
#include <errno.h>
#include <liberrno.h>
#include <fortran.h>
#include <stdlib.h>
#include <cray/fmtconv.h>
#include <cray/nassert.h>
#if !defined(_ABSOFT)
#include <sys/unistd.h>
#endif
#include "fio.h"
#include "namelist.h"
#include "rnl90def.h"

/* EXTERNAL entry points */
extern int _s_scan_extensions(void *ptr, ftype_t type,
        unsigned long elsize, long *field_begin,
        unsigned long rec_chars, int *fwptr, long cmode);
extern int _nicverr(const int _Nicverror);

/* use SUBGTC when the character retrieval cannot hit an end of file until
 * the retrieval is complete.  This occurs when retrieving the characters of
 * a name.  This macro is used in functions outside the main namelist FRN
 * routine.
 */

#define SUBGTC(x) {                                     \
        while (cup->ulinecnt == 0) {                    \
                if (errn = _nlrd_fillrec(css, cup)) {   \
                        return(errn);                   \
                }                                       \
        }                                               \
        x       = (char) *cup->ulineptr++;              \
        cup->ulinecnt--;                                \
}

#define SUBGTCNOEOR(x) {                                \
        if (!cup->ulinecnt) {                           \
                x       = ' ';                          \
        } else {                                        \
                x       = (char) *cup->ulineptr++;      \
                cup->ulinecnt--;                        \
        }                                               \
}

/* Fortran 95 provides an exclamation point as an input record
 * comment character.  Prepare for its addition in 3.0+.  If
 * comment begins an input record, ignore the rest of the
 * input record and get the next input record.
 */

#define CMTE_SUBGTC(x) {                                \
        while (cup->ulinecnt == 0) {                    \
                if (errn = _nlrd_fillrec(css, cup)) {   \
                        return(errn);                   \
                }                                       \
        }                                               \
        x       = (char) *cup->ulineptr++;              \
        if (x == '!') {                                 \
                x       = ' ';                          \
                cup->ulinecnt   = 1;                    \
        }                                               \
        cup->ulinecnt--;                                \
}

#define CMTE_SUBGTCNOEOR(x) {                           \
        if (!cup->ulinecnt) {                           \
                x       = ' ';                          \
        } else {                                        \
                x       = (char) *cup->ulineptr++;      \
                cup->ulinecnt--;                        \
        }                                               \
        if (x == '!') {                                 \
                x       = ' ';                          \
                cup->ulinecnt   = 0;                    \
        }                                               \
}
                


/* use MAINGT when the character retrieval can hit an end of file before 
 * retrieval is complete.  This occurs when retrieving '=', delimiters,
 * , etc.  This macro is used in functions within the main namelist FRN
 * routine.  CMTE_MAINGT is the same except comments are allowed for F95.
 */

#define MAINGT(x) {                                             \
        while (cup->ulinecnt == 0) {                            \
                if (errn = _nlrd_fillrec(css, cup)) {           \
                        if (errn < 0) {                         \
                                ENDD(endf, css, FERDPEOF);      \
                        }                                       \
                        else {                                  \
                                ERROR0(errf, css, errn);        \
                        }                                       \
                }                                               \
        }                                                       \
        x       = (char) *cup->ulineptr++;                      \
        cup->ulinecnt--;                                        \
}

#define CMTE_MAINGT(x) {                                        \
        while (cup->ulinecnt == 0) {                            \
                if (errn = _nlrd_fillrec(css, cup)) {           \
                        if (errn < 0) {                         \
                                ENDD(endf, css, FERDPEOF);      \
                        }                                       \
                        else {                                  \
                                ERROR0(errf, css, errn);        \
                        }                                       \
                }                                               \
        }                                                       \
        x       = (char) *cup->ulineptr++;                      \
        /* CHECK for comment */                                 \
        if (x == '!') {                                         \
                x       = ' ';                                  \
                cup->ulinecnt   = 1;                            \
        }                                                       \
        cup->ulinecnt--;                                        \
}

#define GETSECTION(x) {  \
                field_begin     = cup->ulineptr;                \
                field_end       = cup->ulineptr;                \
                for (j = 0; j < cup->ulinecnt; j++) {           \
                        x       = (char) *field_end;            \
                        if (x == ')' || x == ',' || x == ':')   \
                                break;                          \
                        field_end++;                            \
                }                                               \
                field_width     = j;                            \
}

/*
 *      This table is used to drive the f90 input conversion based on the
 *      type of the data.
 */
ic_func *ncf_tab90[] = {
        NULL,           /* DVTYPE_UNUSED */
        NULL,           /* DVTYPE_TYPELESS */
        _iu2s,          /* DVTYPE_INTEGER */
        _defgu2sd,      /* DVTYPE_REAL */
        _defgu2sd,      /* DVTYPE_COMPLEX */
        NULL,           /* DVTYPE_LOGICAL */
        NULL,           /* DVTYPE_ASCII */
};

static int _nlrd_fillrec(FIOSPTR css, unit *cup);

static int _getname(FIOSPTR css, unit *cup, char *buf, char *lastc);

static void _cnvrt_toupper(char *bufr);

static nmlist_goli_t *_findname(char *key, nmlist_goli_t *nlvar,
                unsigned countitm);

static int _getnlval(FIOSPTR css, nmlist_goli_t *nlvar, char *lastc, 
        unit *cup);

static int _indx_nl(FIOSPTR css, unit *cup, struct DvDimen *dvdn,
   int *ndim, long strbegend[3], int *encnt, int *icnt, int arryflag);

static int _nlrdent(FIOSPTR css,unit *cup,nmlist_goli_t *nalist,
        unsigned count, char *lastc, int byt);

static int _nlread(FIOSPTR css, ftype_t type, unit *cup, void *ptr,
   long elsize, int cnt, int inc, char *lastc);

static int _nexdata(FIOSPTR css, ftype_t type, void *ptr, int cnt, int inc,
   char lastc, unit *cup, long *lval, int *lcount, long elsize, int *nullvlu);

static int _g_charstr(FIOSPTR css, unit *cup, void *p, int cnt, char c,
   int lcount, long elsize, int *nullvlu);

static int _g_complx(FIOSPTR css, unit *cup, ftype_t type, long *lval,
   long elsize);

static int _g_number(ftype_t type, unit *cup,long *lval, long elsize);

static int _gocthex(FIOSPTR css, unit *cup, ftype_t type, long *lval, int base,
   long elsize, int *nullvlu);

static int _get_holl(FIOSPTR css, unit *cup, char holltype, int count,
        ftype_t type, long *lval, long elsize);

static int  _get_quoholl(FIOSPTR css, unit *cup, char cdelim, ftype_t type,
   long *lval, long elsize);

static int _nl_stride_dv(FIOSPTR css, unit *cup, DopeVectorType *dv,
        struct DvDimen *sectn, char *lastc, long strbegend[3]);

static int _nl_strd_derv( FIOSPTR css, unit *cup, DopeVectorType *dv,
   struct DvDimen *sectn, char *lastch, nmlist_goli_t *vdr,
   unsigned int cnt, long bte);

/*
 *      _FRN    - called by compiled Fortran programs to process a namelist 
 *                read statement.
 *      Synopsis
 *              int _FRN(       ControlListType *cilist,
 *                              nmlist_group *namlist,
 *                              void *stck);
 *              Where
 *                      cilist  - pointer to the control information list
 *                                information.  This describes the specifiers
 *                                for the current I/O statement.
 *                      namlist  - pointer to the namelist table.
 *                      stck    - pointer to stack space which is passed
 *                                to each call to _FRU for a particular
 *                                statement.  This is used by the library.
 *      Return value
 *              IO_OKAY, IO_END, or IO_ERR
 */

int
_FRN(ControlListType *cilist, nmlist_group *namlist, void *stck)
{
        char            buf[MAXNAML + 5], c;
        int             errf;           /* Error processing flag        */
        int             endf;           /* EOF processing flag          */
        int             errn;           /* Error number                 */
        register unum_t unum;           /* Actual unit number           */
        unit            *cup;           /* Pointer to unit table entry  */
        unsigned long   rlen;           /* group name length            */
        unsigned long   rcount;         /* count of namelist items      */
        char            *rptr;          /* pointer to group name        */
        char            *varptr;        /* ptr to group_obj_list item   */
        unsigned long   varlen;         /* len of group_obj_list name   */
        nmlist_goli_t   *nlvar;         /* ptr to next variable entry   */
        nmlist_goli_t   *fdvar;         /* ptr to next variable entry   */
        ftype_t         type;
        char            endnmlchar;     /* namelist group name char     */
        FIOSPTR         css;

        /* Assertions */
        /* Validate that the size of *stck is large enough */
        assert ( cilist->stksize >= sizeof(struct fiostate)/sizeof(long) );

        /* The compiler flags namelist with fmt flag */
        assert( (cilist->fmt == CI_NAMELIST));

        /* The compiler disallows namelist with internal files */
        assert( !(cilist->internal && cilist->fmt == CI_NAMELIST));

        /* The compiler disallows namelist with direct files */
        assert( !(cilist->dflag && cilist->fmt == CI_NAMELIST));

        css     = stck;
        errn    = 0;
        type    = DVTYPE_UNUSED;
        varptr  = NULL;

/* **************************************************************************
 *      Statement Initialization Section
 ************************************************************************* */

        /* Establish error processing options */
        errf    = (cilist->errflag || cilist->iostatflg);
        endf    = (cilist->endflag || cilist->iostatflg);

        if (cilist->uflag == CI_UNITASTERK)
                unum    = STDIN_U;
        else
                unum    = *cilist->unit.wa;

        STMT_BEGIN(unum, 0, T_RNL, NULL, css, cup);

        if (cup == NULL) {      /* If not connected */
                cup     = _imp_open(css, SEQ, FMT, unum, errf, &errn);
                /*
                 * If the open failed, cup is NULL and errn contains
                 * the error number.
                 */
                if (cup == NULL)
                        goto finalization;
        }
        /* All paths which lead here have set cup to a non-null value */
        assert (cup != NULL);

        /* Copy the user's error processing options into the unit table */
        cup->uflag      = (cilist->errflag              ?  _UERRF : 0) |
                          (cilist->endflag              ?  _UENDF : 0) |
                          (cilist->iostat_spec != NULL  ? _UIOSTF : 0);
        css->u.fmt.nonadv       = 0;

        /* If trying to read a file without read permission */
        if ((cup->uaction & OS_READ) == 0) {
                errn    = FENOREAD;
                ERROR0(errf, css, errn);
        }
        /* If attempting formatted I/O on an unformatted file */
        if (!cup->ufmt) {
                errn    = FEFMTTIV;
                ERROR0(errf, css, errn);
        }
        /* If sequential and writing, disallow read after write */
        if (cup->useq && cup->uwrt != 0) {
                errn    = FERDAFWR;
                ERROR0(errf, css, errn);
        }

        /* Preset fields in unit table */

        cup->uwrt       = 0;

        /* Initialize fields in the Fortran statement state structure */

        css->u.fmt.icp          = NULL;
        css->u.fmt.blank0       = cup->ublnk;
        css->u.fmt.lcomma       = 0;
        css->u.fmt.slash        = 0;

        if (cup->useq == 0) {   /* If seq. attempted on direct file */
                errn    = FESEQTIV;     /* Sequential not allowed */
                ERROR0(errf, css, errn);
        }
        /* external sequential formatted I/O */
        if (cup->uend && !cup->umultfil) {      /* If after endfile */
                errn    = FERDENDR;     /* Read after endfile */
                ERROR0(endf, css, errn);
        }

        css->u.fmt.endrec       = _sr_endrec;

        if (cup->pnonadv == 0)          /* if previous ADVANCE='YES' */
                errn    = (*css->u.fmt.endrec)(css, cup, 1); /* Read a record */
        else                            /* else previous ADVANCE='NO' */
                css->u.fmt.leftablim    = cup->ulineptr; /* set left tablimit */

        if (errn != 0)
                if (errn < 0 ) {
                        ENDD(endf, css, FERDPEOF);
                }
                else {
                        ERROR0(errf, css, errn);
                }
        cup->pnonadv    = css->u.fmt.nonadv;    /* remember prev ADVANCE= */

/* **************************************************************************
 *      Data Transfer Section
 ************************************************************************* */

#if defined(__mips) || !defined(_WORD32)
        if (!(cup->uft90)) {
                errn    = _rnl90to77(css, cup, namlist, stck, errf, endf);
                goto finalization;

        }
#endif
skiprec:
        while (cup->ulinecnt == 0) {
                errn    = _nlrd_fillrec(css, cup);
                if (errn != 0)
                        goto err_eof;
        }
rrd:
        do {
                CMTE_MAINGT(c)
        } while (ISBLANK(c));
        if (c != '&' && c != '$') {
                /* irix f77 and f90, and 'assign -Y on' skip an input
                 * record when the first part of the record is not an
                 * ampersand or dollar sign delimiting a namelist
                 * group name.
                 */
                if ((cup->ufnl_skip != 0) ||
                    (cup->ufcompat == AS_IRIX_F77) ||
                    (cup->ufcompat == AS_IRIX_F90)) {
                        cup->ulinecnt   = 0;
                        goto skiprec;
                }
                errn    = FENLONEC;
                ERROR0(errf, css, errn);
        }
        /* save beginning character to check against ending char */
        endnmlchar      = c;

        /* get first character of namelist group name from input record */
        MAINGT(c);
        /* and get namelist group name from input record */
        errn    = _getname(css, cup, buf, &c);
        if (errn != 0)
                goto err_eof;
        /* convert group name to uppercase */
        _cnvrt_toupper(buf);

        assert ( (cup != NULL));
        rcount  = namlist->icount;      /* number of name table entries */
        rptr    = _fcdtocp(namlist->group_name); /* ptr to groupname    */
        rlen    = _fcdlen(namlist->group_name); /* len of groupname     */
        nlvar   = namlist->goli;                /* group object ptr     */

        if (strncmp(rptr,buf,rlen)) {
                if (cup->ufnl_skip == 0) {
                        errn    = FENLIVGP;
                        ERROR1(errf, css, errn, buf);
                }

                /* Skip unmatched namelist group. The slash terminates
                 * the f90 namelist input.
                 */
                while (c != '/') {

                        /* check to see if old namelist ending (&END)
                         * is present rather than the slash in f90.
                         */
                        if (c == '&' || c == '$') {

                                /* check to see that beginning namelist
                                 * group name delimiter matches the
                                 * ending delimiter before END.
                                 */
                                if (c == endnmlchar) {

                                        /* get END, if present. */
                                        do {
                                                MAINGT(c);
                                        } while (!ISBLANK(c));
                                        goto rrd;
                                }
                        }

                        /* check for delimited character string */
                        if ((c == '\'') || (c == '"')) {
                                char    qcr;
                                qcr     = c;
rqte:
                                do {
                                        MAINGT(c);
                                } while (c != qcr);
                                MAINGT(c);
                                /* embedded double quote? */
                                if (c == qcr)
                                        goto rqte;
                        } else {
                                CMTE_MAINGT(c);
                        }
                }

                goto rrd;
        }
        /*
         *      This is the correct namelist group name.  Process the
         *      input record. Read until the input record or records
         *      until the terminating character is found.  This is a
         *      slash or ampersand or MRNLDELIM.
         */
        while (c != '/') {
                int     sepcnt;
                if (c == '&' || c == '$') {
                        if (c != endnmlchar) {
                                /* begin character did not match end char */
                                errn    = FENLONEC;
                                ERROR0(errf, css, errn);
                        }
                        else
                                goto finalization;
                }
                /* get group_object_name from input record */
                errn    = _getname(css, cup, buf, &c);
                if (errn != 0)
                        goto err_eof;
                _cnvrt_toupper(buf);
                /* find matching group_object_name from namelist table */
                if (!(fdvar = _findname(buf, nlvar, rcount))) {
                        if (strlen(buf) > 0) {
                                /* An objectlistname in input record */
                                errn    = FENLNREC;
                                ERROR1(errf, css, errn, buf);
                        }
                        else {
                                /* No object list name in input record */
                                errn    = 0; /* empty variable entry */
                                goto finalization;
                        }
                }
                /*
                 * c is a '%' to indicate a structure component follows.
                 * Look for a component name to follow the percent sign.
                 */
                while (c == '%') {
                        nmlist_struclist_t *nlstruc; /* nmlist struc entry */
                        unsigned        scount;
                        nmlist_goli_t   *vaddr;
                        assert ((fdvar->valtype == IO_STRUC_A) || 
                                (fdvar->valtype == IO_STRUC_S));
                        if ((fdvar->valtype == IO_SCALAR) ||
                            (fdvar->valtype == IO_DOPEVEC)) {
                                /* structure indicator in object name
                                 * that is not a structure
                                 */
                                errn    = FENLNREC;
                                ERROR1(errf, css, errn, buf);
                        }
                        /* input variable is a structure */
                        nlstruc = fdvar->goli_addr.sptr; /* ptr to struc */
                        vaddr   = nlstruc->goli;        /* ptr to list */
                        scount  = nlstruc->structlen;   /* number entries */
                        /*
                         * Get the namelist object list name from the
                         * input record
                         */
                        MAINGT(c);
                        errn    = _getname(css, cup, buf, &c);
                        if (errn != 0)
                                goto err_eof;
                        _cnvrt_toupper(buf);
                        /*
                         * Find the matching namelist object list name
                         * for the object list name in the input record
                         */
                        if (!(fdvar = _findname(buf, vaddr, scount))) {
                                if (strlen(buf) > 0) {
                                        /* objectlistname in input record */
                                        errn    = FENLNREC;
                                        ERROR1(errf, css, errn, buf);
                                }
                                else {
                                        /* No name in input record */
                                        errn    = 0; /* empty variable entry */
                                        goto finalization;
                                }
                        }
                }
                /* we're positioned just after the object name
                 * so get following value(s)
                 */
                errn    = _getnlval(css, fdvar, &c, cup);
                if (errn != 0)
                        goto err_eof;
                sepcnt  = 0;
                for ( ; ; ) {
                        if (!(ISBLANK(c))) {
                                if ((c == ',') && (sepcnt == 0)) {
                                        /* skip separator */
                                        sepcnt++;
                                }
                                else
                                        break;
                        }
                        CMTE_MAINGT(c);
                }
        }

/***************************************************************************
 *      Statement Finalization Section
 ***************************************************************************/
finalization:

        /* Set IOSTAT variable to 0 if no error, >0 error code otherwise */
        if (cilist->iostat_spec != NULL)
                *cilist->iostat_spec    = errn;

        /* End the Beguine */
        STMT_END(cup, TF_READ, NULL, css);      /* Unlock unit */

        /* Return proper status */
        if (errn == 0)
                return(IO_OKAY);
        else if (errn < 0) {
                cup->pnonadv    = 0;    /* no current record if EOF */
                return(IO_END);
        }
        return(IO_ERR);
err_eof:
        /* err and eof handling */
        if(errn < 0) {
                ENDD(endf, css, FERDPEOF);
        } else if (errn == FENLSTRN || errn == FENLSTRG ||
                   errn == FENLSUBD || errn == FENLSUBN ||
                   errn == FENLSUBS || errn == FENLLGNM ||
                   errn == FENLUNKI || errn == FENLUNKN) {
                        ERROR1(errf, css, errn, buf);
        } else {
                ERROR0(errf, css, errn);
        }
        goto finalization;
}

/* _nlrd_fillrec - namelist read of one record from a file
 *      returns         0 - successful
 *                      EOF - end of file
 *                      ERR - error was encountered
 *                      cup->uend is set if EOF encountered
 */

static int
_nlrd_fillrec(FIOSPTR css, unit *cup)
{
        register int    errn;

        errn    = css->u.fmt.endrec(css, cup, 1);

        return(errn);
}

/*
 *      _getname - Get variable name or group name
 *
 *      On entry:
 *              - Positioned to a name possibly preceded by blanks
 *      On exit:
 *              - 0 if successful
 *                EOF if end of file read
 *                > 0 if other error (errno will be set)
 *              - *cup->ulineptr is record position after the name.
 *              - *lastc contains the last character read.
 *      In looking for the name, we stop when we see a space, '=',
 *      '(', '%', or ending namelist delimiter ('&' or '$').
 */

static int
_getname(FIOSPTR css, unit *cup, char *s, char *lastc)
{
        char    *p, c;
        int     n, errn;
        errn    = 0;
        n       = MAXNAML + 5; /* real*16 input can be 34 characters long */
        p       = s;
        c       = *lastc;
        /*
         * Names cannot have embedded blanks.  In cf77 compatibility mode,
         * a comment can immediately follow the name and terminates it.
         * An unknown comment character may be nonstandard for Fortran 90.
         * Allow the terminating ampersand for simpler non-f90 namelist
         * compatibility.
         */

        while (ISBLANK(c))
                CMTE_SUBGTC(c);
        while (!(ISBLANK(c)) && c != '(' && c != '=' && c != '/' &&
                         c != '&' && c != '%' && c != '$') {
                *p++    = c;
                CMTE_SUBGTCNOEOR(c);
                if (n-- == 0) {
                        errn    = FENLLGNM;     /* name too long */
                        p--;
                        break;
                }
        }
        *lastc  = c;
        *p      = '\0';
        return (errn);
}

/*
 * _findname - find variable name in list of nmlist_goli_t entries
 *              of namelist table
 * On entry:
 *      - lastc points to character following name in input buffer.
 * Returns:
 *      pointer to matching object list entry
 *      NULL if variable name was not found.
 */

static nmlist_goli_t
*_findname(char *key, nmlist_goli_t *nlvar, unsigned countitm)
{
        char            *varptr;
        unsigned        varlen;
        nmlist_goli_t   *newitem;
        int             cnt, lcnt;
        newitem = nlvar;
        cnt     = countitm;
        lcnt    = strlen(key);
        while (cnt--) {
                varptr  = _fcdtocp(newitem->goli_name);
                varlen  = _fcdlen(newitem->goli_name);
                if ((varlen == lcnt) && (!strncmp(key, varptr, lcnt)))
                        return (newitem);
                else {
                        /* cannot do this in a switch since some word32
                         * systems do not have the extra padding.
                         */
#if (defined(__mips) && (_MIPS_SZLONG == 32)) || (defined(_LITTLE_ENDIAN) && !defined(_LP64))
                        newitem = (nmlist_goli_t*)((long *)newitem +
                                3 + (sizeof(_fcd))/(sizeof(long)));
#else
                        newitem = (nmlist_goli_t*)((long *)newitem +
                                2 + (sizeof(_fcd))/(sizeof(long)));
#endif
                }
        }
        return (NULL);
}

/* _getnlval - get values for namelist io
 *
 * On entry:
 *      - positioned after variable name
 *      - lastc contains the character following the name
 * On exit:
 *      - *lastc contains the character following the value
 *      - cup->ulineptr is pointing to the character following lastc
 *      - returns: 0 if successful
 *                -value if EOF detected
 *                > 0 if error detected
 */

static int
_getnlval(FIOSPTR css, nmlist_goli_t *nlvar, char *lastc, unit *cup)
{
        long            cntp    = 0;
        int             i;
        int             ndim    = 0;
        int             encnt   = 0;
        int             icnt    = 0;
        long            strbegend[3];
        char            *cp;
        char            c;
        long            vaddr;
        long            errn    = 0;
        struct DvDimen  dimnsn[MAXDIM];
        struct DvDimen  *dvdn = dimnsn;
        /* find offset if indexed array */
        /* clear array element, section, and substring information */
        for (i=0; i < MAXDIM; i++) {
                dimnsn[i].stride_mult   = 0;
                dimnsn[i].extent        = 0;
                dimnsn[i].low_bound     = 0;
        }
        strbegend[0]    = -1;   /* flag indicating string */
        strbegend[1]    = -1;   /* string begin         */
        strbegend[2]    = -1;   /* string end           */

        switch (nlvar->valtype) {
        case IO_SCALAR:
        {
                nmlist_scalar_t *nlscalar; /* nmlist scalar entry */
                unsigned long   elsize;
                unsigned int    int_len;
                void            *vaddr;
                ftype_t         type;   /* fortran data type */
                nlscalar        = nlvar->goli_addr.ptr; /* ptr to scalar */
                type            = nlscalar->tinfo.type;
                int_len         = nlscalar->tinfo.int_len;
                /* Assertions */
                assert (type >= DVTYPE_TYPELESS && type <= DVTYPE_ASCII);
                assert(nlscalar->tinfo.int_len > 0 );
                if ((type != DVTYPE_ASCII) && (*lastc == '(')) {
                        errn    = FENLUNKI;
                        break;
                }
                if (type == DVTYPE_ASCII)
                        strbegend[0]    = 0;
                if (*lastc == '(') {
                        errn    = _indx_nl(css, cup, dvdn, &ndim, strbegend,
                                &encnt, &icnt, 0);
                        if (errn != 0) {
                                if (errn == FENLSUBS)
                                        errn    = FENLSTRG;
                                else if (errn == FENLSUBN)
                                        errn    = FENLSTRN;
                                break;
                        }
                } else {
                        while (ISBLANK(*lastc)) {
                                CMTE_SUBGTC(*lastc);
                        }
                        /* namelist is terminated by slash, ampersand, or $ */
                        if ((*lastc == '/') || (*lastc == '&') || (*lastc == '$')) {
                                errn    = 0;
                                break;
                        }
                        /* Not a value here. */
                        if (*lastc != '=') {
                                errn    = FENLNOVL;
                                break;
                        }
                }

                /* Currently positioned after the '=' sign, but lastc is
                 * pointing at the '=' sign.  Update lastc for nlread and
                 * compute:
                 * cntp = number of array elements to be read
                 *      (1 if not an array).
                 * elsize = size of a variable or array element
                 *      (words for nonchar, bytes for char).
                 * vaddr = target address for input value.  For character,
                 *      this is a Fortran character descriptor.
                 */
                CMTE_SUBGTC(*lastc);
                if (type == DVTYPE_ASCII) {
                        char    *wptr;
                        const int bytesperchar = 1;
                        long    begt    = strbegend[1];
                        long    endt    = strbegend[2];
                        wptr    = _fcdtocp(nlscalar->scal_addr.charptr);
                        elsize  = _fcdlen(nlscalar->scal_addr.charptr);
                        elsize  = elsize * bytesperchar;
                        /* check for character substrings in input record */
                        if (strbegend[0] > 0) {
                                if (begt < 1 )
                                        begt    = 1;
                                else if (begt > elsize) {
                                        errn    = FENLUNKN;
                                        break;
                                }
                                if (endt < 1 )
                                        endt    = elsize;
                                else if ((endt > elsize) || (endt < begt)) {
                                        errn    = FENLUNKN;
                                        break;
                                }
                                wptr    = wptr + (begt - 1);
                                elsize  = (endt - begt) + 1;
                        }
                        vaddr   = wptr;
                }
                else {
                        vaddr   = nlscalar->scal_addr.ptr;
                        elsize  = int_len >> 3;
                }
                c       = *lastc;
                cntp    = 1;
                errn    = _nlread(css, type, cup, vaddr, elsize, cntp, 0, &c);
                *lastc  = c;
                break;
        }
        case IO_DOPEVEC:
        {
                DopeVectorType  *nldv;
                ftype_t         type;   /* fortran data type */
                nldv    = nlvar->goli_addr.dv; /* ptr to dope vector */
                /* Assertions */
                assert ( nldv != NULL );
                assert ( nldv->type_lens.int_len > 0 );
                type    = nldv->type_lens.type;
                if (type == DVTYPE_ASCII)
                        strbegend[0]    = 0;
                for (i=0; i < nldv->n_dim; i++) {
                        dimnsn[i].stride_mult   = nldv->dimension[i].stride_mult;
                        dimnsn[i].extent        = nldv->dimension[i].extent;
                        dimnsn[i].low_bound     = nldv->dimension[i].low_bound;
                }
                if (*lastc == '(') {
                        errn    = _indx_nl(css, cup, dvdn, &ndim, strbegend,
                                &encnt, &icnt, 1);
                        if (errn != 0)
                                break;
                } else {
                        while (ISBLANK(*lastc)) {
                                CMTE_SUBGTC(*lastc);
                        }
                        /* namelist is terminated by slash, ampersand, or $ */
                        if ((*lastc == '/') || (*lastc == '&') || (*lastc == '$')) {
                                errn    = 0;
                                break;
                        }
                        /* Not a value or structure qualification here. */
                        if (*lastc != '=') {
                                errn    = FENLNOVL;
                                break;
                        }
                }

                /* Currently positioned after the '=' sign, but lastc is
                 * pointing at the '=' sign.  Update lastc for nlread and
                 * compute:
                 * cntp = number of array elements to be read
                 *      (1 if not an array).
                 * elsize = size of a variable or array element
                 *      (words for nonchar, bytes for char).
                 * vaddr = target address for input value.  For character,
                 *      this is a Fortran character descriptor.
                 */
                CMTE_SUBGTC(*lastc);
                if ((ndim != 0) && (ndim != nldv->n_dim)) {
                        errn    = FENLBNDY;
                        break;
                }

                /* call nlread directly for array elements. */
                if (ndim != 0) {
                        struct DvDimen  *dvdm = nldv->dimension;
                        void            *vaddr;
                        long            extent = 1;
                        long            elsize;
                        long            mult = 1;
                        long            offs = 0;
                        long            incrmt;
                        int             int_len = nldv->type_lens.int_len;
                        register long   nc;
                        for (nc = 0; nc < nldv->n_dim; nc++) {
                                extent *= dvdm[nc].extent;
                        }

                        /* array element. */
                        if (encnt == 0 && icnt == 0) {
                                offs    = dimnsn[0].low_bound - (dvdm[0].low_bound);
                                incrmt  = 1;
                                for (nc = 1; nc < ndim; nc++) {
                                        mult    = mult * (dvdm[nc-1].extent);
                                        offs    = offs +
                                               ((dimnsn[nc].low_bound -
                                           dvdm[nc].low_bound) * mult);
                                }
                                extent  = extent - offs;
                                if (type == DVTYPE_ASCII) {
                                        char            *wptr;
                                        const int        bytesperchar = 1;
                                        long    begt = strbegend[1];
                                        long    endt = strbegend[2];
                                        wptr =
                                          _fcdtocp(nldv->base_addr.charptr);
                                        elsize  =
                                           _fcdlen(nldv->base_addr.charptr);
                                        elsize  = elsize * bytesperchar;
                                        /* check for character
                                         * substrings in input record.
                                         */
                                        wptr += offs * elsize;

                                        if (strbegend[0] > 0) {
                                                if (begt < 1 )
                                                        begt    = 1;
                                                else if (begt > elsize) {
                                                        errn    = FENLUNKN;
                                                        break;
                                                }
                                                if (endt < 1 )
                                                        endt    = elsize;
                                                else if ((endt >
                                                        elsize) ||
                                                        (endt < begt)) {
                                                        errn    = FENLUNKN;
                                                        break;
                                                }
                                                wptr    = wptr + (begt - 1);
                                                elsize  = (endt - begt) + 1;
                                        }

                                        vaddr   = wptr;
                                } else {
                                        bcont   *iwptr;
                                        iwptr   = (bcont*)nldv->base_addr.a.ptr;
                                        elsize  = int_len >> 3;
                                        iwptr  += offs * (elsize /
                                                (sizeof(bcont)));
                                        vaddr   = iwptr;
                                }
                                /* Assertions */
                                assert ( elsize > 0 && extent > 0 );
                                c       = *lastc;
                                cntp    = extent;
                                errn    = _nlread(css, type, cup, vaddr,
                                                elsize, cntp, incrmt, &c);
                                *lastc  = c;
                        } else {
                                for (nc = 0; nc < ndim; nc++) {
                                        if (dimnsn[nc].extent !=
                                                dvdm[nc].extent) {
                                                if (dimnsn[nc].extent >
                                                    dvdm[nc].extent) {
                                                        return(FENLBNDY);
                                                }
                                        }
                                        if (dimnsn[nc].stride_mult !=
                                            dvdm[nc].stride_mult) {
                                                dimnsn[nc].stride_mult =
                                                  dimnsn[nc].stride_mult *
                                                  dvdm[nc].stride_mult;
                                        }
                                }
                                c       = *lastc;
                                errn    = _nl_stride_dv(css, cup, nldv,
                                                dvdn, &c, strbegend);
                                *lastc  = c;
                        }
                        
                /* call nlread directly for noncharacter whole arrays */
                } else if (type != DVTYPE_ASCII) {
                        int             n_dm = nldv->n_dim;
                        unsigned long   elsize = nldv->type_lens.int_len >> 3;
                        unsigned long   extent = nldv->dimension[0].extent;
                        struct DvDimen  *dvdm = nldv->dimension;
                        long            incrmt;
        
                        if (n_dm != 1) {
                                register long   nc;
                                if (n_dm == 2) {
                                        if (dvdm[0].stride_mult * extent !=
                                            dvdm[1].stride_mult)
                                                goto gen_dv_process;
                                        extent *= dvdm[1].extent;
                                } else if (n_dm == 0) {
                                        extent  = 1;
                                } else {
                                        for (nc = 0; nc < (n_dm-1); nc++) {
                                                register int st =
                                                   dvdm[nc].stride_mult;
                                                register int ex =
                                                   dvdm[nc].extent;
                                                if ( (st * ex) !=
                                                   dvdm[nc+1].stride_mult)
                                                        goto gen_dv_process;
                                                extent *= dvdm[nc+1].extent;
                                        }
                                }
                        }
                        if (extent > 1) {
                                register long sm =
                                        nldv->dimension[0].stride_mult;
                                if (sm * (signed)SMSCALE(nldv) == elsize)
                                        incrmt  = 1;
                                else {
                                        int bytes_per_sm        = sm *
                                                (signed)SMSCALE(nldv);
                                        incrmt  = bytes_per_sm / elsize;
                                        /* if stride not a multiple of size... */
                                        if (elsize * incrmt != bytes_per_sm)
                                                goto gen_dv_process;
                                }
                        } else
                                incrmt  = 0;

                        /* Assertions */
                        assert ( elsize > 0 && extent > 0 );
                        c       = *lastc;
                        errn    = _nlread(css, type, cup,
                                        nldv->base_addr.a.ptr, elsize, extent,
                                        incrmt, &c);
                        *lastc  = c;
                } else {
gen_dv_process:
                        c       = *lastc;
                        errn    = _nl_stride_dv(css, cup, nldv, 0, &c, strbegend);
                        *lastc  = c;
                }
                break;
        }
        case IO_STRUC_A:
        {
                nmlist_struclist_t *nlstruc; /* nmlist struc entry */
                unsigned long   elsize;
                unsigned int    int_len;
                unsigned int    scount;
                char            *cp;
                nmlist_goli_t   *vaddr;
                ftype_t         type;   /* fortran data type */
                int             byt = 0; /* scalar struct has 0 offset */
                nlstruc = nlvar->goli_addr.sptr; /* ptr to structure. */
                vaddr   = nlstruc->goli;                /* ptr to list. */
                scount  = nlstruc->structlen;   /* number of entries. */
                if (*lastc == '(') {
                        /* This is not an array or substring - err */
                        errn    = FENLUNKI;
                        break;
                } else {
                        while (ISBLANK(*lastc)) {
                                CMTE_SUBGTC(*lastc);
                        }
                        /* namelist terminated by slash, ampersand, or $ */
                        if ((*lastc == '/') || (*lastc == '&') ||
                            (*lastc == '$')) {
                                errn    = 0;
                                break;
                        }
                        /* Check for structure qualification. */
                        if (*lastc == '%') {
                                errn    = FENLIOER;
                                break;
                        } else if (*lastc != '=') {
                                errn    = FENLNOVL;
                                break;
                        }
                }

                /* Currently positioned after the '=' sign, but lastc is
                 * pointing at the '=' sign.  Update lastc for nlread and
                 * compute:
                 * cntp = number of array elements to be read
                 *      (1 if not an array).
                 * elsize = size of a variable or array element
                 *      (words for nonchar, bytes for char).
                 * vaddr = target address for input value.  For character,
                 *      this is a Fortran character descriptor.
                 */
                CMTE_SUBGTC(*lastc);
                cp      = lastc;
                errn    = _nlrdent(css, cup, vaddr, scount, cp, byt);
                *lastc  = *cp;
                break;
        }
        case IO_STRUC_S:
        {
                nmlist_struclist_t *nlstruc; /* nmlist struc entry */
                unsigned long   elsize;
                unsigned int    int_len;
                unsigned int    scount;
                int             nc;
                long            ic;
                char            *cp;
                long            extnt = 1;
                nmlist_goli_t   *vaddr;
                DopeVectorType  *nlsdv;
                ftype_t         type;   /* fortran data type */
                int             byt = 0; /* arraystruct offset in bytes */
                unsigned int    compflag = 0;
                nmlist_goli_t   *fdvar;
                char            abuf[MAXNAML + 5];
                nlstruc = nlvar->goli_addr.sptr; /* ptr to struc */

                /* number of entries */
                scount  = nlstruc->structlen;

                /* ptr to list */
                vaddr   = nlstruc->goli;
                fdvar   = nlvar;

                /* ptr to dope vector */
                nlsdv   = nlstruc->struc_addr.dv;
                elsize  = nlsdv->base_addr.a.el_len;
                type    = nlsdv->type_lens.type;

                for (i=0; i < nlsdv->n_dim; i++) {
                        dimnsn[i].stride_mult   = nlsdv->dimension[i].stride_mult;
                        dimnsn[i].extent        = nlsdv->dimension[i].extent;
                        dimnsn[i].low_bound     = nlsdv->dimension[i].low_bound;
                }
                if (*lastc == '(') {
                        errn    = _indx_nl(css, cup, dvdn, &ndim, strbegend,
                                &encnt, &icnt, 1);
                        if (errn != 0)
                                break;
                } else {
                        while (ISBLANK(*lastc)) {
                                CMTE_SUBGTC(*lastc);
                        }
                        /* namelist terminated by slash, ampersand, or $ */
                        if ((*lastc == '/') || (*lastc == '&') ||
                            (*lastc == '$')) {
                                errn    = 0;
                                break;
                        }
                }

                /* Currently positioned after the '=' sign, but lastc is
                 * pointing at the '=' sign.  Update lastc for nlread and
                 * compute:
                 * cntp = number of array elements to be read
                 *      (1 if not an array).
                 * elsize = size of a variable or array element
                 *      (words for nonchar, bytes for char).
                 * vaddr = target address for input value.  For character,
                 *      this is a Fortran character descriptor.
                 * 
                 * byt is used when the structure is an array of
                 * structures.  Each component must add an offset to
                 * its base address after the first array element.
                 * With derived types, the bits must be changed to bytes.
                 */
                CMTE_SUBGTC(*lastc);
                if ((ndim != 0) && (ndim != nlsdv->n_dim)) {
                        errn    = FENLBNDY;
                        break;
                }
                /* Check for structure qualification. */
                while (*lastc == '%') {
                        compflag++;
                        nlstruc = fdvar->goli_addr.sptr;
                        vaddr   = nlstruc->goli;
                        scount  = nlstruc->structlen;
                        /* Check for structure qualification. */
                        SUBGTC(*lastc);
                        errn    = _getname(css, cup, abuf, lastc);
                        if (errn != 0)
                                break;
                        _cnvrt_toupper(abuf);
                        /* find matching namelist object list
                        * name in input record
                        */
                        if (!(fdvar = _findname(abuf, vaddr, scount))) {
                                if (strlen(abuf) > 0) {
                                /* objectlistname in record */
                                        errn    = FENLNREC;
                                        break;
                                } else {
                                /* no name in record. May be
                                 * empty record. Quit process.
                                 */
                                errn    = 0;
                                break;
                                }
                        } else
                                vaddr   = fdvar;
                        while (ISBLANK(*lastc)) {
                                CMTE_SUBGTC(*lastc);
                        }
                        if (*lastc != '=') {
                                errn    = FENLNOVL;
                                break;
                        }
                        CMTE_SUBGTC(*lastc);
                }
                if (ndim != 0) {
                        struct DvDimen  *dvdm = nlsdv->dimension;
                        long            mult = 1;
                        long            offs = 0;
                        register long   nc;
                        for (nc = 0; nc < nlsdv->n_dim; nc++)
                                extnt *= nlsdv->dimension[nc].extent;
                        /* array element. */
                        if (encnt == 0 && icnt == 0) {
                                offs    = dimnsn[0].low_bound - (dvdm[0].low_bound);
                                for (nc = 1; nc < ndim; nc++) {
                                        mult    = mult * (dvdm[nc-1].extent);
                                        offs    = offs +
                                           ((dimnsn[nc].low_bound -
                                           dvdm[nc].low_bound) * mult); 
                                }
                                extnt   = extnt - offs;
                                elsize  = elsize >> 3;
                                byt     = offs * elsize;
                                assert ( elsize > 0 && extnt > 0);
                                cp      = lastc;
                                if (compflag)
                                        scount  = 1;
                                errn    = _nlrdent(css, cup, vaddr, scount,
                                                cp, byt);
                                *lastc  = *cp;
                        } else {
                                for (nc = 0; nc < ndim; nc++) {
                                        if (dimnsn[nc].extent !=
                                            dvdm[nc].extent) {
                                                if (dimnsn[nc].extent >
                                                   dvdm[nc].extent) {
                                                        return(FENLBNDY);
                                                }
                                        }
                                        if (dimnsn[nc].stride_mult !=
                                           dvdm[nc].stride_mult) {
                                                dimnsn[nc].stride_mult =
                                                   dimnsn[nc].stride_mult *
                                                   dvdm[nc].stride_mult;
                                        }
                                }
                                cp      = lastc;
                                if (compflag)
                                        scount  = 1;
                                errn    = _nl_strd_derv(css, cup, nlsdv, dvdn,
                                                cp, vaddr, scount, byt);
                                *lastc  = *cp;
                        }
                } else {
                        cp      = lastc;
                        errn    = _nl_strd_derv(css, cup, nlsdv, 0, cp,
                                        vaddr, scount, byt);
                        *lastc  = *cp;
                }
                break;
        }
        default:
                 errn   = FEINTUNK;
        }
        return(errn);
}

/*      _nlread - calls _nexdata to get the next value and stores the
 *              result in the namelist object entry.
 *      On Entry - cup_ulineptr points to the first character following the
 *              value.
 *      On Exit - lastc  will contain the first nonblank, nonseparator
 *              character following the value.
 */

static int
_nlread(FIOSPTR css, ftype_t type, unit *cup, void *ptr, long elsize,
        int cntp, int incrm, char *lastc)
{
        long            ss, ncntp;
        long            stat;
        char            c;
        void            *vaddr;
        long            errn = 0;
        int             lcount;         /* repeat count for values */
        long            lval[9];        /* convert space */
        bcont           *sval;
        int             nullvlu;
        c       = *lastc;
        ncntp   = cntp;
        vaddr   = ptr;
        nullvlu = 0;

        while (ncntp > 0) {
                errn    = _nexdata(css, type, vaddr, ncntp, 1, c, cup,
                                lval, &lcount, elsize, &nullvlu);
                if (errn != 0)
                        return(errn);
                else {
                        if (nullvlu == 2) {
                                lcount  = 0;
                                ncntp   = 0;
                        }
                }
                if (lcount > ncntp) {
                        errn    = FENLTOOM;
                        return(errn);
                }
                if (type == DVTYPE_ASCII) {
                        char    *wptr;
                        wptr    = vaddr;
                        /* character data already stored, adjust
                         * ptr and count only.
                         */
                        ncntp   = ncntp - lcount;
                        wptr    = wptr + (lcount * elsize);
                        vaddr   = wptr;
                }
                else {
                        int move;
                        int *iptr;
                        int ix, lim;
                        bcont *siptr;
                        move    = MIN(ncntp,lcount);
                        lim     = elsize/(sizeof(bcont));
                        siptr   = (bcont*) vaddr;
                        /* move what's needed from data group */
                        while (move != 0) {
                                sval    = (bcont*) lval;
                                /* do not move null values */
                                if (!nullvlu) {
                                        for (ix=0; ix < lim; ix++) {
                                                *siptr  = *sval;
                                                siptr++;
                                                sval++;
                                        }
                                } else
                                        siptr   = siptr + lim;
                                vaddr   = siptr;
                                move--;
                                ncntp--;
                                lcount--;
                        }
                }
                do {
                        CMTE_SUBGTC(*lastc);
                } while (ISBLANK(*lastc));
                if (*lastc == ',') {
                        do {
                                CMTE_SUBGTC(*lastc);
                        } while (ISBLANK(*lastc));
                }
        c       = *lastc;
        }
        return(0);
}

/*      _indx_nl        compute the dimension information of an
 *                      indexed array in the input record.
 *      On entry:
 *              _ positioned just after the '('
 *      On exit:
 *              - returns:      0 on success
 *                              -value on eof
 *              - positioned just after the '='
 *              - if % occurred, the scan is backed up one
 *              - the lastc argument is not changed
 */

static int
_indx_nl(
        FIOSPTR css, unit *cup, struct DvDimen *dvdn, int *ndima,
        long strbegend[3],int *encnt, int *icnt, int arryflag)
{
        long    mode, ss;
        long    offs, mult;
        char    c;
        int     i, j, ir1, en1;
        long    dummy;
        int     errn = 0;
        long    stat;
        long    field_width;
        long    *field_begin;
        long    *field_end;
        long    tempbuf[2];
        en1     = 0;
        ir1     = 0;
        if (arryflag) {
                for (i = 0; i < MAXDIMS; ) {
                        long    dummy;
                        /* no comments in namelist input here and
                         * skip leading blanks here only. 
                         */
                        do {
                                SUBGTC(c);
                        } while (ISBLANK(c));
                        /* Was end of subscripts reached in input record */
                        if (c == ')')
                                break;
                        cup->ulinecnt++;
                        cup->ulineptr--;

                        /* Get the low_bound subscript information first */
                        GETSECTION(c);
                        if (field_width == 0)
                                goto indxgetext;
                        /* pass field_end + 1 */
                        field_end++;
                        tempbuf[0]      = 0;
                        tempbuf[1]      = 0;
                        mode            = 0;
                        (void) _iu2s(field_begin, &field_width,
                                &field_end, &mode, tempbuf, &stat,
                                &dummy, &dummy);
                        if(stat < 0) {
                                errn    = FENLSUBS;
                                return(errn);
                        }
                        dvdn[i].low_bound       = *((_f_int8 *)tempbuf);
indxgetext:
                        /* point beyond subscript or lowbound. */
                        cup->ulineptr   = field_begin + field_width;
                        cup->ulinecnt   = cup->ulinecnt - field_width;

                        /* Get extent subscript information */
                        if (c == ':') {
                                /* update ulineptr */
                                SUBGTC(c);
                                GETSECTION(c);
                                if (field_width == 0)
                                        goto indxgetinc;
                                /* pass field_end + 1 */
                                field_end++;
                                tempbuf[0]      = 0;
                                tempbuf[1]      = 0;
                                mode            = 0;
                                (void) _iu2s(field_begin, &field_width,
                                        &field_end, &mode, tempbuf, &stat,
                                        &dummy, &dummy);
                                if(stat < 0) {
                                        errn    = FENLSUBS;
                                        return(errn);
                                }
                                /* calculate extent from upper bound
                                 * (upperbound - lowerbound) + 1
                                 */
                                dvdn[i].extent  = (*((_f_int8 *)tempbuf) -
                                                   dvdn[i].low_bound) + 1;
                                en1++;
indxgetinc:
                                /* point beyond subscript extent. */
                                cup->ulineptr   = field_begin + field_width;
                                cup->ulinecnt   = cup->ulinecnt - field_width;

                                /* Get stride_mult subscript information */
                                if (c == ':') {
                                        /* update ulineptr */
                                        SUBGTC(c);
                                        GETSECTION(c);
                                        if (field_width == 0)
                                                goto indxforloop;
                                        /* pass field_end + 1 */
                                        field_end++;
                                        tempbuf[0]      = 0;
                                        tempbuf[1]      = 0;
                                        mode            = 0;
                                        (void) _iu2s(field_begin,
                                                &field_width, &field_end,
                                                &mode, tempbuf, &stat,
                                                &dummy, &dummy);
                                        if(stat < 0) {
                                                errn    = FENLSUBS;
                                                return(errn);
                                        }
                                        dvdn[i].stride_mult     = *((_f_int8 *)tempbuf);
                                        ir1++;
indxforloop:
                                        /* point beyond subscript stride_mult. */
                                        cup->ulineptr   = field_begin + field_width;
                                        cup->ulinecnt   = cup->ulinecnt - field_width;
                                }
                        }
                        /* increment the number of subscripts */
                        i++;
                        do {
                                SUBGTC(c);      /* get to ',' or ')' */
                        } while (ISBLANK(c));   /* NO EOR allowed here */
                        /* check for end of subscripts */
                        if (c == ')')
                                break;
                        if (c != ',') {
                                errn    = FENLSUBD;     /* Not a comma */
                                return(errn);
                        }
                }
                *ndima  = i;
                *encnt  = en1;
                *icnt   = ir1;
                if (i == 0) {
                        errn    = FENLSUBN;     /* null index */
                        return(errn);
                }
        }
        if (strbegend[0] == 0) {
                j       = 0;
                if (arryflag) {
                        SUBGTC(c);
                } else
                        c       = '(';
                /* Check for substring information after array element */
                if (c == '(') {
                        /* skip leading blanks in input here */
                        do {
                                SUBGTC(c);
                        } while (ISBLANK(c));
                        /* End of subscripts found in input record? */
                        if (c == ')') {
                                errn    = FENLSTRN;     /* null index */
                                return(errn);
                        }
                        cup->ulinecnt++;
                        cup->ulineptr--;
                        GETSECTION(c);
                        if (field_width == 0)
                                goto indxstrend;
                        /* pass field_end + 1 */
                        field_end++;
                        tempbuf[0]      = 0;
                        tempbuf[1]      = 0;
                        mode            = 0;
                        (void) _iu2s(field_begin, &field_width, &field_end,
                                &mode, tempbuf, &stat, &dummy, &dummy);
                        if(stat < 0) {
                                errn    = FENLSTRG;
                                return(errn);
                        }
                        strbegend[1]    = *((_f_int8 *)tempbuf);
                        j++;
indxstrend:
                        /* point beyond colon. */
                        cup->ulineptr   = field_begin + field_width;
                        cup->ulinecnt   = cup->ulinecnt - field_width;
                        if (c == ':') {
                                /* update ulineptr */
                                SUBGTC(c);
                                /* skip leading blanks in input here */
                                do {
                                        SUBGTC(c);
                                } while (ISBLANK(c));
                                /* End of subscripts found in input rec */
                                if (c == ')')
                                        goto indxstrout;
                                cup->ulinecnt++;
                                cup->ulineptr--;
                                GETSECTION(c);
                                if (field_width == 0)
                                        goto indxstrdon;
                                /* pass field_end + 1 */
                                field_end++;
                                tempbuf[0]      = 0;
                                tempbuf[1]      = 0;
                                mode            = 0;
                                (void) _iu2s(field_begin, &field_width,
                                        &field_end, &mode, tempbuf,
                                        &stat, &dummy, &dummy);
                                if(stat < 0) {
                                        errn    = FENLSTRG;
                                        return(errn);
                                }
                                strbegend[2]    = *((_f_int8 *)tempbuf);
                                j++;
indxstrdon:
                                /* point to right paren? */
                                cup->ulineptr   = field_begin + field_width;
                                cup->ulinecnt   = cup->ulinecnt - field_width;
                        }
indxstrout:
                        strbegend[0]    = j;
                }
        }
        /*
         * Look for the equal sign or the structure qualification
         * character
         */
        while (!(c == '=') && !(c == '%')) {
                SUBGTC(c);
        }
        if (c == '%') {
                cup->ulineptr--;
                cup->ulinecnt++;
        }
        return(errn);
}

/* Converts the string in buf to upper case letters */

static void
_cnvrt_toupper(char *buf)
{
        char    c;
        while ((c = *buf) != '\0') {
                *buf++  = toupper(c);
        }
        return;
}

/*
 *      _nlrdent - namelist input of structure entries
 *              Recursive call to handle structure table entries for
 *              namelist.
 *      Return value:
 *              0 on success.  lval contains result.
 *                      lcount contains repeat count.
 *              >0 error code if error encountered
 */

static int
_nlrdent(FIOSPTR css, unit *cup, nmlist_goli_t *nalist, unsigned count,
        char *lastc, int byt)
{
        char    c, oc;
        int     ocnt, ss;
        long    *optr;
        unsigned        scnt;   /* count of namelist struc items */
        nmlist_goli_t   *nlvar; /* ptr to NEXT Var entry */
        int             errn;   /* error number */
        int             cntp;
        c       = *lastc;
        scnt    = count;
        errn    = 0;
        nlvar   = nalist;       /* group object pointer */

        while (scnt--) {
                switch(nlvar->valtype) {
                case IO_SCALAR:
                {
                        nmlist_scalar_t *nlscalar; /* nmlist scalar entry */
                        unsigned long   elsize;
                        unsigned int    int_len;
                        void            *vaddr;
                        ftype_t         type;   /* fortran data type */
                        int             adj = 0;
                        cntp    = 1;
                        nlscalar = nlvar->goli_addr.ptr; /* ptr to scalar */
                        type    = nlscalar->tinfo.type;
                        int_len = nlscalar->tinfo.int_len;
                        /* Assertions */
                        assert (type >= DVTYPE_TYPELESS &&
                                        type <= DVTYPE_ASCII);
                        assert(nlscalar->tinfo.int_len > 0 );
                        if (type == DVTYPE_ASCII) {
                                char    *wptr;
                                const int bytesperchar = 1;
                                wptr =
                                   _fcdtocp(nlscalar->scal_addr.charptr) +
                                   byt;
                                elsize =
                                   _fcdlen(nlscalar->scal_addr.charptr);
                                elsize  = elsize * bytesperchar;
                                /* Any character substring in input record */
                                vaddr   = wptr;
                        }
                        else {
                                if (byt > 0)
                                        adj     = byt/(sizeof(bcont));
                                vaddr   = ((bcont*)nlscalar->scal_addr.ptr) +
                                                adj;
                                elsize  = int_len >> 3;
                        }
                        errn    = _nlread(css, type, cup, vaddr, elsize,
                                        cntp, 0, &c);
                        if (errn != 0)
                                return(errn);
                        *lastc  = c;
                        break;
                }
                case IO_DOPEVEC:
                {
                        DopeVectorType  *nldv;
                        unsigned long   elsize;
                        unsigned long   extent = 1;
                        unsigned int    int_len;
                        void            *vaddr;
                        int             nc;
                        ftype_t         type;   /* fortran data type */
                        int             adj = 0;
                        nldv    = nlvar->goli_addr.dv; /* ptr to dope vector */
                        /* Assertions */
                        assert ( nldv != NULL );
                        assert ( nldv->type_lens.int_len > 0 );
                        type    = nldv->type_lens.type;
                        int_len = nldv->type_lens.int_len;
                        if (type == DVTYPE_ASCII) {
                                char    *wptr;
                                const int       bytesperchar = 1;
                                wptr    = _fcdtocp(nldv->base_addr.charptr) +
                                        byt;
                                elsize  = _fcdlen(nldv->base_addr.charptr);
                                elsize  = elsize * bytesperchar;
                                vaddr   = wptr;
                        }
                        else {
                                if (byt > 0)
                                        adj     = byt/(sizeof(bcont));
                                vaddr   = ((bcont*)nldv->base_addr.a.ptr) + adj;
                                elsize  = int_len >> 3;
                        }
                        for (nc = 0; nc < nldv->n_dim; nc++) {
                                extent *= nldv->dimension[nc].extent;
                        }
                        /* Assertions */
                        assert ( elsize > 0 && extent > 0 );
                        cntp    = extent;
                        errn    = _nlread(css, type, cup, vaddr, elsize,
                                        cntp, 1, &c);
                        if (errn != 0)
                                return(errn);
                        *lastc  = c;
                        break;
                }
                case IO_STRUC_A:
                {
                        nmlist_struclist_t *nlstruc; /* nmlist struc entry */
                        unsigned long   elsize;
                        unsigned int    int_len;
                        unsigned int    scount;
                        nmlist_goli_t   *vaddr;
                        ftype_t         type;   /* fortran data type */
                        int             bytoff;
                        nlstruc = nlvar->goli_addr.sptr; /* ptr to struc */
                        scount  = nlstruc->structlen;   /* number entries */
                        vaddr   = nlstruc->goli;        /* ptr to list */
                        /*
                         * No additional offset needed, pass current
                         * offset on to next version.
                         */
                        bytoff  = byt;
                        errn =
                           _nlrdent(css, cup, vaddr, scount, &c, bytoff);
                        if (errn != 0)
                                return(errn);
                        *lastc  = c;
                        break;
                }
                case IO_STRUC_S:
                {
                        nmlist_struclist_t *nlstruc; /* nmlist struc entry */
                        unsigned long   elsize;
                        unsigned int    int_len;
                        unsigned int    scount;
                        int             nc;
                        long            ic;
                        long            extnt=1;
                        nmlist_goli_t   *vaddr;
                        DopeVectorType  *nlsdv;
                        ftype_t         type;   /* fortran data type */
                        int             bytoff;
                        nlstruc = nlvar->goli_addr.sptr; /* ptr to struc */
                        scount  = nlstruc->structlen;   /* number entries */
                        vaddr   = nlstruc->goli;        /* ptr to list */
                        nlsdv   = nlstruc->struc_addr.dv; /* ptr to dopevec */
                        /*
                         * byt is used when the structure is an array
                         * of structures.  Each element must add an offset
                         * to its address after the first array element.
                         */
                        elsize  = nlsdv->base_addr.a.el_len;
                        for (nc = 0; nc < nlsdv->n_dim; nc++) {
                                extnt *= nlsdv->dimension[nc].extent;
                        }
                        for (ic = 0; ic < extnt; ic++) {
                                /*
                                 * create another byte offset for this
                                 * nesting of a structure of arrays.  Must
                                 * change elsize from bits to bytes.
                                 */
                                bytoff  = byt + ((elsize >> 3) * ic);
                                errn    = _nlrdent(css, cup, vaddr, scount,
                                        &c, bytoff);
                                if (errn != 0)
                                        return(errn);
                        }
                        *lastc  = c;
                        break;
                }
                default:
                        errn    = FEINTUNK;
                }
                if (errn !=0)
                        return(errn);
#if (defined(__mips) && (_MIPS_SZLONG == 32)) || (defined(_LITTLE_ENDIAN) && !defined(_LP64))
                nlvar   = (nmlist_goli_t*)((long *)nlvar + 3 +
                        (sizeof(_fcd))/(sizeof(long)));
#else
                nlvar   = (nmlist_goli_t*)((long *)nlvar + 2 +
                        (sizeof(_fcd))/(sizeof(long)));
#endif
        }
        return(errn);
}

/*      _nexdata - get the next data group - position at the first character
 *              following the value or values.
 *      On return, lval will contain the value and lcount the repeat count
 *      Outptr will point to character immediately following value
 *
 *      The return value is:    -value for EOF
 *                              0 for ok
 *                              >0 if an error
 *              nullvlu =       1 for null value read
 *                              2 for null value, followed by possible
 *                                variable name
 */
static int
_nexdata(
        FIOSPTR         css,
        ftype_t         type,   /* Type of data item */
        void            *ptr,   /* Address of data item */
        int             cnt,    /* Number of values to look for */
        int             inc,
        char            lastc,  /* First character of value, may be blank */
        unit            *cup,   /* Input unit */
        long            *lval,  /* Value is placed here */
        int             *lcount, /* Repeat count is returned here */
        long            elsize,
        int             *nullvlu) /* indicate if any nulls returned */
{
        char    c, oc;
        int     ocnt;
        long    *optr;
        int     holcnt;         /* Length of hollerith string */
        char    newc;
        int     errn;
        *nullvlu        = 0;
        c       = lastc;
        while (ISBLANK(c)) {
                CMTE_SUBGTC(c);
        }
        *lcount = 1;    /* set repeat count */
        if (isdigit((int) c)) {
                /* Look for repeat count.  We can have a repeat count
                 * for any type of data, including character.
                 */
                *lcount = c - '0';
                ocnt    = cup->ulinecnt; /* save count and pointer, in case */
                optr    = cup->ulineptr; /* this isn't repeat count */
                oc      = c;
                for (;;) {
                        /* get next character */
                        /* blank character if end-of-record */
                        SUBGTCNOEOR(c);
                        if (isdigit((int) c))
                                *lcount = (*lcount * 10) + c - '0';
                        else
                                break;
                }
                /*
                 * Could have r*c, rH, rL, or rR, where r is the number just
                 * read.  No embedded blanks allowed in r*c, rH, rL, or rR.
                 */
                switch (c) {
                case '*':
                        /* get next character */
                        /* blank character if end-of-record */
                        CMTE_SUBGTCNOEOR(c);
                        if (isdigit((int) c)) {
                                /* See if we have a repeat count followed
                                 * by hollerith, like 3*4Habcd
                                 */
                                holcnt  = c - '0';
                                ocnt    = cup->ulinecnt;
                                optr    = cup->ulineptr;
                                oc      = c;
                                for (;;) {
                                        /* blank character if end-of-record */
                                        SUBGTCNOEOR(c);
                                        if (isdigit((int) c))
                                                holcnt  = (holcnt * 10) +
                                                        c - '0';
                                        else
                                                break;
                                }
                                switch (c) {
                                case 'H':
                                case 'h':
                                case 'R':
                                case 'r':
                                case 'L':
                                case 'l':
                                        return(_get_holl(css, cup, c, holcnt,
                                                type, lval, elsize));
                                default:
                                        /* backup restore */
                                        cup->ulineptr   = optr;
                                        /* cnt and ptr */
                                        cup->ulinecnt   = ocnt;
                                        c       = oc;
                                        ocnt    = 1;
                                        break;
                                } /* switch */
                        }
                        break;  /* Ordinary repeat count */
                case 'H':
                case 'h':
                case 'R':
                case 'r':
                case 'L':
                case 'l':
                /* Assume it is a Hollerith string, like 3Habc */
                        holcnt  = *lcount;
                        *lcount = 1;    /* No repeats */
                        return(_get_holl(css, cup, c, holcnt, type,
                                lval, elsize));
                default:
                        /* No repeat count, backup restore, cnt & ptr */
                        cup->ulineptr   = optr;
                        cup->ulinecnt   = ocnt;
                        c               = oc;
                        ocnt            = 1;
                        *lcount         = 1;
                        break;
                } /* switch */
        }
        /* END of isdigit()
         * Looking for a value.  When we get here we are at a nonblank
         * character, unless we had the form r*, in which case it may
         * be followed by a blank (NULL).
         */
        if (c == ',') {
                cup->ulineptr--; /* reset cnt and ptr so */
                cup->ulinecnt++; /* we can read separator again */
                *nullvlu        = 1;
                return(0);      /* return null value */
        }
        else if (ISBLANK(c)) {
                *nullvlu        = 1;
                return(0);      /* return null value */
        }
        else {
                if (c == '!') {
                        /* use this path with input like:  a = 5,!comment */
                        cup->ulineptr--; /* reset cnt and ptr so */
                        cup->ulinecnt++; /* we can read separator again */
                        *nullvlu        = 1;
                        return(0);      /* return null value */
                } else
                        if (c == '/' || c == '&' || c == '$') {
                                /* treated terminating slash or ampersand
                                 * the same for f90 to allow simpler
                                 * non-f90 compatibility.
                                 */
                                cup->ulineptr--; /* reset cnt and ptr so */
                                cup->ulinecnt++; /* read delimiter again */
                                *nullvlu        = 2;
                                return(0);      /* Return null value */
                        }
        }
        /*
         * It is important that we handle the special cases of types logical
         * and character first, because the format of their data is treated
         * differently.
         */
        if (type == DVTYPE_LOGICAL) {
                bcont   *slval;
                slval   = (bcont *)lval;

                /* Looking for a logical value.  Logical values must be of
                 * the form: optional decimal point, followed by a 'T' for
                 * true or an 'F' for false, optionally followed by one
                 * or more additional characters.  Those additional
                 * characters cannot include '=', ',', ':', ';', '(', '$'
                 * or '&'.
                 */
                if (c == '.') {
                        /* blank character if end-of-record */
                        SUBGTCNOEOR(c);
                        /* .T or .t assumed to be a logical value */
                        if ((c == 'T') || (c == 't')) {
                                switch (elsize) {
#ifdef _F_INT4
                                case 4:
                                        *(_f_log4 *)slval       = _btol(1);
                                        break;
#if     defined(_F_INT2) && (defined(__mips) || defined(__sv2))
                                case 2:
                                        *(_f_log2 *)slval       = _btol(1);
                                        break;
                                case 1:
                                        *(_f_log1 *)slval       = _btol(1);
                                        break;
#endif  /* _F_INT2 and (mips or sv2) */
#endif  /* _F_INT4 */
                                case 8:
                                        *(_f_log8 *)slval       = _btol(1);
                                        break;
                                default:
                                        return(FEKNTSUP); /* kind not supported */
                                }

                        /* F and .f are assumed to be a logical value */
                        } else if ((c == 'F') || (c == 'f')) {
                                switch (elsize) {
#ifdef _F_INT4
                                case 4:
                                        *(_f_log4 *)slval       = _btol(0);
                                        break;
#if     defined(_F_INT2) && (defined(__mips) || defined(__sv2))
                                case 2:
                                        *(_f_log2 *)slval       = _btol(0);
                                        break;
                                case 1:
                                        *(_f_log1 *)slval       = _btol(0);
                                        break;
#endif  /* _F_INT2 and (mips or sv2) */
#endif  /* _F_INT4 */
                                case 8:
                                        *(_f_log8 *)slval       = _btol(0);
                                        break;
                                default:
                                        return(FEKNTSUP); /* kind not supported */
                                }
                        } else {
                                errn    = FENLIVLG;     /* Invalid logical */
                                return(errn);
                        }
                }
                else {
                        /* If the string does not start with a '.', it could
                         * be a logical value or a variable name.  Try to
                         * determine which by seeing if it is followed by a
                         * replacement character or '('.  Save count and
                         * pointer in case this isn't a value.
                         */
                        ocnt    = cup->ulinecnt;
                        optr    = cup->ulineptr;
                        /* do not go beyond the end of the buffer */
                        if (ocnt > 0) {
                                newc    = *optr++;
                                ocnt--;
                                while (!(ISBLANK(newc))) {
                                /* check for terminating or separator char */
                                        if (newc == ',' || newc == '/' ||
                                            newc == '&' || newc == '$')
                                                break;
                                        if ((newc == '=') || (newc == '(') ||
                                            (newc == '%')) {
                                        /* Reset, this MAY be the first
                                         * letter of a variable name
                                         */
                                                cup->ulineptr--;
                                                cup->ulinecnt++;
                                                *nullvlu        = 2;
                                                return(0); /* Null value */
                                        }
                                        if (ocnt <= 0)
                                                break;
                                        newc    = *optr++;
                                        ocnt--;
                                }
                                while ((ISBLANK(newc)) && ocnt-- > 0)
                                        newc    = *optr++;
                                if (newc == '=') {
                                /*
                                 * Reset, because this MAY have been
                                 * the first letter of a variable name
                                 */
                                        cup->ulineptr--;
                                        cup->ulinecnt++;
                                        *nullvlu        = 2;
                                        return(0);      /* Null value */
                                }
                        }
                        if ((c == 'T') || (c == 't')) {
                                switch (elsize) {
#ifdef _F_REAL4
                                case 4:
                                        *(_f_log4 *)slval       = _btol(1);
                                        break;
#if     defined(_F_INT2) && (defined(__mips) || defined(__sv2))
                                case 2:
                                        *(_f_log2 *)slval       = _btol(1);
                                        break;
                                case 1:
                                        *(_f_log1 *)slval       = _btol(1);
                                        break;
#endif  /* _F_INT2 and (mips or sv2) */
#endif
                                case 8:
                                        *(_f_log8 *)slval       = _btol(1);
                                        break;
                                default:
                                        return(FEKNTSUP); /* kind not supported */
                                }
                        }
                        else if ((c == 'F') || (c == 'f')) {
                                switch (elsize) {
#ifdef _F_REAL4
                                case 4:
                                        *(_f_log4 *)slval       = _btol(0);
                                        break;
#if     defined(_F_INT2) && (defined(__mips) || defined(__sv2))
                                case 2:
                                        *(_f_log2 *)slval       = _btol(0);
                                        break;
                                case 1:
                                        *(_f_log1 *)slval       = _btol(0);
                                        break;
#endif  /* _F_INT2 and (mips or sv2) */
#endif
                                case 8:
                                        *(_f_log8 *)slval       = _btol(0);
                                        break;
                                default:
                                        return(FEKNTSUP); /* kind not supported */
                                }
                        }
                        else if (ISBLANK(c) || c == ',') {
                                *nullvlu        = 1;
                                return(0);      /* Indicate null value */
                        }
                        else {
                                errn    = FENLIVLG;     /* Invalid logical */
                                return(errn);
                        }
                }
                /* We assume we're reading a logical value.
                 * Skip to the end of this value.
                 */
                while ( !(ISBLANK(c))) {
                        CMTE_SUBGTCNOEOR(c);
                        /* check for separator or terminating character */
                        if (c == '/' || c == ',' || c == '&' || c == '$') {
                                /* Reset cnt and ptr for conversion routine */
                                cup->ulineptr--;
                                cup->ulinecnt++;
                                return(0); /* return logical value */
                        }
                }
                return(0);      /* return logical value */
        } /* End of type logical */
        /* if type character, read character data */
        if (type == DVTYPE_ASCII)
                return (_g_charstr(css, cup, ptr, cnt, c, *lcount,
                        elsize, nullvlu));
        /* Get value for variable that is not type LOGICAL or CHARACTER */
        if (isdigit((int) c) || c == '+' || c == '-' || c == '.') {
                if (type == DVTYPE_COMPLEX) {
                        errn    = FENLIVCX;
                        return(errn);
                }
                return(_g_number(type, cup, lval, elsize));
        }
        /* When we get here we are looking for a VALUE.  We are at a
         * nonblank character which is not a digit, +, or -, separator,
         * comment or delimiter.
         * A left parenthesis indicates complex data
         * An apostrophe or quote indicates hollerith data
         * A letter o indicates octal data
         * A letter z indicates hexadecimal data
         */
        if (c == '(') {
                return(_g_complx(css, cup, type, lval, elsize));
        }
        else if ((c == '\'') || (c == '"')) {
                return(_get_quoholl(css, cup, c, type, lval, elsize));
        }
        else if (c == 'O' || c == 'o') {
                return(_gocthex(css, cup, type, lval, OCTAL, elsize, nullvlu));
        }
        else if (c == 'Z' || c == 'z') {
                return(_gocthex(css, cup, type, lval, HEX, elsize, nullvlu));
        }
        else {
                /* No valid value.
                 * Reset cup->ulineptr, because this MAY have been the first
                 * character of a variable name.  For example, if we have:
                 * integer var1(3),var2, with input: var1=2, var2 = 5
                 * then when we try to read the value for var1(2), we will
                 * see 'var2'
                 */
                cup->ulineptr--;
                cup->ulinecnt++;
                *nullvlu        = 2;
                return(0);      /* Return null value */
        }
}

/* _g_complx - get the value for a complex number.
 * On entry:
 *              positioned at '(' for a complex number.
 * Returns:     0 if OK,
 *              -value if EOF
 *              > 0 with valid error number if an error
 */

static int
_g_complx(
        FIOSPTR css, unit*cup, ftype_t type, long *lval, long elsize)
{
        char    c;
        long    mode, stat;
        long    zero    = 0;
        long    field_width;
        long    *field_begin;
        long    *field_end;
        int     i, errn;
        int     nc;
        ic_func *ngcf;
        int     inc;
        int     ptrfw;
        bcont   *slval;
        /*
         * IN reading the complex number, assume
         * intervening EOR is OK
         */
        if (type != DVTYPE_COMPLEX) {
                errn    = FENLIVCX;     /* not complex type */
                return(errn);
        }
        /*
         *      Call the function from the ncf_tab90 table.
         */

        ngcf    = ncf_tab90[type];
        mode    = 0;

        switch (elsize) {
#ifdef _F_REAL4
        case 8:
                mode    = MODEHP;
                break;
#endif
        case 16:
                break;
        case 32:
                mode    = MODEDP;
                break;
        default:
                return(FEKNTSUP);       /* kind not supported */
        }
        inc     = (elsize / 2) / (sizeof(bcont));
        slval   = (bcont*)lval;

        /* loop and get both real and imaginary */
        for (i = 0; i < 2; i++) {
                do {
                        SUBGTC(c);      /* skip the '(' */
                } while (ISBLANK(c));   /* skip blanks */
                cup->ulinecnt++;        /* backup 1 character */
                cup->ulineptr--;        /* backup 1 character */
                field_begin     = cup->ulineptr;
                field_end       = cup->ulineptr;
                field_width     = cup->ulinecnt;
                nc              = 0;

                while (nc < cup->ulinecnt && !(ISSEP(*field_end) ||
                   *field_end == ')' || *field_end == '&' ||
                   *field_end == '$' )) {
                        field_end++;
                        nc++;
                }
                /* pass field_end + 1 */
                field_end++;
                field_width     = nc;
                /* convert both the real and imaginary parts */
                errn    = ngcf(field_begin, &field_width, &field_end,
                        &mode, slval + (i * inc), &stat, &zero, &zero);

                /* If the scan failed, the input data might be
                 * Hollerith or hex or octal.  Allow _s_scan_extensions
                 * _s_scan_extensions to rescan the input and
                 * recompute the field width.
                 */
                if (errn < 0) {
                        errn    = _nicverr(stat);
                } else
                        errn    = 0;

                /* if (errn == EX_ILLCHAR) */
                if (errn == FENICVIC) {
                        int     errn2;
                        errn2   = _s_scan_extensions(slval + (i * inc),
                                type, elsize, field_begin,
                                field_width, &ptrfw, mode);

                        cup->ulineptr += ptrfw;
                        cup->ulinecnt -= ptrfw;
                        if (errn2 <= 0)
                                errn    = 0;
                        else
                                /* errors FELDUNKI and FELDSTRL
                                 * are currently returned.
                                 */
                                return(FENLIVCX);
                } else {
                        cup->ulineptr   = field_begin + field_width;
                        cup->ulinecnt  -= cup->ulineptr - field_begin;
                        if (errn != 0)
                                return(errn);
                }
                do {
                        SUBGTC(c);
                } while (ISBLANK(c));
                if ((c != ',') && (i == 0))
                        return(FENLIVCX); /* err in cmplx no. form */
        }
        if ( c != ')')
                return(FENLIVCX); /* err in complex number format */
        return(0);
}

/*
 * _g_number - Read a number.
 * Returns:     0 if ok
 *              -value if EOF
 *              > 0 if error
 */

static int
_g_number(
        ftype_t         type,
        unit            *cup,
        long            *lval,
        long            elsize)
{
        long    mode, stat;
        long    zero = 0;
        long    field_width;
        long    *field_begin;
        long    *field_end;
        int     ss = 0;
        int     errn = 0;
        int     nc;
        ic_func *ngcf;
        int     ptrfw;
        bcont   *slval;

        mode    = 0;

        switch (type) {
        case DVTYPE_REAL:
                switch (elsize) {
#ifdef _F_REAL4
                case 4:
                        mode    = MODEHP;
                        break;
#endif
                case 8:
                        break;
                case 16:
                        mode    = MODEDP;
                        break;
                default:
                        return(FEKNTSUP);
                }
                break;
        case DVTYPE_INTEGER:
                switch (elsize) {
#ifdef _F_INT4
                case 4:
                        mode    = MODEHP;
                        break;
#if     defined(_F_INT2) && (defined(__mips) || defined(__sv2))
                case 2:
                        mode    = MODEWP;
                        break;
                case 1:
                        mode    = MODEBP;
                        break;
#endif  /* _F_INT2 and (mips or sv2) */
#endif  /* _F_INT4 */
                case 8:
                        break;
                default:
                        return(FEKNTSUP);
                }
                break;
        }
        /*
         * Call the function from the ncf_tab90 table.
         */
        ngcf            = ncf_tab90[type];
        cup->ulinecnt++;        /* backup 1 character */
        cup->ulineptr--;        /* backup 1 character */
        field_begin     = cup->ulineptr;
        field_end       = cup->ulineptr;
        field_width     = cup->ulinecnt;
        slval           = (bcont*)lval;
        nc              = 0;
        while (nc < cup->ulinecnt && !(ISSEP(*field_end) ||
           *field_end == '&' || *field_end == '$')) {
                field_end++;
                nc++;
        }
        /* pass field_end + 1 */
        field_end++;
        field_width     = nc;
        errn    = ngcf(field_begin, &field_width, &field_end,
                &mode, slval, &stat, &zero, &zero);

        /* If the scan failed, the input data might be
         * Hollerith or hex or octal.  Allow _s_scan_extensions
         * _s_scan_extensions to rescan the input and
         * recompute the field width.
         */
        if (errn < 0) {
                ss      = _nicverr(stat);
                if (ss == 0)
                        errn    = 0;
        } else
                errn    = 0;

        /* if (errn == EX_ILLCHAR) */
        if (ss == FENICVIC) {
                int     errn2;
                errn2   = _s_scan_extensions(slval,
                        type, elsize, field_begin,
                        field_width, &ptrfw, mode);

                cup->ulineptr   = field_begin + field_width;
                cup->ulinecnt  -= cup->ulineptr - field_begin;
                if (errn2 >= 0)
                        errn    = 0;
                else
                        /* errors FELDUNKI and FELDSTRL
                         * are currently returned.
                         */
                        errn    = FENLUNKI;
                        return(errn);
        } else {
                cup->ulineptr   = field_begin + field_width;
                cup->ulinecnt  -= cup->ulineptr - field_begin;
        }
        return(errn);
}

/* _g_charstr - read a character string
 *
 * Input: cup_ulineptr will point one past the first character of the string.
 *      "c" will contain the first character of the string.
 * Returns:     0 if ok,
 *              -value if EOF
 *              > 0 if error
 */

static int
_g_charstr(
        FIOSPTR         css,
        unit            *cup,
        void            *p,     /* Address of variable being read */
        int             cnt,    /* Number of strings we expect to read */
        char            c,      /* First character of string. */
        int             lcount, /* Repeat count */
        long            elsize,
        int             *nullvlu)
{
        int     eos;    /* eos == -1 if end or beginning of string */
        int     i, ch;
        unsigned int    len77;
        char    *cp;
        char    enddelim;
        char    c1;
        int     repcount;
        char    *cpold;
        int     errn = 0;
        long    *optr;
        int     ocnt;
        void    *fchp;
        *nullvlu = 0;
        /*
         * Character data may be enclosed in apostrophes or quotation marks.
         * Each apostrophe within a character constant delimited by
         * apostrophes must be represented by 2 consecutive apostrophes
         * without an intervening blank or end of record. The same holds
         * true for quotation marks. Character constants may be continued
         * from the end of one record to the beginning of the next record.
         * The end of the record does not cause a blank or any other
         * character to become part of the constant.
         * Blank characters, separator characters, comment characters, and
         * delimiter characters may appear in character constants.
         *
         * For cf77 only (F90 does not allow undelimited character on input):
         * If the character constant has the following properties:
         * 1. It does not contain blank characters,
         *    separator characters, comment characters, left parenthesis
         *    or delimiter characters.
         * 2. It does not cross a record boundary,
         * 3. the first nonblank character is not a quotation mark or
         *    apostrophe,
         * 4. the leading characters are not numeric followed by asterisk,
         * 5. the leading characters are not numeric followed by R, H, or L
         * then the enclosing apostrophes or quotation marks are not required
         * and apostrophes or quotation marks within the character constant
         * are not to be doubled.
         *
         * Let len be the length of the list item, and let w be the length
         * of the character constant. If len is less than or equal to w,
         * the leftmost len characters of the constant are transmitted to the
         * variable. If len is greater than w, the constant is transmitted to
         * the leftmost w characters of the variable and the remaining len-w
         * characters of the list item are filled with blanks.
         *
         * f90 allows zero-length character and it uses one input data item
         * from the input record.  It does not store the value to the
         * the zero-sized character entity.  cf77 does not allow this feature.
         */
        eos     = 0;
        fchp    = p;
        len77   = elsize;       /* Get character length */
        /* f90 allows zero-length character entities */
        cp              = fchp;
        repcount        = MIN(lcount,cnt);
        /*
         * If the first character is a quote or apostrophe, we expect
         * that character to delimit the end of the string.
         */
        if ((c == '\'') || (c == '"')) {
                enddelim        = c;
                /* find characters in string */
                for (i = 0; i < len77 && eos == 0; i++) {
                        GETSTRD();
                                if (eos == 0)
                                        *cp++   = ch;
                }
                if (eos == -1)
                        i--;
                i       = len77 - i; /* If declared len > read len */
                if (i > 0)
                        (void) memset(cp, BLANK, i);    /* blank fill */
                cp      = cp + i;
                while (eos != -1) {
                        /*
                         * We didn't hit the end of the string yet.
                         * Search for it.
                         */
                        GETSTRD();
                }
                while (--repcount) {
                        /* We have a repeat count.
                         * cp will point to the next element.
                         * Copy len77 characters to the next element. 
                         */
                        cpold   = fchp;
                        (void) memcpy(cp, cpold, len77);
                        cp      = cp + len77;   /* Next element */
                }
        } else {
                /*
                 * We have a character string that's not surrounded
                 * by quotes (or apostrophes).  Read until we see a
                 * blank, separator, comment, or EOR (which looks
                 * like a blank to us).  Store as many of them as
                 * we have room for.  We cannot have a repeat count
                 * unless we're surrounded by quotes or apostrophes.
                 */
                if (lcount > 1) {
                        errn    = FENLNOVL; /* invalid char data */
                        return(errn);
                }
                /*
                 * Determine if this is a value or a variable name.
                 * Save count and pointer in case this isn't a value.
                 */
                ocnt    = cup->ulinecnt;
                optr    = cup->ulineptr;
                c1      = *optr++;
                ocnt--;

                while (!(ISBLANK(c1))) {
                        /* check for separator or terminating character */
                        if (c1 == ',' || c1 == '/' || c1 == '&' || c == '$')
                                break;  /* Assume value */
                        if (c1 == '=' || c1 == '(' || c1 == '%') {
                                /* Reset, this MAY be the first
                                 * letter of a variable name.
                                 */
                                cup->ulineptr--;
                                cup->ulinecnt++;
                                *nullvlu        = 2;
                                return(0); /* Null value */
                        }
                        c1      = *optr++;
                        ocnt--;
                }
                while ((ISBLANK(c1)) && ocnt-- > 0)
                        c1      = *optr++;
                if (c1 == '=' || c1 == '(' || c1 == '%') {
                        /*
                         * Reset, this MAY be the first letter
                         * of a variable name.
                         */
                        cup->ulineptr--;
                        cup->ulinecnt++;
                        *nullvlu        = 2;
                        return(0);      /* Null value */
                }
                /* f90 does not allow undelimited character */
                errn    = FENLUNKI; /* undelimited char */
                return(errn);
        }
        return(errn);
}

/* _get_holl - Read a hollerith string.
 *
 * Returns:     0 if a value was found,
 *              -value if EOF
 *              > 0 if an error occurred
 */

static int
_get_holl(
        FIOSPTR         css,
        unit            *cup,
        char            holltype,
        int             count,  /* Number of characters in string */
        ftype_t         type,   /* Type of data item */
        long            *lval,
        long            elsize)
{
        int     i;
        char    *holbufptr;
        char    c;
        int     errn = 0;
        int     fill;
        /*
         * Read 'count' characters from the current word, packing them
         * left justified into lval[0].
         *
         * Can't have hollerith input for DOUBLE, COMPLEX or CHARACTER data.
         * Hollerith input is supported for compatibility with
         * old versions of namelist.
         *
         * Because we don't allow CHARACTER data, we can make the
         * simplifying assumption that we start on a word boundary.
         * Also, we are going to assume that whatever we read in will need
         * to fit in one word. Repeat counts are allowed. If it becomes
         * necessary to allow hollerith strings of > 8 characters, some
         * thought will need to be given as to how to handle repeat counts.
         */
        if (type == DVTYPE_COMPLEX || type == DVTYPE_ASCII ||
          ((type == DVTYPE_REAL) && elsize == sizeof(_f_real16))) {
                errn    = FENLUNKI;
                return(errn);
        }
        if (count > elsize) {
                errn    = FENLIOER;
                return(errn);
        }
        fill            = BLANK;
        holbufptr       = (char *)lval;
        if (holltype == 'R' || holltype == 'r') {
                /* right justified */
                fill            = NULLC;
                holbufptr       = holbufptr + (elsize - count);
        }
        else
                if (holltype == 'L' || holltype == 'l')
                        fill    = NULLC;
        /* Last character in buffer is the EOR character,
         * that's why we check for cup->ulinecnt > 1
         */
        for (i = 0; i < count && (cup->ulinecnt > 1) ; i++) {
                SUBGTC(c); /* comment characters are not special
                            * within hollerith string */
                *holbufptr++    = c;
        }
        if (i == count) {
                /* Do we need to fill the last word? */
                if (holltype == 'R' || holltype == 'r') /* right justified? */
                        holbufptr       = (char *)lval;
                (void) memset(holbufptr, fill, elsize - count);
        }
        else {
                /*
                 * We hit EOR before we read enough characters _or_ we had
                 * too many characters.
                 */
                errn    = FENLIOER;
                return(errn);
        }
        return(errn);
}

/* _get_quoholl
 * Get a hollerith string that is surrounded by quotes or apostrophes
 * Legal syntax is '----'L, '----'R, or '----'H
 *
 * Returns:     0 if a value was found,
 *              -value if EOF
 *              > 0 if an error occurred
 */

static int
_get_quoholl(
        FIOSPTR         css,
        unit            *cup,
        char            cdelim, /* Quote or apostrophe (to end hollerith) */
        ftype_t         type,   /* Type of data */
        long            *lval,  /* Value is placed here */
        long            elsize) /* size */
{
        int     numchar;        /* character counter */
        int     j;
        int     fill;           /* Fill character is either ' ' or '\0' */
        long    holbuf;         /* Data is stored here until we know whether
                                   it is right or left justified. */
        char    *holbufptr;     /* pointer into holbuf */
        char    c;              /* Character read */
        char    *lvalcharptr;   /* Pointer to value */
        int     errn = 0;
        /*
         * Can't have hollerith input for DOUBLE, COMPLEX or CHARACTER data.
         * Hollerith input is supported for compatibility with
         * old versions of namelist.
         *
         * Because we don't allow CHARACTER data, we can make the
         * simplifying assumption that we start on a word boundary.
         * Also, we are going to assume that whatever we read in will need
         * to fit in one word. Repeat counts are allowed. If it becomes
         * necessary to allow hollerith strings of > 8 characters, some
         * thought will need to be given as to how to handle repeat counts.
         */
        if (type == DVTYPE_COMPLEX || type == DVTYPE_ASCII ||
           (type == DVTYPE_REAL && elsize == sizeof(_f_real16))) {
                errn    = FENLUNKI;
                return(errn);
        }
        lvalcharptr     = (char *)lval;
        holbufptr       = (char *) &holbuf;
        /* Do not allow quoted strings to be continued on another record. */
        numchar = 0;
        for (;;) {
                SUBGTC(c);
                if (c == cdelim) {
                        /* Allow Comment characters within quoted string */
                        SUBGTC(c);
                        if (c != cdelim)
                                break;  /* That was the end of the quoted
                                         * string.  Otherwise, we saw two
                                         * quotes in a row, which means
                                         * we store one.
                                         */
                }
                if (++numchar > elsize) {
                        errn    = FENLIOER;
                        return(errn);
                }
                *holbufptr++    = c;    /* Save the character */
                /*
                 * Last character in input buffer is not EOR character,
                 * that's why we check for cup->ulinecnt <= 0
                 */
                if (cup->ulinecnt <= 0) {
                        errn    = FENLIOER;
                        return(errn);
                }
        } /* On exit from this loop, numchar = number of chars. stored */
        if (c == 'L' || c == 'l')
                fill    = NULLC;
        else if (c == 'R' || c == 'r') {
                /* Right justify and store the value just read */
                holbufptr       = holbufptr - 1;        /* Last character */
                lvalcharptr     = lvalcharptr + (elsize - 1);
                j               = elsize - numchar;
                while (numchar-- > 0)
                        *lvalcharptr--  = *holbufptr--;

                /* Fill word with 0's if necessary */
                while (j-- > 0)
                        *lvalcharptr--  = '\0';
                return(0);
        }
        else {
                /* H format */
                fill    = BLANK;
                if (c != 'H' && c != 'h') {
                        /* Reset pointers since the character does */
                        /* not belong to this value */
                        cup->ulineptr--;
                        cup->ulinecnt++;
                }
        }
        /* Do we need to fill the last word? */
        (void) memset(holbufptr, fill, elsize - numchar);
        *lval   = holbuf;
        return(errn);
}

/* _gocthex - provides octal or hex editing for compatibility with old
 * versions of namelist.
 *      Legal formats: O'123 or O'123'. Octal number may not contain blanks,
 *      and this is a difference with the old version of namelist.
 *      Legal formats: Z'1a3 or Z'1a3'.
 *
 * On input:
 *      cup_ulineptr should point to the character immediately following the O
 * Returns:     0 if a value was found,
 *              -value if EOF
 *              >0 if an error occurred
 * nullvlu =    1 if a null value was found
 *              2 if a null value was found, and it is not followed
 *                by another value
 */

static int
_gocthex(
        FIOSPTR css,
        unit    *cup,
        ftype_t type,
        long    *lval,
        int     base,
        long    elsize,
        int     *nullvlu)
{
        char    c;
        char    strbuf[2];
        int     errn = 0;
        int     octshift = OCTSHFT;
        int     hexshift = HEXSHFT;
        /* check size in bytes of incoming variable. */
#if defined(_F_REAL4) && defined(_F_INT4)
        if (elsize <= 4) {
                octshift        = OCTSHFT4;
                hexshift        = HEXSHFT4;
        }
#endif
        *nullvlu        = 0;
        if (*cup->ulineptr != '\'') {
                /* Can't be a value, might be a variable name */
                cup->ulineptr--;
                cup->ulinecnt++;
                *nullvlu        = 2;
                return(0);      /* NULL value */
        }
        /* This type of format won't work for complex or double precision */
        if (type == DVTYPE_COMPLEX || (type == DVTYPE_REAL &&
            elsize == sizeof(_f_real16))) {
                errn    = FENLUNKI;     /* type mismatch */
                return(errn);
        }
        /* if not enough characters in record for octal/hex constant, err */
        if (cup->ulinecnt <= 1) {
                errn    = FENLIOER;
                return(errn);
        }
        SUBGTC(c);      /* Skip the apostrophe */
        SUBGTC(c);      /* and get the next character */
        *lval           = 0;
        strbuf[1]       = '\0';
        while (!(ISBLANK(c)) && c != '\'') {
                if (base == OCTAL) {
                        if ((!isdigit((int) c)) || (c == '9') ||
                                (*lval >> octshift)) {
                                        errn    = FENICVIC; /* NICV type err */
                                        return(errn);
                        }
                        *lval   = (*lval * 8) + c - '0';
                }
                else { /* Check for hex digit or overflow */
                        if ((!isxdigit(c)) || (*lval >> hexshift)) {
                                errn    = FENICVIC;     /* NICV type err */
                                return(errn);
                        }
                        strbuf[0]       = c;
                        *lval   = (*lval * 16) +
                                        (int) strtol(strbuf, (char **)NULL, 16);
                }
                /* check for comment after value */
                CMTE_SUBGTC(c);
                if (c == ',') {
                        cup->ulineptr--;
                        cup->ulinecnt++; /* to read separator after */
                        break;  /* return from this routine */
                }
        }
        return(errn);   /* indicate value */
}

/*
 *      _nl_stride_dv
 *              Call a specified function to transfer a data area defined
 *              by a dopevector.  This corresponds to an array section.
 *      Arguments
 *              dv      - dope vector which describes the array section.
 *              sectn   - Dimension information in input record.
 *      Return Value
 *              0               normal return
 *              FERDPEOF        if end of file condition
 *              >0              if error condition
 */

static int
_nl_stride_dv(
        FIOSPTR         css,
        unit            *cup,
        DopeVectorType  *dv,
        struct DvDimen  *sectn,
        char            *lastch,
        long            strbegend[3])
{
        int             nd;
        int             i;
        long            extent;                 /* extent of first dimension */
        long            inc;                    /* stride in items */
        long            ret = 0;
        ftype_t         f90type;                /* F90 data type code */
        long            elsize;                 /* byte size of each element */
        long            element_stride;         /* 1 iff elsize divides stride*/
        register long   id1, id2, id3, id4, id5, id6, id7;
        struct DvDimen  *dvdimen;
        long            badjust;                /* offset for collapsed dims */
        bcont           *addr;                  /* for numeric data */
        char            *baddr;                 /* for byte-oriented data */
        void            *addr2, *addr3, *addr4;
        void            *addr5, *addr6;
        struct DvDimen  dimen[MAXDIM];
        long            begt = strbegend[1];
        long            endt = strbegend[2];

        /* Assertions */
        assert ( dv != NULL );
        assert ( dv->type_lens.int_len > 0 );

        if (dv->p_or_a && (dv->assoc == 0))
                return(FEPTRNAS);               /* pointer not associated */

        f90type = dv->type_lens.type;
        nd      = dv->n_dim;
        badjust = 0;

/*
 *      Make a local copy of dimension information so we may optimize it.
 */
        for (i = 0; i < nd; i++)
                dimen[i]        = dv->dimension[i];

/*
 *      Fold any indexes into the new dimension structure.  The
 *      result is that we can ignore the low_bound field in the
 *      nested loops. 
 *
 *      We also collapse (remove) indexed dimensions and 
 *      unindexed dimensions with extents of one.
 */
        dvdimen = dv->dimension;
        for (i = 0; i < nd; i++) {
                if (sectn == NULL) {

                        /* bail out here if any extent is 0 */
                        if (dvdimen[i].extent == 0)
                                return(0);      
                }
                else {
                        /* collapse this indexed dimension */
                        badjust += (sectn[i].low_bound -
                                    dvdimen[i].low_bound) * 
                                        dvdimen[i].stride_mult;
                        if (dvdimen[i].extent != sectn[i].extent)
                                dimen[i].extent = sectn[i].extent;
                        if (dvdimen[i].stride_mult != sectn[i].stride_mult)
                                dimen[i].stride_mult = sectn[i].stride_mult;
                }
        }

        if (f90type == DVTYPE_ASCII) {

                elsize          = _fcdlen(dv->base_addr.charptr); /* in bytes */
                extent          = dimen[0].extent;
                inc             = 0;
                element_stride  = 1;

                if (extent > 1) {
                        register int    stm = dimen[0].stride_mult;

                        inc     = stm / elsize;
                        if (inc * elsize != stm)
                        element_stride  = 0;    /* it's a section of substrings */
                }
        
                baddr   = _fcdtocp(dv->base_addr.charptr) +
                                badjust * (dv->type_lens.int_len >> 3);
                
                switch(nd) {
                case 7:
                    for (id7 = 0; id7 < dimen[6].extent; id7++) {
                      addr6     = baddr;
                case 6:
                      for (id6 = 0; id6 < dimen[5].extent; id6++) {
                        addr5   = baddr;
                case 5:
                        for (id5 = 0; id5 < dimen[4].extent; id5++) {
                          addr4 = baddr;
                case 4:
                          for (id4 = 0; id4 < dimen[3].extent; id4++) {
                            addr3       = baddr;
                case 3:
                            for (id3 = 0; id3 < dimen[2].extent; id3++) {
                              addr2     = baddr;
                case 2:
                              for (id2 = 0; id2 < dimen[1].extent; id2++) {
                case 1:
                                if ((element_stride == 1) && (strbegend[0] == 0)) {
                                  ret   = _nlread(css, f90type, cup, baddr,
                                             elsize, extent, inc, lastch);
                                  if (ret != 0) goto done;
                                }
                                else {
                                  char  *ba;
                                  char  *newba;
                                  int   newelsz;
                                  ba    = baddr;
                                  if (strbegend[0] == 0) {
                                    for (id1 = 0; id1 < extent; id1++) {
                                      ret = _nlread(css, f90type, cup, ba,
                                               elsize, 1, 0, lastch);
                                      if (ret != 0) goto done;
                                      ba        += dimen[0].stride_mult;
                                    }
                                  } else {
                                    if (begt < 1 )
                                      begt = 1;
                                    else if (begt > elsize) {
                                      ret       = FENLUNKN;
                                      goto done;
                                    }
                                    if (endt < 1 )
                                      endt = elsize;
                                    else if ((endt > elsize) || (endt < begt)) {
                                      ret       = FENLUNKN;
                                      goto done;
                                    }
                                    for (id1 = 0; id1 < extent; id1++) {
                                      newba     = ba + (begt - 1);
                                      newelsz   = (endt - begt) + 1;
                                      ret = _nlread(css, f90type, cup,
                                        newba, newelsz, 1, 0, lastch);
                                      if (ret != 0)
                                        goto done;
                                      ba        += dimen[0].stride_mult;
                                    }
                                  }
                                }
        
                                if (nd == 1) goto done;
                                baddr   += dimen[1].stride_mult;
                              }
                              if (nd == 2) goto done;
                              baddr     = addr2;
                              baddr     += dimen[2].stride_mult;
                            }
                            if (nd == 3) goto done;
                            baddr       = addr3;
                            baddr       += dimen[3].stride_mult;
                          }
                          if (nd == 4) goto done;
                          baddr = addr4;
                          baddr += dimen[4].stride_mult;
                        }
                        if (nd == 5) goto done;
                        baddr   = addr5;
                        baddr   += dimen[5].stride_mult;
                      }
                      if (nd == 6) goto done;
                      baddr     = addr6;
                      baddr     += dimen[6].stride_mult;
                    }
                }

        }
        else {                          /* numeric data */

                int bshft;      /* 0 or 1; shift count for ratio of             */
                                /* stride_mult units to basic storage unit      */
                                /* size.                                        */

                /*
                 *      We only support dopevector stride mults with units
                 *      scaled by sizeof(long) or sizeof(bcont).
                 */
#if     defined(__mips) || defined(_LITTLE_ENDIAN) || defined(__sv2)
                assert( SMSCALE(dv) == sizeof(bcont) ||
                        SMSCALE(dv) == sizeof(_f_int2) ||
                        SMSCALE(dv) == sizeof(_f_int4) ||
                        SMSCALE(dv) == sizeof(long)     );
#else
                assert( SMSCALE(dv) == sizeof(bcont) ||
                        SMSCALE(dv) == sizeof(long)     );
#endif

                /* the -1 is not possible but check for it */
                assert( SMSHIFT(dv) != -1);

                element_stride  = 1;
                elsize          = dv->type_lens.int_len >> 3;
                extent          = dimen[0].extent;
                inc             = 0;
                bshft           = SMSHIFT(dv);

                if (extent > 1) {
                    int bytes_per_sm = dimen[0].stride_mult*(signed)SMSCALE(dv);
                    inc = bytes_per_sm / elsize;
                    if (inc * elsize != bytes_per_sm)
                        element_stride  = 0;    /* section across derived type */
                }

                addr    = (bcont*)dv->base_addr.a.ptr + (badjust << bshft);
                
                switch(nd) {
                case 7:
                    for (id7 = 0; id7 < dimen[6].extent; id7++) {
                      addr6     = addr;
                case 6:
                      for (id6 = 0; id6 < dimen[5].extent; id6++) {
                        addr5   = addr;
                case 5:
                        for (id5 = 0; id5 < dimen[4].extent; id5++) {
                          addr4 = addr;
                case 4:
                          for (id4 = 0; id4 < dimen[3].extent; id4++) {
                            addr3       = addr;
                case 3:
                            for (id3 = 0; id3 < dimen[2].extent; id3++) {
                              addr2     = addr;
                case 2:
                              for (id2 = 0; id2 < dimen[1].extent; id2++) {
                case 1:
                                if (element_stride)  {
                                  ret   = _nlread(css, f90type, cup, addr,
                                        elsize, extent, inc, lastch);
                                }
                                else {
                                  bcont *ad;
                                  ad    = addr;
                                  /* 
                                   * If derived type foo contains two fields,
                                   * real a and double precision d,  then
                                   * foo(1:2)%d generates this type of 
                                   * dopevector with a stride which is not
                                   * a multiple of the element size.
                                   */
                                  for (id1 = 0; id1 < extent; id1++) {
                                    ret = _nlread(css, f90type, cup, ad,
                                               elsize, 1, 0, lastch);
                                    if (ret != 0) goto done;
                                    ad  += dimen[0].stride_mult;
                                  }
                                }
        

                                if (ret != 0) goto done;
        
                                if (nd == 1) goto done;
                                addr    += dimen[1].stride_mult << bshft;
                              }
                              if (nd == 2) goto done;
                              addr      = addr2;
                              addr      += dimen[2].stride_mult << bshft;
                            }
                            if (nd == 3) goto done;
                            addr        = addr3;
                            addr        += dimen[3].stride_mult << bshft;
                          }
                          if (nd == 4) goto done;
                          addr  = addr4;
                          addr  += dimen[4].stride_mult << bshft;
                        }
                        if (nd == 5) goto done;
                        addr    = addr5;
                        addr    += dimen[5].stride_mult << bshft;
                      }
                      if (nd == 6) goto done;
                      addr      = addr6;
                      addr      += dimen[6].stride_mult << bshft;
                    }
                }
        }

done:   return(ret);
}

static int
_nl_strd_derv(
        FIOSPTR         css,
        unit            *cup,
        DopeVectorType  *dv,
        struct DvDimen  *sectn,
        char            *lastch,
        nmlist_goli_t   *vdr,
        unsigned int    cnt,
        long            bte)
{
        const int       bytesperchar = 1;
        int             nd;
        int             i;
        long            badjust;        /* offset for collapsed dims */
        long            elsize;         /* byte size of each element */
        long            ret = 0;
        long            sizeamt;        /* unit for stride mult */
        register long   id1, id2, id3, id4, id5, id6, id7;
        struct DvDimen  *dvdimen;
        struct DvDimen  dimen[MAXDIM];

        nd      = dv->n_dim;
        badjust = 0;

/*      Make a local copy of dimension information to optimize it. */
        for (i = 0; i < nd; i++)
                dimen[i]        = dv->dimension[i];

/*      Fold any indexes into the new dimension structure.  The
 *      result is that we can ignore the low_bound field in the
 *      nested loops. 
 *
 *      We also collapse (remove) indexed dimensions and 
 *      unindexed dimensions with extents of one.
 */
        dvdimen = dv->dimension;
        for (i = 0; i < nd; i++) {
                if (sectn == NULL) {

                        /* bail out here if any extent is 0 */
                        if (dvdimen[i].extent == 0)
                                return(0);      
                }
                else {
                        /* collapse this indexed dimension */
                        badjust += (sectn[i].low_bound -
                                    dvdimen[i].low_bound) * 
                                        dvdimen[i].stride_mult;
                        if (dvdimen[i].extent != sectn[i].extent)
                                dimen[i].extent = sectn[i].extent;
                        if (dvdimen[i].stride_mult != sectn[i].stride_mult)
                                dimen[i].stride_mult = sectn[i].stride_mult;
                }
        }

        elsize  = dv->base_addr.a.el_len>> 3;
        bte     = (badjust * elsize);
        if (dv->type_lens.type == DVTYPE_DERIVEDWORD) {
                sizeamt = sizeof(int);
        } else if (dv->type_lens.type == DVTYPE_DERIVEDBYTE) {
                sizeamt = 1 * bytesperchar;
        } else {
                sizeamt = (signed)SMSCALE(dv);
        }

        switch(nd) {
        case 7:
                for (id7 = 0; id7 < dimen[6].extent; id7++) {
        case 6:
                 for (id6 = 0; id6 < dimen[5].extent; id6++) {
        case 5:
                  for (id5 = 0; id5 < dimen[4].extent; id5++) {
        case 4:
                   for (id4 = 0; id4 < dimen[3].extent; id4++) {
        case 3:
                    for (id3 = 0; id3 < dimen[2].extent; id3++) {
        case 2:
                     for (id2 = 0; id2 < dimen[1].extent; id2++) {
        case 1:
                      for (id1 = 0; id1 < dimen[0].extent; id1++) {
                        ret     = _nlrdent(css, cup, vdr, cnt, lastch, bte);

                        if (ret != 0) goto done;
                        bte += dimen[0].stride_mult * sizeamt;
                      }
                      if (nd == 1) goto done;
                      bte += dimen[1].stride_mult * sizeamt;
                     }
                     if (nd == 2) goto done;
                     bte += dimen[2].stride_mult * sizeamt;
                    }
                    if (nd == 3) goto done;
                    bte += dimen[3].stride_mult * sizeamt;
                   }
                   if (nd == 4) goto done;
                   bte += dimen[4].stride_mult * sizeamt;
                  }
                  if (nd == 5) goto done;
                  bte += dimen[5].stride_mult * sizeamt;
                 }
                 if (nd == 6) goto done;
                 bte += dimen[6].stride_mult * sizeamt;
                }
        }
done:   return(ret);
}