/SYS REGION=400K
/FILE SYSPRINT NAME($Y65:BBCMOS.LIS) NEW(REPL)
/FILE SYSPUNCH NAME($Y65:BBCMOS.OBJ) NEW(REPL)
/LOAD VSFORT
/OPT OPT(1),DECK,SOURCE,LIST
/JOB NOGO
C
C     BBC MOS emulation package. All communication from the 6502
C     emulator is carried out by calling the OPSYS routine.
C
      SUBROUTINE OPSYS
      IMPLICIT INTEGER (A-Z)
      INTEGER FLAGS /ZF0000000/
      LOGICAL UIO
      CHARACTER WRLINE*80,BUFFER*80,ERROR*80,ASCII(0:255),EBCDIC(0:255)
      CHARACTER CLS /Z70/
      COMMON /TABLES/ ASCII,EBCDIC
      COMMON /REGS/ A,X,Y,P,PC,SP
      COMMON /WRCH/ WRLINE,WRCPTR
      DATA TIME /0/
C
C     System calls :  1 - OSBYTE    2 - OSWORD   3 - OSWRCH   4 - OSRDCH
C                     5 - OSFILE    6 - OSARGS   7 - OSBGET   8 - OSBPUT
C                     9 - OSGBPB   10 - OSFIND  11 - OSFSC   12 - Others
C
      GOTO (1,2,3,4,5,6,7,8,9,10,11,12),PC-768
C
C     Perform selected OSBYTE calls
C
 1    IF (A.EQ.0) THEN
        IF (X.EQ.0) THEN
          CALL BRK(247,'OS 6.3|')
        ELSE
          X=6
        ENDIF
      ELSE IF (A.EQ.124.OR.A.EQ.126) THEN
        CALL WRMEM(255,0)
      ELSE IF (A.EQ.125) THEN
        CALL WRMEM(255,128)
      ELSE IF (A.EQ.129) THEN
        IF (Y.NE.255) CALL DELAY((X+256*Y)/100)
        X=0
        Y=0
        P=LAND(P,254+FLAGS)
      ELSE IF (A.EQ.130) THEN
        X=0
        Y=0
      ELSE IF (A.EQ.131) THEN
        X=0
        Y=8
      ELSE IF (A.EQ.132.OR.A.EQ.133) THEN
        X=0
        Y=247
      ELSE IF (A.EQ.218) THEN
      ELSE IF (A.EQ.11.OR.A.EQ.12.OR.A.EQ.15) THEN
      ELSE
        WRITE (6,1000) A
 1000   FORMAT(' *Unsupported OSBYTE call ',Z2)
        RETURN
      ENDIF
      RETURN
C
C     Read a line from the keyboard (OSWORD 0) Also do 1 and 2.
C     Note bug in BBC manuals - Y should NOT include CR.
C
 2    IF (A.GT.2) THEN
        WRITE (6,2000) A
 2000   FORMAT(' *Unsupported OSWORD call ',Z2)
        RETURN
      ENDIF
      GOTO (2100,2200,2300), A+1
 2100 CALL WRBUF
      CALL TEXTLC
      READ (9,2101) BUFFER
      CALL TEXTUC
 2101 FORMAT(A80)
      CBLK=X+256*Y
      ADDR=RDMEM(CBLK)+RDMEM(LAND(CBLK+1,65535))*256
      MAXLEN=RDMEM(LAND(CBLK+2,65535))
      Y=LOCATE(BUFFER,-80,' ',-1)
      IF (Y.GT.MAXLEN) Y=MAXLEN
      DO 2102 I=1,Y
        CALL WRMEM(LAND(ADDR+I-1,65535),BYTE(ASCII(BYTE(BUFFER(I:I)))))
 2102 CONTINUE
      CALL WRMEM(LAND(ADDR+Y,65535),13)
      P=LAND(P,254+FLAGS)
      RETURN
 2200 ADDR=X+Y*256
      CALL TSTIME(2,TEMP)
      TEMP=TEMP*100-TIME
      DO 2201 I=0,3
        CALL WRMEM(ADDR+I,TEMP/256**I)
 2201 CONTINUE
      CALL WRMEM(ADDR+4,0)
      RETURN
 2300 ADDR=X+Y*256
      CALL TSTIME(2,TIME)
      TIME=TIME*100
      DO 2301 I=0,3
        TIME=TIME+RDMEM(ADDR+I)*256**I
 2301 CONTINUE
      RETURN
C
C     OSWRCH - Write a character to the screen
C
 3    IF (A.GE.32.OR.A.EQ.10) THEN
        WRCPTR=WRCPTR+1
        WRLINE(WRCPTR:WRCPTR)=EBCDIC(A)
      ELSE IF (A.EQ.12) THEN
        CALL WRBUF
        WRITE (6,3000) CLS
 3000   FORMAT(A1)
      ENDIF
      IF (A.EQ.13.OR.WRCPTR.EQ.80) CALL WRBUF
      RETURN
C
C     OSRDCH (Very iffy!)
C
 4    CONTINUE
      CALL MFSETU(9)
      CALL MFIO(RC,'*.',0,80,BUFFER)
      P=LAND(P,254+FLAGS)
      IF (RC.NE.0) P=LOR(P,1)
      A=BYTE(ASCII(BYTE(BUFFER)))
      RETURN
C
C     OSFILE routines
C
 5    ADDR=X+Y*256
      FNAMEA=RDMEM(ADDR)+RDMEM(ADDR+1)*256
      DO 5000 I=0,63
        BUFFER(I+1:I+1)=EBCDIC(RDMEM(FNAMEA+I))
        IF (BUFFER(I+1:I+1).EQ.' ') GOTO 5001
 5000 CONTINUE
 5001 CONTINUE
      MLOAD=0
      MEXEC=0
      MSTRT=0
      MEND=0
      DO 5002 I=0,3
        MLOAD=MLOAD+RDMEM(ADDR+2+I)*256**I
        MEXEC=MEXEC+RDMEM(ADDR+6+I)*256**I
        MSTRT=MSTRT+RDMEM(ADDR+10+I)*256**I
        MEND=MEND+RDMEM(ADDR+14+I)*256**I
 5002 CONTINUE
      CALL FILINF(BUFFER,LOAD,EXEC,LENGTH,ATRIBS,LRECL,UIO,RC)
      IF (A.EQ.0) THEN
        IF (RC.NE.0) ATRIBS=4
        IF (LAND(ATRIBS,2).EQ.2) THEN
          CALL BRK(193,'Write not allowed|')
          A=1
          RETURN
        ENDIF
        LENGTH=MEND-MSTRT
        CALL SAVFIL(BUFFER,MSTRT,LENGTH)
        CALL WRCAT(BUFFER,MLOAD,MEXEC,LENGTH,ATRIBS)
      ELSE
        IF (RC.EQ.30.AND.A.EQ.255) CALL BRK(214,'File not found|')
        IF (RC.NE.0) THEN
          A=0
          RETURN
        ENDIF
        IF (A.GE.5) THEN
          DO 5003 I=0,3
            CALL WRMEM(ADDR+2+I,LOAD/256**I)
            CALL WRMEM(ADDR+6+I,EXEC/256**I)
            CALL WRMEM(ADDR+10+I,LENGTH/256**I)
            CALL WRMEM(ADDR+10+I,ATRIBS/256**I)
 5003     CONTINUE
        ENDIF
        IF (A.EQ.1) THEN
          CALL WRCAT(BUFFER,MLOAD,MEXEC,LENGTH,MEND)
        ELSE IF (A.EQ.2) THEN
          CALL WRCAT(BUFFER,MLOAD,EXEC,LENGTH,ATRIBS)
        ELSE IF (A.EQ.3) THEN
          CALL WRCAT(BUFFER,LOAD,MEXEC,LENGTH,ATRIBS)
        ELSE IF (A.EQ.4) THEN
          CALL WRCAT(BUFFER,LOAD,EXEC,LENGTH,MEND)
        ELSE IF (A.EQ.6) THEN
          IF (LAND(ATRIBS,8).EQ.8) THEN
            CALL BRK(195,'Delete not allowed|')
            A=1
            RETURN
          ENDIF
          CALL PURGE(-1,BUFFER,RC)
          IF (RC.NE.0) THEN
            WRITE (ERROR,5004) RC,BUFFER(:36)
 5004   FORMAT('MUSIC error ',I3, ' encountered deleting file ',A36,'|')
            CALL BRK(128,ERROR)
          ENDIF
        ELSE IF (A.EQ.255) THEN
          IF (LAND(ATRIBS,1).EQ.1) THEN
            CALL BRK(195,'Read not allowed|')
            A=1
            RETURN
          ENDIF
          IF (LAND(MEXEC,255).EQ.0) LOAD=MLOAD
          CALL LODFIL(BUFFER,LOAD,LENGTH,LRECL,UIO,RC)
        ENDIF
      ENDIF
      A=1
      RETURN
C
C     OSARGS
C
 6    CONTINUE
      IF (Y.EQ.0) THEN
        IF (A.EQ.0) THEN
          A=4
        ELSE IF (A.EQ.1) THEN
          CALL WRMEM(LAND(X+0,255),RUNADR)
          CALL WRMEM(LAND(X+1,255),RUNADR/256)
          CALL WRMEM(LAND(X+2,255),255)
          CALL WRMEM(LAND(X+3,255),255)
        ENDIF
      ENDIF
      RETURN
C
C     OSBGET
C
 7    CALL FILES(1,A,Y,0)
      RETURN
C
C     OSBPUT
C
 8    CALL FILES(2,A,Y,0)
      RETURN
C
C     OSGBPB
C
 9    CONTINUE
      RETURN
C
C     OSFIND
C
 10   IF (A.NE.0) THEN
        ADDR=X+Y*256
        BUFFER=' '
        DO 10000 I=0,63
          BUFFER(I+1:I+1)=EBCDIC(RDMEM(ADDR+I))
          IF (BUFFER(I+1:I+1).EQ.' ') GOTO 10001
10000   CONTINUE
10001   CONTINUE
      ENDIF
      IF (LAND(A,63).EQ.0) CALL FILES(A,A,Y,BUFFER)
      RETURN
C
C     OSFSC routines
C
 11   IF (A.EQ.2.OR.A.EQ.4) THEN
C       *RUN
        ADDR=X+Y*256
        DO 1100  I=0,79
          TEMP=RDMEM(ADDR+I)
          IF (TEMP.EQ.32.OR.TEMP.EQ.13) THEN
            BUFFER(I+1:I+1)=' '
            RUNADR=ADDR+I
            GOTO 1101
          ENDIF
          BUFFER(I+1:I+1)=EBCDIC(TEMP)
 1100   CONTINUE
 1101   CONTINUE
        DO 1102 I=0,79
          IF (RDMEM(RUNADR).NE.32) GOTO 1103
          RUNADR=RUNADR+1
 1102   CONTINUE
 1103   CONTINUE
        CALL FILINF(BUFFER,LOAD,EXEC,LENGTH,ATRIBS,LRECL,UIO,RC)
        IF (RC.EQ.30) CALL BRK(214,'File not found|')
        IF (RC.NE.0) RETURN
        IF (LAND(ATRIBS,4).EQ.4) THEN
          CALL BRK(195,'Execute not allowed|')
          RETURN
        ENDIF
        CALL LODFIL(BUFFER(LEN+1:),LOAD,LENGTH,LRECL,UIO,RC)
        IF (RC.NE.0) RETURN
        A=1
        CALL EXECUT(EXEC)
      ELSE IF (A.EQ.3) THEN
        CALL BRK(254,'Bad command|')
      ELSE IF (A.EQ.5) THEN
        CALL NXTCMD('DIR * X',7,228)
      ENDIF
      RETURN
C
C     Perform miscellaneous tasks, mainly from OSCLI
C
 12   IF (A.EQ.0) THEN
C       CALL NXTCMD('DEFINE PFn =WHATEVER',?,228)
      ELSE IF (A.EQ.1) THEN
C       Execute MUSIC command (*MUSIC)
        CALL FILL(BUFFER,80,' ')
        ADDR=X+256*Y
        DO 1201 I=0,79
          TEMP=RDMEM(ADDR+I)
          IF (TEMP.EQ.13) GOTO 1202
          BUFFER(I+1:I+1)=EBCDIC(TEMP)
 1201   CONTINUE
 1202   CONTINUE
        CALL NXTCMD(BUFFER,80,228)
      ENDIF
      RETURN
      END
C
C     Output the current screen buffer and start a new one
C
      SUBROUTINE WRBUF
      IMPLICIT INTEGER (A-Z)
      CHARACTER WRLINE*80
      COMMON /WRCH/ WRLINE,WRCPTR
      IF (WRCPTR.EQ.0) RETURN
      WRITE (6,*) WRLINE(:WRCPTR)
      WRCPTR=0
      RETURN
      END
C
C     Open a file and extract the BBC file attributes from the tag
C     Copy it into memory in the required position.
C
      SUBROUTINE FILINF(FILNAM,LOAD,EXEC,LENGTH,ATRIBS,LRECL,UIO,RC)
      IMPLICIT INTEGER (A-Z)
      INTEGER*2 INFO(10)
      CHARACTER FILNAM*64,TAG*64
      LOGICAL UIO
      COMMON /MFTAG/ TAG
      COMMON /MFINFO/ INFO
      CALL MFACT(RC,'EXTRACT.',-1,FILNAM)
      IF (RC.NE.0) THEN
        IF (RC.EQ.12) THEN
          CALL BRK(204,'Bad filename|')
        ELSE IF (RC.NE.30) THEN
          CALL BRK(128,'MUSIC error opening file|')
        ENDIF
        RETURN
      ENDIF
      CALL TOUC(TAG,9)
      IF (TAG(:9).NE.'BBC FILE ') THEN
        CALL BRK(128,'File is not a BBC file|')
        RC=-1
        RETURN
      ENDIF
      CALL X2I(TAG(10:17),8,LOAD,RC1,BAD)
      CALL X2I(TAG(19:26),8,EXEC,RC2,BAD)
      CALL X2I(TAG(28:35),8,LENGTH,RC3,BAD)
      IF (TAG(37:37).NE.'R'.AND.TAG(37:37).NE.' ') RC3=1
      IF (TAG(38:38).NE.'W'.AND.TAG(38:38).NE.' ') RC3=1
      IF (TAG(39:39).NE.'X'.AND.TAG(39:39).NE.' ') RC3=1
      IF (TAG(40:40).NE.'D'.AND.TAG(40:40).NE.' ') RC3=1
      IF (RC1+RC2+RC3.NE.0) THEN
        CALL BRK(128,'File attributes are incorrect|')
        RC=-1
        RETURN
      ENDIF
      ATRIBS=0
      IF (TAG(37:37).EQ.' ') ATRIBS=ATRIBS+1
      IF (TAG(38:38).EQ.' ') ATRIBS=ATRIBS+2
      IF (TAG(39:39).EQ.' ') ATRIBS=ATRIBS+4
      IF (TAG(40:40).EQ.' ') ATRIBS=ATRIBS+8
      LRECL=INFO(7)
      RECFM=BYTE(INFO(8))
      IF (RECFM.EQ.0) THEN
        UIO=.TRUE.
        LRECL=512
      ELSE
        UIO=.FALSE.
      ENDIF
      RETURN
      END
C
C     Load a file from disk into memory
C
      SUBROUTINE LODFIL(FILNAM,LOAD,LENGTH,LRECL,UIO,RC)
      IMPLICIT INTEGER (A-Z)
      CHARACTER FILNAM*64,RECORD(32760),ERROR*80
      LOGICAL UIO
      COMMON /OSFILE/ RECORD
      COMMON /MFPHYS/ RECLEN,RBA
      LOAD=LAND(LOAD,65535)
      CALL MFACT(RC,'OPEN OKOLD RDOK.',-1,FILNAM)
      IF (RC.NE.0) GOTO 3
      BYTES=0
    1   IF (UIO) THEN
          CALL MFIO(RC,'UIO RD.',0,LRECL,RECORD)
        ELSE
          CALL MFIO(RC,'IO RD.',0,LRECL,RECORD)
        ENDIF
        IF (RC.NE.0) GOTO 3
        DO 2 I=0,RECLEN-1
          IF (BYTES.GE.LENGTH) GOTO 5
          CALL WRMEM(LOAD+I,BYTE(RECORD(I+1)))
          BYTES=BYTES+1
    2   CONTINUE
        LOAD=LOAD+RECLEN
      GOTO 1
    3 IF (RC.GT.1) THEN
        WRITE (ERROR,4) RC,FILNAM(:36)
    4   FORMAT('MUSIC error ',I3, ' encountered reading file ',A36,'|')
        CALL BRK(128,ERROR)
      ENDIF
      IF (RC.EQ.1) RC=0
    5 CALL MFACT(RET,'CLOSE.',-1,FILNAM)
      RETURN
      END
C
C     Save a file onto disk from memory
C
      SUBROUTINE SAVFIL(FILNAM,START,LENGTH)
      IMPLICIT INTEGER (A-Z)
      CHARACTER FILNAM*64,RECORD(32760),ERROR*80
      INTEGER PRIV /Z0000C0C0/, F /Z0100/, FC /Z0200/
      INTEGER    PRIM, SEC, MAXK, ACCESS
      INTEGER*2  LRECL, RECFM
      COMMON /MFINFO/ PRIM,SEC,MAXK,LRECL,RECFM,ACCESS
      COMMON /OSFILE/ RECORD
      CALL PURGE(-1,FILNAM,RC)
      IF (RC.NE.0.AND.RC.NE.30) THEN
        WRITE (ERROR,4) RC,FILNAM(:36)
        CALL BRK(128,ERROR)
        RETURN
      ENDIF
      PRIM=LENGTH/1024 + 2
      SEC=0
      MAXK=-1
      LRECL=256
      RECFM=F
      ACCESS=PRIV
      CALL MFACT(RC,'OPEN OKNEW WROK.',-1,FILNAM)
      IF (RC.NE.0) GOTO 3
      PAGES=(LENGTH+255)/256
    1 IF (PAGES.EQ.0) GOTO 5
        DO 2 I=0,255
          CALL LBMOVE(RDMEM(START+I),4,RECORD(I+1),1,1)
    2   CONTINUE
        CALL MFIO(RC,'IO WR.',0,256,RECORD)
        IF (RC.NE.0) GOTO 3
        PAGES=PAGES-1
        START=START+256
      GOTO 1
    3 WRITE (ERROR,4) RC,FILNAM(:36)
    4 FORMAT('MUSIC error ',I3, ' encountered writing file ',A36,'|')
      CALL BRK(128,ERROR)
    5 CALL MFACT(RET,'CLOSE RLSE.',-1,FILNAM)
      RETURN
      END
C
C     Write the catalogue entry (tag) for a BBC file
C
      SUBROUTINE WRCAT(FILNAM,LOAD,EXEC,LENGTH,ATRIBS)
      IMPLICIT INTEGER (A-Z)
      CHARACTER FILNAM*64,TAG*64
      COMMON /MFTAG/ TAG
      CALL MFACT(RC,'OPEN OKOLD WROK.',-1,FILNAM)
      TAG='BBC file '
      CALL I2X(LOAD,TAG(10:17))
      CALL I2X(EXEC,TAG(19:26))
      CALL I2X(LENGTH,TAG(28:35))
      IF (LAND(ATRIBS,1).EQ.0) TAG(37:37)='R'
      IF (LAND(ATRIBS,2).EQ.0) TAG(38:38)='W'
      IF (LAND(ATRIBS,4).EQ.0) TAG(39:39)='X'
      IF (LAND(ATRIBS,8).EQ.0) TAG(40:40)='D'
      CALL MFACT(RC,'CLOSE RLSE CTAG.',-1,FILNAM)
      RETURN
      END
C
C     Error encountered in OS. Write a BRK plus message to the end of
C     the stack and execute it - paged rom style.
C
      SUBROUTINE BRK(ERR,ERRSTR)
      IMPLICIT INTEGER (A-Z)
      CHARACTER ERRSTR*80,ASCII(0:255),EBCDIC(0:255)
      COMMON /TABLES/ ASCII,EBCDIC
      CALL WRMEM(256,0)
      CALL WRMEM(257,ERR)
      I=1
    1   CALL WRMEM(257+I,BYTE(ASCII(BYTE(ERRSTR(I:I)))))
        I=I+1
        IF (ERRSTR(I:I).NE.'|') GOTO 1
      CALL WRMEM(257+I,0)
      CALL EXECUT(256)
      RETURN
      END
C
C     Fix the return address on the stack to start execution elsewhere
C
      SUBROUTINE EXECUT(ADDR)
      IMPLICIT INTEGER (A-Z)
      COMMON /REGS/ A,X,Y,P,PC,SP
      CALL WRMEM(SP+256,LAND(ADDR-1,65280)/256)
      SP=LAND(SP-1,255)
      CALL WRMEM(SP+256,LAND(ADDR-1,255))
      SP=LAND(SP-1,255)
      RETURN
      END
C
C     Carry out OSFIND, OSBGET, OSBPUT, OSARGS, OSGBPB
C
      SUBROUTINE FILES(CODE,A,Y,FILNAM)
C
C     OPNFLS : Word 1  bit 0 - Read allowed on this file
C                      bit 1 - Write allowed on this file
C                      bit 4 - EOF warning has been given
C                      bit 5 - Length has exceeded cat length
C                      bit 6 - Sector in memory must be written to disk
C                      bit 7 - Sector in memory contains PTR
C
C                      bits 8 - ?  : Sector number in memory
C
C              Word 2  Internal MUSIC unit number
C
C              Word 3  Files MUSIC record length
C
C              Word 4
C
      IMPLICIT INTEGER (A-Z)
      CHARACTER*64 OPNFNM(10),BUFFER*256(10)
      INTEGER OPNFLS(10,4) /40*0/,PTR(10),EXT(10)
      CHARACTER FILNAM*64,ERROR*80
      INTEGER PRIV /Z0000C0C0/, F /Z0100/, FC /Z0200/, FLAGS /ZF0000000/
      INTEGER*2 LRECL,RECFM
      INTEGER    PRIM, SEC, MAXK, ACCESS
      COMMON /MFINFO/ PRIM,SEC,MAXK,LRECL,RECFM,ACCESS
      IF (CODE.LT.5.AND.(CODE.NE.0.OR.Y.NE.0)) THEN
        IF (OPNFLS(Y,1).EQ.0) THEN
          CALL BRK(222,'Bad file channel|')
          RETURN
        ENDIF
      ENDIF
C
C     OSBGET
C
      IF (CODE.EQ.1) THEN
        IF (LAND(OPNFLS(Y,1),1).EQ.0) THEN
          CALL BRK(195,'Read not allowed|')
          RETURN
        ENDIF
        IF (PTR(Y).GE.EXT(Y)) THEN
          IF (LAND(OPNFLS(Y,1),16).NE.0) THEN
            CALL BRK(223,'EOF|')
            RETURN
          ELSE
            OPNFLS(Y,1)=LOR(OPNFLS(Y,1),16)
            P=LOR(P,1)
            A=254
            RETURN
          ENDIF
        ENDIF
        IF (LAND(OPNFLS(Y,1),128).EQ.0) THEN
          CALL MFSETU(OPNFLS(Y,2))
          IF (LAND(OPNFLS(Y,1),64).NE.0) THEN
C           WRITE OUT SECTOR
          ENDIF
C         READ IN SECTOR
C         65280 SHOULD BE BIGGER FOR FILES > 64K
          OPNFLS(Y,1)=LAND(LOR(OPNFLS(Y,1),128),191)+LAND(PTR(Y),65280)
        ENDIF
        A=BYTE(BUFFER(Y)(LAND(PTR(Y),255)+1:))
        PTR(Y)=PTR(Y)+1
C       65407 SHOULD BE BIGGER FOR FILES > 64K
        IF (LAND(PTR(Y),255).EQ.0) OPNFLS(Y,1)=LAND(OPNFLS(Y,1),65407)
        P=LAND(P,254+FLAGS)
C
C     OSBPUT
C
      ELSE IF (CODE.EQ.2) THEN
        IF (LAND(OPNFLS(Y,1),2).EQ.0) THEN
          CALL BRK(193,'Write not allowed|')
          RETURN
        ENDIF
        IF (LAND(OPNFLS(Y,1),128).EQ.0) THEN
          IF (LAND(OPNFLS(Y,1),64).NE.0) THEN
            CALL MFSETU(OPNFLS(Y,2))
C           WRITE OUT SECTOR
          ENDIF
          IF (LAND(EXT(Y),255).EQ.0.AND.PTR(Y).EQ.EXT(Y)) THEN
C             Flag sector_after_ext as current one in buffer
          ELSE
            CALL MFSETU(OPNFLS(Y,2))
C           READ IN SECTOR
          ENDIF
C         65280 SHOULD BE BIGGER FOR FILES > 64K
          OPNFLS(Y,1)=LAND(LOR(OPNFLS(Y,1),128),191)+LAND(PTR(Y),65280)
        ENDIF
        CALL LMOVE(A,BUFFER(Y)(LAND(PTR(Y),255)+1:),1)
        OPNFLS(Y,1)=LOR(OPNFLS(Y,1),64)
        PTR(Y)=PTR(Y)+1
C       65407 SHOULD BE BIGGER FOR FILES > 64K
        IF (LAND(PTR(Y),255).EQ.0) OPNFLS(Y,1)=LAND(OPNFLS(Y,1),65407)
        IF (PTR(Y).GT.EXT(Y)) THEN
          EXT(Y)=PTR(Y)
          OPNFLS(Y,1)=LOR(OPNFLS(Y,1),32)
        ENDIF
      ELSE IF (CODE.EQ.64.OR.CODE.EQ.128.OR.CODE.EQ.192) THEN
C
C     See if we have an available channel. Also check if file is open
C     already. Can be open more than once, but all access must be read.
C     Note that the same filename can be specified in different ways -
C     this will subvert this check.
C
        A=0
        DO 1 I=10,1,-1
          IF (OPNFLS(I,1).EQ.0) THEN
            A=I
          ELSE
            IF (OPNFNM(I).EQ.FILNAM.AND.
     +         (LAND(OPNFLS(I,1),2).EQ.2.OR.CODE.GT.64)) THEN
              CALL BRK(194,'File open|')
              RETURN
            ENDIF
          ENDIF
  1     CONTINUE
        IF (A.EQ.0) THEN
          CALL BRK(192,'Too many files open|')
          RETURN
        ENDIF
C
C       Look for file in catalogue
C
        CALL FILINF(FILNAM,LOAD,EXEC,LENGTH,ATRIBS,LRECL,UIO,RC)
C
C       Check access to the file and set up pointers etc
C
        OPNFLS(A,1)=0
        IF (LAND(CODE,64).EQ.64) THEN
          IF (RC.EQ.0) THEN
            IF (LAND(ATRIBS,1).EQ.1) THEN
              CALL BRK(195,'Read not allowed|')
              RETURN
            ENDIF
          ELSE
            IF (RC.NE.30) THEN
              WRITE (ERROR,2) RC,FILNAM(:36)
              CALL BRK(128,ERROR)
            ENDIF
            A=0
            RETURN
          ENDIF
          EXT(A)=LENGTH
          OPNFLS(A,1)=1
        ENDIF
        IF (LAND(CODE,128).EQ.128) THEN
          IF (RC.NE.0) ATRIBS=4
          IF (LAND(ATRIBS,2).EQ.2) THEN
            CALL BRK(193,'Write not allowed|')
            RETURN
          ELSE IF (RC.NE.30) THEN
            WRITE (ERROR,2) RC,FILNAM(:36)
            CALL BRK(128,ERROR)
            RETURN
          ENDIF
          OPNFLS(A,1)=OPNFLS(A,1)+2
        ENDIF
        IF (CODE.EQ.128) THEN
          CALL PURGE(-1,FILNAM,RC)
          IF (RC.NE.0.AND.RC.NE.30) THEN
            WRITE (ERROR,2) RC,FILNAM(:36)
            CALL BRK(128,ERROR)
            RETURN
          ENDIF
          PRIM=16
          SEC=0
          MAXK=-1
          LRECL=256
          RECFM=F
          ACCESS=PRIV
          EXT(A)=0
          OPNFLS(A,1)=32+3
        ENDIF
C       CALL MFACT(RC,'OPEN OKOLD OKNEW RDOK WROK.',-1,FILNAM)
        IF (RC.NE.0) THEN
         WRITE (ERROR,2) RC,FILNAM(:36)
    2    FORMAT('MUSIC error ',I3, ' encountered opening file ',A36,'|')
         CALL BRK(128,ERROR)
         RETURN
        ENDIF
        CALL MFGETU(OPNFLS(A,2))
        OPNFLS(A,3)=LRECL
        OPNFNM(A)=FILNAM
        PTR(A)=0
C
C     Check if file is already open and that all opens are read
C     Put length in EXT (and PTR if required)
C
      ELSE IF (CODE.EQ.0) THEN
        IF (Y.EQ.0) THEN
          DO 8 I=1,10
            CALL OSCLOS(OPNFLS(I,1),OPNFNM(I))
  8       CONTINUE
        ELSE
C
C         Note Channel is verified if A=0 and Y^=0
C
          CALL OSCLOS(OPNFLS(Y,1),OPNFNM(Y))
        ENDIF
      ENDIF
      RETURN
      END
C
C     OSFIND Close
C
      SUBROUTINE OSCLOS(OPNFLS,FILNAM)
      CHARACTER*64 FILNAM
      INTEGER OPNFLS
C     IF (LAND(OPNFLS,64).EQ.64) WRITE OUT SECTOR
C     IF (LAND(OPNFLS,32).EQ.32) UPDATE CAT ENTRY
      CALL MFACT(RC,'CLOSE RLSE.',-1,FILNAM)
      OPNFLS=0
      RETURN
      END
C
C     Translate tables
C
      BLOCK DATA
      CHARACTER EBCDIC(0:255)/ 33*' ','!','"','#','$','%','&','''','(',
     $ ')','*','+',',','-','.','/','0','1','2','3','4','5','6','7','8',
     $ '9',':',';','<','=','>','?','@','A','B','C','D','E','F','G','H',
     $ 'I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X',
     $ 'Y','Z','[','\',']','^','_','`','a','b','c','d','e','f','g','h',
     $ 'i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x',
     $ 'y','z','{','|','}','~',129*'%' /
      CHARACTER ASCII(0:255) /
     $ Z00,Z01,Z02,Z03,Z1A,Z09,Z1A,Z7F,Z1A,Z1A,Z1A,Z0B,Z0C,Z0D,Z0E,Z0F,
     $ Z10,Z11,Z12,Z13,Z1A,Z1A,Z08,Z1A,Z18,Z19,Z1A,Z1A,Z1C,Z1D,Z1E,Z1F,
     $ Z1A,Z1A,Z1C,Z1A,Z1A,Z0A,Z17,Z1B,Z1A,Z1A,Z1A,Z1A,Z1A,Z05,Z06,Z07,
     $ Z1A,Z1A,Z16,Z1A,Z1A,Z1E,Z1A,Z04,Z1A,Z1A,Z1A,Z1A,Z14,Z15,Z1A,Z1A,
     $ Z20,ZA6,ZE1,Z80,ZEB,Z90,Z9F,ZE2,ZAB,Z8B,Z5C,Z2E,Z3C,Z28,Z2B,Z7C,
     $ Z26,ZA9,ZAA,Z9C,ZDB,ZA5,Z99,ZE3,ZA8,Z9E,Z21,Z24,Z2A,Z29,Z3B,Z5E,
     $ Z2D,Z2F,ZDF,ZDC,Z9A,ZDD,ZDE,Z98,Z9D,ZAC,ZBA,Z2C,Z25,Z5F,Z3E,Z3F,
     $ ZD7,Z88,Z94,ZB0,ZB1,ZB2,ZFC,ZD6,ZFB,Z60,Z3A,Z23,Z40,Z27,Z3D,Z22,
     $ Z00,Z61,Z62,Z63,Z64,Z65,Z66,Z67,Z68,Z69,Z96,ZA4,ZF3,ZAF,ZAE,ZC5,
     $ Z8C,Z6A,Z6B,Z6C,Z6D,Z6E,Z6F,Z70,Z71,Z72,Z97,Z87,ZCE,Z93,ZF1,ZFE,
     $ ZC8,Z7E,Z73,Z74,Z75,Z76,Z77,Z78,Z79,Z7A,ZEF,ZC0,ZDA,Z5B,ZF2,ZF9,
     $ ZB5,ZB6,ZFD,ZB7,ZB8,ZB9,ZE6,ZBB,ZBC,ZBD,Z8D,ZD9,ZBF,Z5D,ZD8,ZC4,
     $ Z7B,Z41,Z42,Z43,Z44,Z45,Z46,Z47,Z48,Z49,ZCB,ZCA,ZBE,ZE8,ZEC,ZED,
     $ Z7D,Z4A,Z4B,Z4C,Z4D,Z4E,Z4F,Z50,Z51,Z52,ZA1,ZAD,ZF5,ZF4,ZA3,Z8F,
     $ Z5C,ZE7,Z53,Z54,Z55,Z56,Z57,Z58,Z59,Z5A,ZA0,Z85,Z8E,ZE9,ZE4,ZD1,
     $ Z30,Z31,Z32,Z33,Z34,Z35,Z36,Z37,Z38,Z39,ZB3,ZF7,ZF0,ZFA,ZA7,ZFF/
      COMMON /TABLES/ ASCII,EBCDIC
      END