/* Subroutine idate(i,j,k) sets i to month, j to day of month,
   k to year minus 1900. */

#include <time.h>
#include <sys/types.h>
#include <sys/times.h>

struct tm *localtime();
long time();

int idate_(i, j, k)
long int *i, *j, *k;
{
struct tm *t;
long tloc;

tloc = time(0);
t = localtime(&tloc);
*i = t->tm_mon + 1;
*j = t->tm_mday;
*k = t->tm_year;
return 0;
}
/*  Fortran-callable tape read/write routines...
*
*  calling sequences:
*
*       tropen(unit, ierr, name, *errlab)
*       twopen(unit, ierr, name, *errlab)
*       tread (unit, ierr, buf, buflen, *errlab)
*       twrite(unit, ierr, buf, buflen, *errlab)
*       trwind(unit, ierr, *errlab)
*       tclose(unit, ierr, *errlab)
*
*  where the Fortran types are
*
*       integer unit, ierr, buflen
*       character*(*) name, buf
*
*  `unit' is similar to a standard Fortran i/o unit number, except
*    that there are no restrictions on its sign or magnitude and
*    it has a life independent of the true Fortran unit numbers.
*    Several tape files can be open at once:  the only limit is
*    that imposed by the operating system on how may files may
*    be open at once.
*
*  `ierr' is assigned a return code:  0 means all went well,
*    -1 means end of file (for tread), and other (negative) values
*    mean something went wrong.  For tread (only), positive
*    values of ierr are also possible, implying that buf was
*    filled with fewer than buflen characters.  (In this case
*    tread fills the remaining character positions of buf with
*    blanks.)
*
*  `name' must contain a valid path name.  Spaces, tabs, newlines,
*    and NULs terminate the pathname, though no such delimiter is
*    required.
*
*  `buf' can be of any type.
*
*  `errlab' is a label to which control will go if something goes
*    wrong.  This argument may be omitted.
*
*  Written by David M. Gay.
*/

#include <stdio.h>
/* The following three included files are not present in every version of UNIX.
*  They are used when TAPE rewind code in TRWIND is activated.
#include <ctype.h>
#include <sys/types.h>
#include <sys/mtio.h>
*/

struct openlist {
        struct openlist *next;
        long int unit;
        int fileds, mode;
        char fname[1];
        };

static struct openlist *first = NULL;
struct openlist *malloc();

int nlen(name, namelen)
register char *name;
register long int namelen;
{
register int i;
register char c;

for (i = 0; i < namelen; i++) {
        c = *name++;
        if (!c || c == ' ' || c == '\t' || c == '\n') break;
        }
return i;
}

int topen(unit, name, ierr, namelen, mode)
long int *unit, *ierr, namelen;
char *name;
int mode;
{
int i, nl;
long int u;
struct openlist *p;

u = *unit;

for (p = first; p != NULL; p = p->next) {
        if (p->unit == u) {
                if (strcmp(p->fname, name)) {
                        i = tclose_(unit, ierr);
                        if (i) return i;
                        break;
                        }
                else {if (p->mode == mode) break;
                      else {
                        if (mode) {  /* if opening for reading  and unit was
                                        open for writing */
                                i = tclose_(unit, ierr);
                                if (i) return i;
                                break;
                                }
                        else {
                              fprintf(stderr,
                               "tropen(%ld,'%s'): already open for writing\n",
                                u, p->fname);
                              *ierr = -2;
                              return 1;
                              }
                           }
                     }
                }
        }
nl = nlen(name, namelen);
p = malloc(nl + sizeof(struct openlist));
if (!p) {
        fprintf("topen: malloc fails!\n");
        *ierr = -3;
        return 1;
        }
for (i = 0; i < nl; i++) p->fname[i] = name[i];
p->fname[nl] = 0;
p->fileds = i = mode ? creat(p->fname,-1) : open(p->fname,0);
if (i < 0) {
        perror(p->fname);
        *ierr = -2;
        free(p);
        return 1;
        }
p->unit = u;
p->mode = mode;
p->next = first;
first = p;
return 0;
}

int tropen_(unit, ierr, name, namelen)
long int *unit, *ierr, namelen;
char *name;
{
return topen(unit, name, ierr, namelen, 0);
}

int twopen_(unit, ierr, name, namelen)
long int *unit, *ierr, namelen;
char *name;
{
return topen(unit, name, ierr, namelen, 1);
}

int tread_(unit, ierr, buf, len)
long int *unit, *len, *ierr;
char *buf;
{
struct openlist *p;
long int u;
int bs, i;

u = *unit;
for (p = first; p != NULL; p = p->next) {
        if (u == p->unit) {
                if (p->mode != 0) {
                        fprintf(stderr,
                        "tread attempted on unit %ld = open for writing\n",
                                u);
                        *ierr = -3;
                        return 1;
                        }
                bs = *len;
                if (bs <= 0) {
                        fprintf("tread called with buflen = %d\n", bs);
                        *ierr = -4;
                        return 1;
                        }
                i = read(p->fileds, buf, bs);
                *ierr = 0;
                if (i == bs) return 0;
                if (i == 0) {
                        *ierr = -1;
                        return 1;
                        }
                if (i > 0) {
                        *ierr = bs - i;
                        for (; i < bs; i++) buf[i] = ' ';
                        return 1;
                        }
                fprintf(stderr,"tread, unit %ld:  return code %d from ",
                        u, i);
                perror("read");
                *ierr = -4;
                return 1;
                }
        }
fprintf(stderr, "tread: unit %ld not open\n", u);
*ierr = -5;
return 1;
}

int twrite_(unit, ierr, buf, len)
long int *unit, *len, *ierr;
char *buf;
{
struct openlist *p;
long int u;
int bs, i;

u = *unit;
for (p = first; p != NULL; p = p->next) {
        if (u == p->unit) {
                if (p->mode != 1) {
                        fprintf(stderr,
                        "twrite attempted on unit %ld = open for reading\n",
                                u);
                        *ierr = -3;
                        return 1;
                        }
                bs = *len;
                if (bs <= 0) {
                        fprintf("twrite called with buflen = %d\n", bs);
                        *ierr = -4;
                        return 1;
                        }
                i = write(p->fileds, buf, bs);
                if (i == bs) {
                        *ierr = 0;
                        return 0;
                        }
                if (i >= 0) {
                        fprintf(stderr,
                        "twrite, unit %ld: %d bytes instead of %d written\n",
                                i, bs);
                        *ierr = -6;
                        return 1;
                        }
                fprintf(stderr,
                        "twrite, unit %ld:  return code %d from ", u, i);
                perror("write");
                *ierr = -4;
                return 1;
                }
        }
fprintf(stderr, "twrite: unit %ld not open\n", u);
*ierr = -5;
return 1;
}

int tclose_(unit, ierr)
long int *unit, *ierr;
{
struct openlist *p, *prev;
long int u;
int i;

u = *unit;
prev = (struct openlist *) &first;
for (p = first; p != NULL; p = p->next) {
        if (u == p->unit) {
                i = close(p->fileds);
                prev->next = p->next;
                free(p);
                if (i) {
                        fprintf(stderr,
                        "tclose, unit %ld:  Return code %d from ", u, i);
                        perror("close");
                        *ierr = -7;
                        return 1;
                        }
                *ierr = 0;
                return 0;
                }
        prev = p;
        }
fprintf(stderr, "tclose: unit %ld not open\n", u);
*ierr = -8;
return 1;
}

int trwind_(unit, ierr)
long int *unit, *ierr;
{
/* struct MTOP is used when TAPE rewind is activated.  IF the function
*  is provided by your version of UNIX, you should use REWIND carefully
*  because it will position the tape to load point, not necessarily to
*  the beginning of the file in use at the time the REWIND command was
*  issued.
struct mtop mtc;
*/
struct openlist *p;
long int u;
int i;
long lseek();

u = *unit;
*ierr = 0;
for (p = first; p != NULL; p = p->next) {
        if (u == p->unit) {
                /* The following 5 statements try to REWIND a TAPE.
                *  The REWIND function is not present in all versions
                *  of UNIX.  When present, it should be used carefully,
                *  because it positions the tape at load point, it does
                *  not seek back to the beginning of the file.
                mtc.mt_count = 1;
                mtc.mt_op = MTREW;
                i = ioct(p->fileds, MTIOCTOP, &mtc);
                if (i >= 0) return 0;
                if (i == -1) */
                  if (!lseek(p->fileds, 0L, 0)) return 0;
                fprintf(stderr, "trwind of unit %ld = ``%s''", u,
                        p->fname);
                perror(" failed");
                *ierr = -9;
                return 1;
                }
        }
fprintf(stderr, "trwind: unit %ld not open\n", u);
*ierr = -8;
return 1;
}
