wnl90to77.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/wnl90to77.c        92.2    06/21/99 10:37:55"

#include <stdio.h>
#include <errno.h>
#include <cray/nassert.h>
#include <liberrno.h>
#include "fio.h"
#include "namelist.h"
#include "wnl90def.h"

/*
 *      _wnl90to77 - called by library routine wnl90.c to write a cf77
 *                      namelist output file.
 *
 *      Synopsis
 *              int _wnl90to77( css,
 *                              unit *cup,
 *                              nmlist_group *namlist,
 *                              void *stck,
 *                              int errf);
 *
 *              Where
 *                      css     pointer to css
 *                      cup     pointer to the unit information
 *                      namlist pointer to the namelist table.
 *                      stck    pointer to stack space which is passed
 *                              to each call to _FWN for a particular
 *                              statement.  This is used by the library.
 *                      errf    Error processing flag.
 *
 *      Return value
 *              errn
 */

int
_wnl90to77(
        FIOSPTR         css,
        unit            *cup,
        nmlist_group    *namlist,
        void            *stck,
        int             errf)
{
        register int    errn;           /* Error number                 */
        char            *wptr;          /* pointer to group name        */
        unsigned long   wlen;           /* group name length            */
        unsigned        wcount;         /* count of namelist items      */
        int             icnt;
        char            *varptr;        /* ptr to group_obj_list_item   */
        unsigned long   varlen;         /* len to group_obj_list_item   */
        nmlist_goli_t   *nlvar;         /* ptr to next variable entry   */
        long            eqlchr;         /* hold nl equal character      */
        long            sepchr;         /* hold nl delimiter character  */
        long            nlchr;          /* hold nl group character      */
        long            trmchr;         /* hold nl terminator character */
        int             trmsize;        /* size of terminator character */

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

        errn    = 0;
        wcount  = namlist->icount;              /* count of list items  */

        /* set up one set of variables to use where f77 mode */

        eqlchr  = OUT_EQ;
        sepchr  = OUT_SEP;
        nlchr   = OUT_CHAR;
        trmchr  = OUT_CHAR; 
        trmsize = 6;
        NLCHAR(OUT_ECHO);               /* blank or echo char   */
        NLCHAR(nlchr);                  /* ampersand or WNLDELM */

        wptr    = _fcdtocp(namlist->group_name); /* ptr to groupname    */
        wlen    = _fcdlen(namlist->group_name); /* len of groupname     */

        /* If length of groupname exceeds recl, put out an error */

        if ((wlen + 4) > cup->unmlsize) {
                errn    = FENLNMSZ;
                ERROR0(errf, css, errn);
        }

        /* Move namelist group name to output buffer    */

        for (icnt = 0; icnt < wlen; icnt++) {
                *cup->ulineptr++        = *wptr++;
                cup->ulinemax++;
        }

        NLCHAR(' ');                    /* write blank          */
        NLCHAR(' ');                    /* write blank          */

        /* WNLLINE specifies one variable per record            */

        NLINE();                        /* new line             */

        nlvar   = namlist->goli;                /* group object pointer */

        while (wcount-- && (errn == 0)) {
                varptr  = _fcdtocp(nlvar->goli_name);
                varlen  = _fcdlen(nlvar->goli_name);

                /* If length of variable name exceeds recl, issue an err */

                if (varlen > cup->unmlsize) {
                        /* error: group object name too big for rec size */
                        errn    = FENLNMSZ;
                        ERROR0(errf, css, errn);
                }
                else
                        if (varlen > (cup->unmlsize - cup->ulinemax)) {
                                NLWFLUSH();
                                NLCHAR(' ');            /* write blank  */
                                NLCHAR(' ');            /* write blank  */
                        }

                /* Write namelist group object name to output buffer */

                for (icnt = 0; icnt < varlen; icnt++) {
                        *cup->ulineptr++        = varptr[icnt];
                        cup->ulinemax++;
                }

                /* Flush output buffer if blank=blank will not fit */

                if ((cup->unmlsize - cup->ulinemax) < 3) {
                        NLWFLUSH();
                        NLCHAR(' ');                    /* write blank  */
                }

                /* Write equal size or replacement character after name */

                NLCHAR(' ');                    /* write blank          */
                NLCHAR(eqlchr);                 /* write equal sign     */
                NLCHAR(' ');                    /* write blank          */

                /* Setting ldwinit is needed before first call to _ld_write */

                css->u.fmt.u.le.ldwinit = 1;

                /* Write the value of the namelist group object */

                switch (nlvar->valtype) {

                case IO_SCALAR:
                {
                        void            *vaddr;
                        type_packet     tip;    /* Type information packet */
                        nmlist_scalar_t *nlscalar; /* nmlist scalar entry */

                        nlscalar        = nlvar->goli_addr.ptr;
                        tip.type90      = nlscalar->tinfo.type;
                        tip.type77      = -1;
                        tip.intlen      = nlscalar->tinfo.int_len;
                        tip.extlen      = tip.intlen;
                        tip.elsize      = tip.intlen >> 3;
                        tip.cnvindx     = 0;
                        tip.count       = 1;
                        tip.stride      = 1;

                        /* Assertions */

                        assert (tip.type90 >= DVTYPE_TYPELESS &&
                                tip.type90 <= DVTYPE_ASCII);
                        assert (tip.intlen > 0);

                        if (tip.type90 == DVTYPE_ASCII) {
                                vaddr           = _fcdtocp(nlscalar->scal_addr.charptr);

                                tip.elsize      = tip.elsize *
                                                _fcdlen(nlscalar->scal_addr.charptr);
                        }
                        else
                                vaddr   = nlscalar->scal_addr.ptr;

                        /* Do not allow double complex for 77 mode */

                        if ((tip.type90 == DVTYPE_COMPLEX &&
                             tip.elsize == (sizeof(_f_dble) * 2)))
                                errn    = FENLDBCP;
                        else /* Use list-directed write */
                                errn    = _ld_write(css, cup, vaddr, &tip, 0);

                        break;
                }

                case IO_DOPEVEC:
                {
                        register short  nc;
                        register long   extent;
                        void            *vaddr;
                        type_packet     tip;
                        DopeVectorType  *nldv;

                        nldv    = nlvar->goli_addr.dv; /* ptr to dope vec */

                        /* Assertions */

                        assert (nldv != NULL);
                        assert (nldv->type_lens.int_len > 0);

                        tip.type90      = nldv->type_lens.type;
                        tip.type77      = -1;
                        tip.intlen      = nldv->type_lens.int_len;
                        tip.extlen      = tip.intlen;
                        tip.elsize      = tip.intlen >> 3;
                        tip.cnvindx     = 0;
                        tip.stride      = 1;

                        if (tip.type90 == DVTYPE_ASCII) {
                                vaddr           = _fcdtocp(nldv->base_addr.charptr);
                                tip.elsize      = tip.elsize *
                                                _fcdlen(nldv->base_addr.charptr);
                        }
                        else
                                vaddr   = nldv->base_addr.a.ptr;

                        extent  = 1;

                        for (nc = 0; nc < nldv->n_dim; nc++)
                                extent  = extent * nldv->dimension[nc].extent;

                        tip.count       = extent;

                        /* Assertions */

                        assert (tip.elsize > 0 && extent > 0);

                        /* Do not allow double complex for 77 mode */

                        if ((tip.type90 == DVTYPE_COMPLEX &&
                             tip.elsize == (sizeof(_f_dble) * 2)))
                                errn    = FENLDBCP;
                        else /* Use list-directed write */
                                errn    = _ld_write(css, cup, vaddr, &tip, 0);

                        break;
                }

                case IO_STRUC_A:
                case IO_STRUC_S:
                {
                        /* Do not allow structures for 77 mode */
                        errn    = FENLSTCT;
                }

                default:
                        errn    = FEINTUNK;     /* Internal error */
                } /* switch */

                if (errn != 0) {
                        ERROR0(errf, css, errn);
                }

                /* Flush out last item to record buffer */

                errn    = _ld_write(css, cup, (void *) NULL, &__tip_null, 0);

                if (errn != 0) {
                        ERROR0(errf, css, errn);
                }

                if (wcount > 0) {
                        if ((cup->unmlsize - cup->ulinemax) < 2) {
                                NLWFLUSH();
                                NLCHAR(' ');    /* write delimiter */
                                NLCHAR(' ');    /* write delimiter */
                                css->u.fmt.u.le.ldwinit = 1;/* suppress comma */
                        }
                        else {
                                NLCHAR(sepchr); /* write comma */
                                NLCHAR(' ');    /* write delimiter */
                                css->u.fmt.u.le.ldwinit = 1;/* suppress comma */
                                NLINE();         /* new line    */
                        }
                }

#if     defined(__mips) && (_MIPS_SZLONG == 32)
                nlvar   = (nmlist_goli_t*)((long *)nlvar + 3 +
                                (sizeof(_fcd))/(sizeof(long)));
#else
                nlvar   = (nmlist_goli_t*)((long *)nlvar + 2 +
                                (sizeof(_fcd))/(sizeof(long)));
#endif
        }

        if (cup->ulinemax > 2) {
                NLINE();         /* new line    */
        }

        if ((cup->unmlsize - cup->ulinemax) < trmsize) {
                NLWFLUSH();
                NLCHAR(' ');                    /* write blank  */
        }

        /* CF77 ends namelist with compat character (does accept slash) */

        NLCHAR(' ');                    /* write blank  */
        NLCHAR(trmchr);                 /* write ending slash   */
        NLCHAR('E');                    /* write END            */
        NLCHAR('N');
        NLCHAR('D');
        NLWFLUSH();

        if (errn != 0)
                cup->uflag      = cup->uflag | _UERRC;  /* Set error status */

/****************************************************************************
 *
 *      Statement Finalization Section
 *
 ***************************************************************************/
finalization:
        return(errn);
}