FTN4,L
      PROGRAM VERIF(3,80),24999-16248 REV.1938 790921 
      INTEGER CLIST(125),AGAIN,DBEOF
      DIMENSION IDCB1(144),IDCB2(144),IBUF1(128),IBUF2(128) 
      DIMENSION IP(5),NAME1(9),NAME2(9) 
      DIMENSION INF1(6),INF2(6),MCR(3),MTYPE(5) 
      COMMON IBUF1,IBUF2
      EQUIVALENCE (IP(1),LUI),(IP(2),LUO),(NAME1(4),INF1),
     $(NAME2(4),INF2),(IP(3),IDBUG),(IP(4),DBEOF) 
C 
      DATA MCR/2H O,2HN ,2HCR/,MTYPE/2H T,2HYP,2HE ,2HIS,2H  /
C 
      CALL RMPAR(IP)
      IF(LUI.EQ.0) LUI = 1
      IF(LUO.EQ.0) LUO = LUI
      IREC = 0
      IANS = 0
      ITERR = 0 
      WRITE(LUI,2)
   2  FORMAT(" /VERIF: REV 1938"/)
C 
  5   CALL FNAME(NAME1,ISC,ICR,LUI,ITYPE) 
C 
      IF(NAME1 .GT. 77B)GO TO 20
C 
      IF(NAME1 .LE. 0)GO TO 999 
      CALL DCBDM(IDCB1,NAME1,ITYPE) 
      NAME1(3) = KCVT(NAME1)
      NAME1(1) = 2HLU 
      NAME1(2) = 2H # 
      DO 10 I=1,5 
      INF1(I) = MTYPE(I)
  10  CONTINUE
      INF1(6) = ITYPE 
      IF(ITYPE .EQ. 0)ITYPE = 2HAS
      GO TO 30
C 
 20   IF(NAME1 .EQ. 2H::)GO TO 999
      CALL OPEN(IDCB1,IERR,NAME1,1,ISC,ICR) 
      IF(IFMGR(IERR,8,LUI,NAME1))5,22 
   22 IF(ICR .NE. 0)GO TO 25
C 
C  OPEN THE FILE AND CHECK ITS TYPE & CARTRIDGE.
C 
      CALL LOCF(IDCB1,IDUM,IDUM,IDUM,IDUM,IDUM,JLU) 
      CALL FSTAT(CLIST) 
      DO 24 JK=1,31 
      JJ = (JK-1)*4 + 1 
      IF(JLU.NE.CLIST(JJ))GO TO 24
      ICR = CLIST (JJ + 2)
      GO TO 25
  24  CONTINUE
C 
  25  DO 35 I=1,3 
      INF1(I) = MCR(I)
  35  CONTINUE
      CALL CNUMD(ICR,INF1(4)) 
C 
  30  IF(IANS .EQ. 2HYE)GO TO 60
  31  CALL FNAME(NAME2,ISC,ICR,LUI,ITYPE) 
C 
      IF(NAME2 .GT. 77B)GO TO 50
C 
      IF(NAME2 .LE. 0)GO TO 999 
      CALL DCBDM(IDCB2,NAME2,ITYPE) 
      NAME2(3) = KCVT(NAME2)
      NAME2(1) = 2HLU 
      NAME2(2) = 2H # 
      DO 40 I=1,5 
      INF2(I) = MTYPE(I)
  40  CONTINUE
      INF2(6) = ITYPE 
      IF(ITYPE .EQ.0)ITYPE = 2HAS 
      GO TO 60
C 
  50  IF(NAME2 .EQ. 2H::)GO TO 999
      CALL OPEN(IDCB2,IERR,NAME2,1,ISC,ICR) 
      IF(IFMGR(IERR,8,LUI,NAME2))30,52
  52  IF(ICR .NE.0)GO TO 55 
C 
C  OPEN THE FILE AND CHECK ITS TYPE & CARTRIDGE.
C 
      CALL LOCF(IDCB2,IDUM,IDUM,IDUM,IDUM,IDUM,JLU) 
      CALL FSTAT(CLIST) 
      DO 54 JK=1,31 
      JJ = (JK-1)*4 + 1 
      IF(JLU.NE.CLIST(JJ))GO TO 54
      ICR = CLIST (JJ + 2)
      GO TO 55
  54  CONTINUE
C 
  55  DO 56 I=1,3 
      INF2(I) = MCR(I)
  56  CONTINUE
      CALL CNUMD(ICR,INF2(4)) 
C 
  60  IF(IANS .EQ. 2HYE .AND. LEN2 .EQ. -1)GO TO 65 
      CALL READF(IDCB1,IERR,IBUF1,128,LEN1) 
      IF(IERR .NE. -12)GO TO 62 
      LEN1 = -1 
      GO TO 64
62    IF(IFMGR(IERR,11,LUI,NAME1))999,64
   64 IF(LEN1 .EQ. 0)GO TO 60 
      IF(IANS .EQ. 2HYE)GO TO 68
C 
  65  CALL READF(IDCB2,IERR,IBUF2,128,LEN2) 
      IF(IERR .NE. -12)GO TO 66 
      LEN2 = -1 
      GO TO 67
 66   IF(IFMGR(IERR,11,LUI,NAME2))999,67
   67 IF(LEN2 .EQ. 0)GO TO 65 
      IF(IANS .EQ. 2HYE)GO TO 68
      IREC = IREC +1
   68 IANS = 0
      IF(IFBRK(IDUM))999,70 
C 
  70  IF(LEN1.NE.LEN2) GO TO 700
C 
      IF(LEN1)200,80,80 
C 
  80  NDERR = 0 
      IEOF = 0
      DO 100 I=1,LEN1 
C 
      IF(IBUF1(I).NE.IBUF2(I)) NDERR = NDERR + 1
C 
  100 CONTINUE
      IF(NDERR .NE.0)GO TO 800
      GO TO 60
C 
 200  IFILE = IFILE + 1 
      IF(ITERR.EQ.0)GO TO 490 
      WRITE(LUI,220)NAME1,NAME2,ITERR 
      IF(LUI.NE.LUO)WRITE(LUO,220)NAME1,NAME2,ITERR 
  220 FORMAT(" /VERIF:  ",9A2," IS DIFFERENT FROM"/ 
     $                10X,9A2," IN ",I5," RECORDS.")
      IF(DBEOF.NE.0)WRITE(LUI,230)IFILE 
 230  FORMAT(" FILE # ",I5) 
      GO TO 999 
  490 IF(DBEOF.EQ.0)GO TO 495 
      IF(IEOF .EQ. 1)GO TO 495
      WRITE(LUI,230)IFILE 
      IEOF = 1
      GO TO 60
  495 WRITE(LUI,500)
  500 FORMAT(/" COMPARE GOOD")
      GO TO 999 
C 
  700 IEOF = 0
      IF(LEN1 .NE. -1) GO TO 760
      ASSIGN 5 TO AGAIN 
      IF(LUI.NE.LUO)WRITE(LUO,740)NAME1 
      WRITE(LUI,740)NAME1 
      WRITE(LUI,742)
  740 FORMAT(/" /VERIF:  EOF READ ON ",9A2) 
  742 FORMAT(" CONTINUE COMPARISON ? _")
  745 READ(LUI,750)IANS 
  750 FORMAT(A2)
      IF(IANS .EQ. 2HYE)GO TO AGAIN 
      IF(DBEOF .NE. 0)GO TO 999 
      GO TO 200 
  760 IF(LEN2 .NE. -1)GO TO 770 
      ASSIGN 31 TO AGAIN
      IF(LUI.NE.LUO)WRITE(LUO,740)NAME2 
      WRITE(LUI,740)NAME2 
      WRITE(LUI,742)
      GO TO 745 
  770 WRITE(LUI,515)IREC,NAME1,LEN1,NAME2,LEN2
      IF(LUI.NE.LUO)WRITE(LUO,515)IREC,NAME1,LEN1,NAME2,LEN2
  515 FORMAT(" /VERIF:      RECORD LENGTH UNEQUAL, RECORD #",I5,
     1/2(/1X,9A2,"  LENGTH = ",I3)/)
      IF(IDBUG .NE. 0)CALL DMPAL(NAME1,NAME2,LEN1,LEN2,LUO) 
      ITERR = ITERR + 1 
      GO TO 60
C 
  800 WRITE(LUI,520)NDERR,IREC
      IF(LUI.NE.LUO)WRITE(LUO,520)NDERR,IREC
  520 FORMAT(" /VERIF:  "I5" DATA COMPARE ERRORS, RECORD #",I5/)
      IF(IDBUG .NE. 0)CALL DMPAL(NAME1,NAME2,LEN1,LEN2,LUO) 
      ITERR = ITERR + 1 
      GO TO 60
C 
  999 IF(NAME1 .GT. 77B)CALL CLOSE(IDCB1) 
      IF(NAME2 .GT. 77B)CALL CLOSE(IDCB2) 
      END 
      SUBROUTINE FNAME(NAME,ISC,ICR,LUI,ITYP) 
      INTEGER PBUF(4,8),IPBUF(33) 
      DIMENSION IBUF(10),IREG(2),NAME(3)
      EQUIVALENCE (IB,IREG(2)),(X,IREG),(PBUF,IPBUF)
      DATA IBUF/10*2H  /
C 
C 
      WRITE(LUI,500)
  500 FORMAT("FILE NAME OR LU,(FORMAT) _")
      X = REIO(1,LUI+400B,IBUF,-20) 
      IF(IBUF.EQ.2H::)GO TO 999 
      CALL COMMA(IBUF,IB) 
      CALL PARSE(IBUF,IB,PBUF)
  999 DO 20 J=1,3 
      NAME(J)=PBUF(J+1,1) 
   20 CONTINUE
C 
C  IF LU IS SPECIFIED SET SECOND PARAM. TO TYPE FORMAT
C 
      IF(PBUF .EQ. 2) GO TO 50
      ITYP = PBUF(2,2)
      RETURN
C 
C FILE SPECIFIED SO, SET THE SECURITY CODE AND CARTRIDGE #
C 
   50 ISC = PBUF(2,2) 
      ICR = PBUF(2,3) 
      RETURN
      END 
      SUBROUTINE DCBDM(IDCB,LU,ITYPE) 
      DIMENSION IDCB(144) 
C 
C CLEAR THE DCB TO ZEROES.
C 
      DO 10 I=1,144 
  10  IDCB(I) = 0 
C 
C WHAT TYPE OF DEVICE IS THIS DCB FOR ? 
C 
      CALL EXEC(13,LU,IDEV) 
C 
      IDEV = IAND(IDEV,37400B)/256
C 
      IF(IDEV.EQ.0) GO TO 100 
      IF(IDEV.EQ.1) GO TO 200 
      IF(IDEV.EQ.5) GO TO 100 
      IF(IDEV.EQ.11B) GO TO 200 
      IF(IDEV.EQ.15B) GO TO 500 
      IF(IDEV.EQ.23B) GO TO 600 
C 
C UNRECOGNIZED DEVICE TYPE
C SET IDCB(1) TO -1 & RETURN TO CALLER. 
C 
      IDCB(1) = -1
      RETURN
C 
C FOR DVR00         CRT 
C 
  100 IDCB(7) = 100001B 
      GO TO 350 
C 
C FOR DVR01         PHOTO READER
C 
  200 IDCB(7) = 100000B 
  350 IDCB(6) = 1 
      IDCB(5) = 1000B + LU
      GO TO 1000
C 
C FOR DVR15         MARK SENSE READR
C 
  500 IDCB(7) = 100000B 
      IDCB(6) = 1 
      IDCB(5) = 100B + LU 
      GO TO 1000
C 
C FOR DVR23         9 TRACK MAG TAPE
C 
  600 IDCB(7) = 100001B 
      IDCB(6) = 100001B 
      IDCB(5) = 100B + LU 
      IDCB(4) = 100B + LU 
      IF(ITYPE .EQ. 0)IDCB(4) = LU
      GO TO 1001
C 
C FINISH THIS SET UP. 
C 
 1000 IDCB(4) = LU
      IF(ITYPE.EQ.2HBA) IDCB(4) = LU + 2300B
      IF(ITYPE.EQ.2HBR) IDCB(4) = LU +  300B
      IF(ITYPE.EQ.2HBN) IDCB(4) = LU +  100B
C 
1001  IDCB(10) = IGET(1717B)
C 
      END 
      SUBROUTINE DMPAL(NAME1,NAME2,LEN1,LEN2,LU)
C   1200 HRS   THU  07 APR 77 
      DIMENSION IBUF1(128),IBUF2(128),NAME1(9),NAME2(9) 
      DIMENSION ITEMP(37),IASC(9) 
      COMMON IBUF1,IBUF2
      EQUIVALENCE (ITEMP(29),IASC)
C 
  1   FORMAT(" ") 
      WRITE(LU,10)NAME1 
 10   FORMAT(1X,9A2/) 
C DUMP RECORD OF NAME1
C 
      DO 773 J=1,LEN1,8 
      L = J + 7 
      IF(L .GT. LEN1)L=LEN1 
C 
      DO 766 K=1,37 
      ITEMP(K) = 20040B 
766   CONTINUE
      CALL CODE 
      WRITE(ITEMP,1766)(IBUF1(K),K=J,L) 
      CALL ASCII(IBUF1(J),8)
      CALL CODE 
      WRITE(IASC,1767)(IBUF1(K),K=J,L)
      WRITE(LU,1768)ITEMP 
 773  CONTINUE
C 
      WRITE(LU,1) 
      WRITE(LU,10)NAME2 
C DUMP RECORD OF NAME2
C 
      DO 883 J=1,LEN2,8 
      L = J + 7 
      IF(L .GT. LEN2)L=LEN2 
C 
      DO 866 K=1,37 
      ITEMP(K) = 20040B 
866   CONTINUE
      CALL CODE 
      WRITE(ITEMP,1766)(IBUF2(K),K=J,L) 
      CALL ASCII(IBUF2(J),8)
      CALL CODE 
      WRITE(IASC,1767)(IBUF2(K),K=J,L)
      WRITE(LU,1768)ITEMP 
 883  CONTINUE
      WRITE(LU,1) 
      RETURN
C 
1766  FORMAT(8(1X,K6))
1767  FORMAT("*",8A2) 
1768  FORMAT(37A2)
      END 
      END$
ASMB,R,L,B,C
      HED ** FILE MANAGER ERROR PROCESSOR **
      NAM IFMGR,7 
      ENT IFMGR 
      EXT EXEC,.ENTR
* 
* THIS FUNCTION CHECKS FOR FILE MANAGER ERRORS.  IF THE ERROR 
* CODE IS < 0, THE ERROR MESSAGE IS PRINTED ON THE SPECIFIED TTY. 
* 
* IF ID IS >= 0, THE ERROR CODE IS RETURNED AS THE FUNCTION VALUE.
* 
* IF ID IS < 0 AND THE ERROR CODE IS < 0, THEN THE PROGRAM IS 
* ABORTED.
* 
* FORTRAN USEAGE EXAMPLE: 
*     IF (IFMGR (IERR,ID,LTTY,NAME)) 100,200
* 
* ASSEMBLY CALLING SEQUENCE 
*     JSB IFMGR 
*     DEF *+4 
*     DEF IERR
*     DEF ID
*     DEF LTTY
*     DEF NAME
*                   ON RETURN A = IERR
* 
* WHERE THE USER SUPPLIED VARIABLES ARE:
* 
* IERR = ERROR PARAMETER RETURNED FROM FILE MANAGER CALL. 
* ID   = CALL IDENTITY CODE (NEGATIVE TO ABORT IF ERROR EXISTS) 
*        1 = APOSN
*        2 = CLOSE
*        3 = CREAT
*        4 = FCONT
*        5 = FSTAT
*        6 = LOCF 
*        7 = NAMF 
*        8 = OPEN 
*        9 = POSNT
*       10 = PURGE
*       11 = READF
*       12 = RWNDF
*       13 = WRITF
* LTTY = LOGICAL UNIT NUMBER OF DEVICE TO LIST ERROR
* NAME = NAME OF FILE THAT HAD ERROR
* 
* PARAMETER ADDRESSES 
* 
IERR  NOP           ERROR CODE
ID    NOP           FILE MANAGER CALL ID
LTTY  NOP           LOGICAL UNIT TO OUTPUT ERROR MESSAGES.
NAME  NOP           NAME OF FILE THAT HAD ERROR 
IFMGR NOP 
      JSB .ENTR     USE .ENTR TO GET
      DEF IERR       ADDRESSES OF PARAMETERS
      LDA IERR,I    GET ERROR CODE
      SSA,RSS       FILE MANAGER ERROR? 
      JMP IFMGR,I   NO,RETURN TO USER 
* 
* ERROR - CONVERT ERROR TO ASCII AND PUT IT INTO OUTPUT BUFFER
* 
      MPY M1        MULTIPLY ERROR BY -1 & THEN 
      DIV .10       DIVIDE BY TEN TO GET TENS DIGIT.
      STA ERROR     SAVE TEMPORARILY
      MPY .10       MULTIPLY BY 10 AND DIVIDE BY
      DIV .1        .1 TO GET TENS VALUE ONLY 
      ADA IERR,I    ADD ERROR CODE,RESULT = - UNITS 
      CMA,INA       MAKE UNITS POSITIVE 
      LDB ERROR     GET TENS DIGIT
      BLF,BLF       ROTATE IT TO HIGH BYTE OF WORD
      IOR B         OR IT WITH UNITS
      IOR ASC00     OR IN ASCII CONSTANT
      STA ERROR     PUT ASCII ERROR CODE IN MSG BUFFER
* 
* ADD CALL ID AND FILE NAME TO BUFFER 
* 
      LDA ID,I      GET ID CODE 
      SSA           IS IT NEGATIVE? 
      CMA,INA       YES - MAKE POSITIVE 
      STA B          IS CODE
      ADB M14         GREATER 
      SSB,RSS         THAN 13?
      CLA           YES - OUTPUT $$$$$ FOR ID 
      STA B         SAVE ERROR CODE 
      ALS           MULTIPLY BY 2 AND 
      ADA B         ADD IT TO ITSELF (X3) 
      ADA CALL      ADD BUFR STARTING ADRS TO OFFSET
      LDB EMES      SET POINTER TO
      STB PNTR      ID NAME 
      CLB           SET FLAG TO INDICATE NAME 
      STB FLAG      BUFFER HAS TO BE TRANSFERRED. 
NFILE LDB M3        SET COUNTER TO
      STB CNTR      TRANSFER 3 WORDS
LOOP  LDB A,I       GET ID WORD & PUT IT
      STB PNTR,I    IN ERROR MESSAGE BUFFER 
      INA           ILNDEX ID AND 
      ISZ PNTR      ERROR MESSAGE POINTERS
      ISZ CNTR      TRANSFER COMPLETE?
      JMP LOOP      NO - TRANSFER NEXT WORD 
      LDB FLAG
      SZB           NAME ARRAY TRANSFERRED? 
      JMP LP1       YES - OUTPUT MESSAGE
      ISZ FLAG      NO - SET FLAG TO SAY YES
      LDA NAME      GET ADDRESS OF ARRAY IN A 
      LDB NAMEB     PUT OUTPUT BUFFER 
      STB PNTR      ADDRESS IN B
      JMP NFILE     TRANSFER FILE NAME
* 
*     PUT IN PROGRAM NAME 
* 
LP1   LDB 1717B 
      ADB .12 
      LDA B,I 
      STA PRGNM 
      INB 
      LDA B,I 
      STA PRGNM+1 
      INB 
      LDA B,I 
      AND M1774 
      IOR COLON 
      STA PRGNM+2 
* 
* OUTPUT ERROR MESSAGE
* 
OUT   JSB EXEC      OUTPUT THE ERROR MESSAGE
      DEF *+5 
      DEF WRITE 
      DEF LTTY,I
      DEF PRGNM 
      DEF M40 
* 
* CHECK FOR ABORT PROGRAM 
* 
      LDA IERR,I    PUT ERROR CODE IN CASE WE RETURN
      LDB ID,I      GET ID CODE 
      SSB,RSS       DO WE ABORT?
      JMP IFMGR,I   NO - RETURN 
* 
* ABORT PROGRAM 
* 
      JSB EXEC      WRITE 
      DEF *+5       "PROGRAM ABORTED!"
      DEF WRITE     ON THE
      DEF LTTY,I    LOCAL TTY 
      DEF ABORT 
      DEF M16 
      JSB EXEC      ASK RTE 
      DEF *+2       TO TERMINATE THE PROGRAM
      DEF .6
* 
* CONSTATNTS, STORAGE ALLOCATION, AND MESSAGES
* 
A     EQU 0         A REGISTER
B     EQU 1         B REGISTER
* 
* CONSTANTS 
* 
COLON OCT 72
.1    DEC 1 
.6    DEC 6 
.10   DEC 10
.12   DEC 12
M1    DEC -1
M3    DEC -3
M14   DEC -14 
M16   DEC -16 
M40   DEC -40 
M1774 OCT 177400
* 
* MISC. CONSTANTS 
* 
ASC00 ASC 1,00
WRITE DEC 2 
* 
* 
CNTR  NOP           UTILITY COUNTER 
FLAG  NOP           ID/NAME TRANSFER FLAG 
PNTR  NOP           TRANSFER POINTER TO MESSAGE BUFFER
* 
* FILE MANAGER CALLS
* 
CALL  DEF *+1 
      SUP PRESS THE GARBAGE 
      ASC 3,$$$$$ 
ID1   ASC 3,APOSN 
ID2   ASC 3,CLOSE 
ID3   ASC 3,CREAT 
ID4   ASC 3,FCONT 
ID5   ASC 3,FSTAT 
ID6   ASC 3,LOCF
ID7   ASC 3,NAMF
ID8   ASC 3,OPEN
ID9   ASC 3,POSNT 
ID10  ASC 3,PURGE 
ID11  ASC 3,READF 
ID12  ASC 3,RWNDF 
ID13  ASC 3,WRITF 
* 
* ERROR MESSAGE 
* 
PRGNM BSS 3 
      ASC 1,
ERMES BSS 3 
      ASC 4,ERROR - 
ERROR NOP 
      ASC 5, IN FILE
NAM.  BSS 3 
NAMEB DEF NAM.
EMES  DEF ERMES 
* 
* ABORT ERROR MESSAGE 
ABORT ASC 8,PROGRAM ABORTED!
* 
* 
* 
      END 
ASMB,R,B,L,C
      NAM COMMA,7   REV A 751031
* 
*  FRI  31 OCT 75   WRITTEN BY DONALD H. POTTENGER  REV A 
* 
      ENT COMMA 
      EXT .ENTR 
*      THIS SUBROUTINE, GIVEN AN ADDRESS AND LENGTH OF A BUFFER,
*  WILL CHECK FOR IMBEDDED COLONS AND REPLACE THEM WITH COMMAS
*  FOR THE SYSTEM PARSE ROUTINE.  THIS HAS OBVIOUS ADVANTAGES 
*  FOR THE USER WHO IS USED TO USING COLONS AS DELIMITERS AS IN 
*  THE FILE MANAGER NAMR PARAMATERS.
* 
*     THE BUFFER CAN BE ANY LENGTH AND SHOULD SPECIFY 
*  THE NUMBER OF CHARACTERS IN THE BUFFER.
* 
BUFAD NOP           BUFFER ADDRESS
BUFLA NOP           BUFFER LENGTH 
COMMA NOP           WHERE IT ALL BEGINS 
      JSB .ENTR     GO GET THE ADDRESSES
      DEF BUFAD       OF THE PARAMATERS 
      LDA BUFLA,I   HOW ABOUT THE LENGTH? 
      CLE,ERA       IS IT AN ODD CHARACTER COUNT? 
      SEZ           NO,  ITS ALL READY TO GO
      INA           YES, INCREASE THE WORD COUNT BY ONE 
      CMA,INA       LET'S MAKE IT NEG. FOR COUNTING 
      STA BUFL      AND SAVE IT 
      SZA,RSS       IS IT A ZERO LENGTH BUFFER? 
      JMP COMMA,I   WELL GET THE HECK OUT OF HERE THEN. 
START LDA BUFAD,I   ORIGINAL NAME HUH ? 
      STA TEMP      LET'S GET A WORD AND GET ON WITH IT 
      AND M177        HOW ABOUT THE LOW BYTE? 
      CPA LOCOL         A COLON?
      JMP LFIX      YES, GO MAKE IT A COMMA 
PAR1  LDA TEMP      NO, PREPARE TO CONTINUE 
      AND M774      THIS TIME LOOK AT THE HI BYTE 
      CPA HICOL       A COLON?
      JMP HFIX      YES, GO MAKE IT A COMMA 
      JMP TERM1     NO, LETS SAVE WHAT WE HAVE AND GO ON
LFIX  LDA TEMP      GET ORIGINAL WORD 
      ADA M16       MAKE THAT COLON A COMMA 
      STA TEMP        AND SAVE
      JMP PAR1+1    GO CHECK HI BYTE
HFIX  LDA TEMP      GET PRESENT VALUE 
      ADA M7000     MAKE THE HI BYTE COLON A COMMA
      RSS              AND SAVE IN ORIGINAL BUFFER
TERM1 LDA TEMP      LETS GET THE CURRENT VALUE
      STA BUFAD,I     AND SAVE IN ORIGINAL BUFFER 
      ISZ BUFAD     INCREMENT THE BUFFER ADDRESS
      ISZ BUFL      ANY MORE WORDS? 
      JMP START     YES, HERE WE GO AGIAN 
      JMP COMMA,I   NOPE, LETS GET OUT!!
      SKP 
* 
*     CONSTANTS AND STORAGE 
* 
BUFL  NOP 
TEMP  NOP 
M177  OCT 177 
M774  OCT 77400 
LOCOL OCT 72
HICOL OCT 35000 
M16   OCT -16 
M7000 OCT -7000 
      END 
ASMB,R,B,L,C
*   1200 HRS   WED  06 APR 77 
      NAM ASCII,7 MAKES BUFFER LEGEL ASCII CHARACTERS  770406 
* 
      ENT ASCII 
      EXT .ENTR 
* 
BUFR  NOP           ASCII BUFFER
LEN   NOP           LENGTH OF BUFFER
ASCII NOP             ENTRY POINT 
      JSB .ENTR 
      DEF BUFR
      LDA LEN,I     SET UP LOOP 
      CMA,INA         COUNTER 
      STA CNTR
START LDA BUFR,I    GET WORD FROM THE BUFFER
      AND B177            MASK FOR RIGHT BYTE 
      STA RBYTE     SAVE
      ADA M40       CHECK FOR LEGEL CHAR. 
      SSA,RSS 
      JMP NEXT      OK, GO CHECK LEFT BYTE
      LDA B40 
      STA RBYTE     SET TO ASCII SPACE
NEXT  LDA BUFR,I    GET CURRENT WORD AGAIN
      AND B7740     MASK FOR HIGH BYTE
      STA LBYTE     SAVE
      ADA M2000     CHECK FOR LEGALITY
      SSA,RSS 
      JMP FIN       OK
      LDA B2000 
      STA LBYTE 
FIN   LDA RBYTE 
      IOR LBYTE 
      STA BUFR,I
      ISZ BUFR
      ISZ CNTR
      JMP START 
      JMP ASCII,I   RETURN
* 
* 
RBYTE NOP 
LBYTE NOP 
CNTR  NOP 
* 
B40   OCT 40
B177  OCT 177 
B2000 OCT 20000 
B7740 OCT 77400 
M40   OCT -40 
M2000 OCT -20000
      END