C<wpw>
C<wpw>
C<wpw>
C<wpw>
C<wpw>
C maximum field for integer strings
C max card size
C must be 2 more than MAXCARD
C<wpw>
C must be highest lu for standard files
C<wpw>
C<wpw>
C<wpw>
C<wpw>
C initr4 - initialize standard files
      SUBROUTINE INITR4
      COMMON/FCOMR/MXFILE, ACTUN(6)
      BYTE ACTUN
      INTEGER MXFILE
      COMMON/FCOMR2/TIIN
      LOGICAL TIIN
      COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD
      BYTE ARGSTR
      LOGICAL UPFLAG, NOREAD
      COMMON/RAT401/LASTC, BUF
      BYTE BUF(134)
      INTEGER LASTC
      INTEGER IER, I
      LASTC = 1
      BUF(LASTC) = 13
      DO 2000 I = 1, 6
        ACTUN(I) = 0
2000  CONTINUE
2010  CONTINUE
      MXFILE = 6
C fold commands to upper case
      UPFLAG = .TRUE.
C haven't read command line yet
      NOREAD = .TRUE.
      CALL OPN(3, 'TI:', 'W', IER)
      IF (.NOT.(IER .NE. 0)) GOTO 2020
        STOP'can''t open ERROUT'
2020  CONTINUE
C open with carriagecontrol=fortran
      CALL OPN(5, 'TI:', 'F', IER)
      IF (.NOT.(IER .NE. 0)) GOTO 2040
        CALL ERROR('can''t open STDIN.')
2040  CONTINUE
      TIIN = .TRUE.
      CALL OPN(2, 'TI:', 'W', IER)
      IF (.NOT.(IER .NE. 0)) GOTO 2060
        CALL ERROR('can''t open STDOUT.')
2060  CONTINUE
      CALL OPN(4, 'TI:', 'F', IER)
      IF (.NOT.(IER .NE. 0)) GOTO 2080
        CALL ERROR('can''t open CMDIN.')
2080  CONTINUE
C close error
      CALL ERRSET(28, .TRUE., .FALSE., .TRUE., .FALSE., 15)
C no such file
      CALL ERRSET(29, .TRUE., .FALSE., .TRUE., .FALSE., 15)
C open failure
      CALL ERRSET(30, .TRUE., .FALSE., .TRUE., .FALSE., 15)
C file name specification
      CALL ERRSET(43, .TRUE., .FALSE., .FALSE., .FALSE., 15)
      RETURN
      END
C endr4 - close up shop
      SUBROUTINE ENDR4
      CALL CLOSEC(2, 'S')
      CALL CLOSEC(5, 'S')
      CALL CLOSEC(3, 'S')
      CALL EXIT
      END
C create - open a new file
      INTEGER FUNCTION CREATE(NAME, STAT)
      BYTE NAME(1)
      INTEGER OPEN
      BYTE STAT
      CREATE = OPEN(NAME, STAT)
      IF (.NOT.(CREATE .EQ. -1)) GOTO 2100
        CALL PUTLIN(NAME, 3)
        CALL REMARK(': can''t create.')
2100  CONTINUE
      RETURN
      END
C openc - open a file, print can't message if error
      INTEGER FUNCTION OPENC(NAME, STAT)
      BYTE NAME(1), STAT
      INTEGER OPEN
      OPENC = OPEN(NAME, STAT)
      IF (.NOT.(OPENC .EQ. -1)) GOTO 2120
        CALL PUTLIN(NAME, 3)
        CALL REMARK(': can''t open.')
2120  CONTINUE
      RETURN
      END
C open - open a file
      INTEGER FUNCTION OPEN(NAME, STAT)
      BYTE NAME(1), STAT, BUF(34)
      INTEGER IER
      COMMON/FCOMR/MXFILE, ACTUN(6)
      BYTE ACTUN
      INTEGER MXFILE
      COMMON/FCOMR2/TIIN
      LOGICAL TIIN
      CALL SCOPY(NAME, 1, BUF, 1)
      IF (.NOT.(STAT .NE. 'P')) GOTO 2140
        CALL DEFNAM(BUF, 'SY:', 0, 0)
2140  CONTINUE
      DO 2160 I = 1, MXFILE
        IF (.NOT.(ACTUN(I) .NE. 0)) GOTO 2180
          GOTO 2160
2180    CONTINUE
        CALL OPN(I + 6, BUF, STAT, IER)
        IF (.NOT.(IER.NE.0)) GOTO 2200
          OPEN =  - 1
          GOTO 2210
2200     CONTINUE
          OPEN = I + 6
          ACTUN(I) = STAT
2210    CONTINUE
        RETURN
2160  CONTINUE
2170  CONTINUE
      CALL REMARK('too many files opened.')
      OPEN =  - 1
      RETURN
      END
C closec - close a file, print message if error
      INTEGER FUNCTION CLOSEC(F, STAT)
      BYTE STAT
      INTEGER F, CLOSEL
      CLOSEC = CLOSEL(F, STAT)
      IF (.NOT.(CLOSEC .EQ. -1)) GOTO 2220
        CALL REMARK('error closing file.')
2220  CONTINUE
      RETURN
      END
C close - close a file
      SUBROUTINE CLOSE(F)
      INTEGER F
      CALL CLOSEL(F, 'S')
      RETURN
      END
C closel - close a file
      INTEGER FUNCTION CLOSEL(IUNIT, STAT)
      COMMON/FCOMR/MXFILE, ACTUN(6)
      BYTE ACTUN
      INTEGER MXFILE
      COMMON/FCOMR2/TIIN
      LOGICAL TIIN
      INTEGER IUNIT
      BYTE STAT
      CLOSEL =  - 1
      IF (.NOT.(IUNIT .GT. 6)) GOTO 2240
        IF (.NOT.(ACTUN(IUNIT-6) .EQ. 0)) GOTO 2260
          CLOSEL = 1
          RETURN
2260    CONTINUE
2240  CONTINUE
      IF (.NOT.(STAT .EQ. 'S')) GOTO 2280
      close(unit=iunit,dispose='KEEP',err=99)
        GOTO 2290
2280   CONTINUE
        IF (.NOT.(STAT .EQ. 'D')) GOTO 2300
      close(unit=iunit,dispose='DELETE',err=999)
          GOTO 2310
2300     CONTINUE
          IF (.NOT.(STAT .EQ. 'P')) GOTO 2320
      close(unit=iunit,dispose='PRINT',err=999)
            GOTO 2330
2320       CONTINUE
            CALL REMARK('illegal command in closel.')
            RETURN
2330      CONTINUE
2310    CONTINUE
2290  CONTINUE
      IF (.NOT.(IUNIT .GT. 6)) GOTO 2340
        ACTUN(IUNIT - 6) = 0
2340  CONTINUE
      CLOSEL = 1
99    CONTINUE
      RETURN
999   CONTINUE
      close(unit=iunit, dispose='KEEP', err=99)
      IF (.NOT.(IUNIT .GT. 6)) GOTO 2360
        ACTUN(IUNIT - 6) = 0
2360  CONTINUE
      RETURN
      END
C cant - print can't open file message and stop
C<wpw>
      SUBROUTINE CANT(BUF)
      BYTE BUF(1)
      CALL PUTLIN(BUF, 3)
      CALL REMARK(': can''t open.')
      CALL EXIT
      END
C defnam - add default device, uic, and extension to filename if not present
      SUBROUTINE DEFNAM(FILE, DEV, UIC, EXT)
      BYTE FILE(1), EXT(1), DEV(1), UIC(1), TFILE(34)
      INTEGER I, CONCAT, LENGTH, INDEX
      IF (.NOT.(FILE(LENGTH(FILE)) .EQ. ':')) GOTO 2380
        RETURN
2380  CONTINUE
      CALL SCOPY(FILE, 1, TFILE, 1)
      FILE(1) = 0
      IF (.NOT.(DEV(1) .NE. 0)) GOTO 2400
        IF (.NOT.(INDEX(TFILE, ':') .EQ. 0)) GOTO 2420
          I = CONCAT(FILE, DEV, 34)
2420    CONTINUE
2400  CONTINUE
      IF (.NOT.(UIC(1) .NE. 0)) GOTO 2440
        IF (.NOT.(INDEX(TFILE, '[') .EQ. 0)) GOTO 2460
          I = CONCAT(FILE, UIC, 34)
2460    CONTINUE
2440  CONTINUE
      I = CONCAT(FILE, TFILE, 34)
      IF (.NOT.(INDEX(TFILE, '.') .EQ. 0)) GOTO 2480
        I = CONCAT(FILE, '.', 34)
        I = CONCAT(FILE, EXT, 34)
2480  CONTINUE
      RETURN
      END
C error - print fatal error message, then die
      SUBROUTINE ERROR(BUF)
      BYTE BUF(1)
      CALL REMARK(BUF)
      CALL EXIT
      END
C outlin - output a line
      SUBROUTINE OUTLIN(BUF, F)
      BYTE BUF(1)
      INTEGER F
      CALL PUTLIN(BUF, F)
      CALL PUTCH(13, F)
      RETURN
      END
C remark - print message; assure NEWLINE
      SUBROUTINE REMARK(LINE)
      BYTE LINE(1)
      INTEGER I
      I = 1
2500  IF (.NOT.(LINE(I) .NE. 0)) GOTO 2520
        IF (.NOT.(LINE(I) .EQ. '.' .AND. LINE(I+1) .EQ. 0)) GOTO 2530
          GOTO 2520
2530    CONTINUE
        CALL PUTCH(LINE(I), 3)
2510    I = I + 1
        GOTO 2500
2520  CONTINUE
      IF (.NOT.(I .EQ. 1)) GOTO 2550
        CALL PUTCH(13, 3)
        GOTO 2560
2550   CONTINUE
        IF (.NOT.(LINE(I-1) .NE. 13)) GOTO 2570
          CALL PUTCH(13, 3)
2570    CONTINUE
2560  CONTINUE
      RETURN
      END
C getrec - read a record and insert NEWLIN and EOS
      INTEGER FUNCTION GETREC(BUF, F)
      BYTE BUF(1), NBUF(10)
      INTEGER F, NC, IER, CLOSEL
      COMMON/FCOMR/MXFILE, ACTUN(6)
      BYTE ACTUN
      INTEGER MXFILE
      COMMON/FCOMR2/TIIN
      LOGICAL TIIN
10    CONTINUE
      CALL GET(F, BUF, 132, NC)
      IF (.NOT.(NC .LT. 0)) GOTO 2590
        IF (.NOT.(NC .EQ. -10)) GOTO 2610
          GETREC =  - 10
          BUF(1) =  - 10
          BUF(2) = 0
          IF (.NOT.(F .EQ. 5)) GOTO 2630
C close, then reopen STDIN
            IF (.NOT.(CLOSEL(5, 'S') .EQ. -1)) GOTO 2650
              CALL ERROR('can''t close STDIN in getrec.')
2650        CONTINUE
            CALL OPN(5, 'TI:', 'F', IER)
            IF (.NOT.(IER .NE. 0)) GOTO 2670
              CALL ERROR('can''t open STDIN in getrec.')
2670        CONTINUE
            TIIN = .TRUE.
2630      CONTINUE
          GOTO 2620
2610     CONTINUE
          CALL PUTLIN('fcs error code ', 3)
          CALL ITOC(NC, NBUF, 10)
          CALL PUTLIN(NBUF, 3)
          CALL REMARK(' returned in getrec.')
          IF (.NOT.(.TRUE.)) GOTO 2690
            GOTO 10
2690      CONTINUE
2620    CONTINUE
        GOTO 2600
2590   CONTINUE
        GETREC = NC + 1
        BUF(GETREC) = 13
        BUF(GETREC + 1) = 0
2600  CONTINUE
      RETURN
      END
C getlin - get a line from a file
      INTEGER FUNCTION GETLIN(INBUF, IN)
      COMMON/RAT401/LASTC, BUF
      BYTE BUF(134)
      INTEGER LASTC
      BYTE INBUF(1)
      INTEGER IN, GETREC
      IF (.NOT.(BUF(LASTC) .NE. 13)) GOTO 2710
C still some chars in buf
        GETLIN = 0
2730    CONTINUE
          LASTC = LASTC + 1
          GETLIN = GETLIN + 1
          INBUF(GETLIN) = BUF(LASTC)
2740      IF (.NOT.(BUF(LASTC) .EQ. 13)) GOTO 2730
2750    CONTINUE
        INBUF(GETLIN + 1) = 0
        GOTO 2720
2710   CONTINUE
        GETLIN = GETREC(INBUF, IN)
2720  CONTINUE
      RETURN
C$# getlin - get a line from a file
C$   integer function getlin(buf,in)
C$   character buf(MAXLINE)
C$   character c, getch
C$   integer in,i
C$   i = 0
C$   repeat {
C$      i = i+1
C$      buf(i) = getch(c,in)
C$      }
C$      until (buf(i) == NEWLINE  |  buf(i) == EOF)
C$   if (buf(i) == EOF) getlin = EOF
C$   else getlin = i
C$   if (i >= MAXLINE) call error('buffer overflow in getlin.')
C$   else buf(i+1) = EOS
C$   return
C$   end
      END
C getch - get characters from file
      BYTE FUNCTION GETCH(C, F)
      COMMON/RAT401/LASTC, BUF
      BYTE BUF(134)
      INTEGER LASTC
      BYTE C
      INTEGER F, NC, GETREC
      IF (.NOT.(BUF(LASTC) .EQ. 13)) GOTO 2760
        NC = GETREC(BUF, F)
        IF (.NOT.(NC .GE. 0)) GOTO 2780
          LASTC = 0
          GOTO 2790
2780     CONTINUE
          C =  - 10
          GETCH =  - 10
          BUF(3) = 13
          LASTC = 3
          RETURN
2790    CONTINUE
2760  CONTINUE
      LASTC = LASTC + 1
      C = BUF(LASTC)
      GETCH = C
      RETURN
C$# getch - get characters from file
C$   character function getch(c, f)      #<wpw>     integer->character
C$   character buf(MAXLINE), c, buf2(MAXCARD)
C$   integer f, i, lastc, nc
C$   equivalence (buf, buf2)
C$   data lastc /MAXLINE/, buf(MAXLINE) /NEWLINE/
C$   # note: MAXLINE = MAXCARD + 1
C$   if (buf(lastc) == NEWLINE | lastc >= MAXLINE) {
C$      read(f, 1, end=10) nc, buf2
C$         1 format(q,MAXCARD a1)
C$      buf(nc+1) = NEWLINE
C$      lastc = 0
C$      }
C$   lastc = lastc + 1
C$   c = buf(lastc)
C$   getch = c
C$   return
C$ 10   c = EOF
C$   getch = EOF
C$   return
C$   end
      END
C putch - put characters
      SUBROUTINE PUTCH(C, F)
      BYTE BUF(134), C, NBUF(10)
      INTEGER F, ISTAT, LASTC, CONCAT
      DATA LASTC/0/
      IF (.NOT.(LASTC .GE. 132 .OR. C .EQ. 13)) GOTO 2800
        CALL PUT(F, BUF, LASTC, ISTAT)
        IF (.NOT.(ISTAT .NE. 0)) GOTO 2820
          LASTC = ITOC(ISTAT, NBUF, 10)
          CALL SCOPY('fcs error code ', 1, BUF, 1)
          LASTC = CONCAT(BUF, NBUF, 134)
          LASTC = CONCAT(BUF, ' returned in putch', 134)
          CALL PUT(3, BUF, LASTC, ISTAT)
          STOP'putch'
2820    CONTINUE
        LASTC = 0
        IF (.NOT.(C .EQ. 13)) GOTO 2840
          RETURN
2840    CONTINUE
2800  CONTINUE
      LASTC = LASTC + 1
      BUF(LASTC) = C
      RETURN
      END
C putlin - put out line by repeated calls to putch
      SUBROUTINE PUTLIN(B, F)
      BYTE B(1)
      INTEGER F, I
      I = 1
2860  IF (.NOT.(B(I) .NE. 0)) GOTO 2880
        CALL PUTCH(B(I), F)
2870    I = I + 1
        GOTO 2860
2880  CONTINUE
      RETURN
      END
C usrbin - get name of major tools utility directory
C           CHANGE FOR EACH SYSTEM
      SUBROUTINE USRBIN(NAME)
      BYTE NAME(1)
C Insert the name of the directory where all the tools are kept
      CALL SCOPY('DP1:[6,110]', 1, NAME, 1)
      RETURN
      END