FTN4,L,C
C 
C    VERSION   1 / 10 / 76   JRT
C 
C    VERSION   9 / 17 / 79   CEJ
C             THIS VERSION WILL HANDLE DATA FILES SUCH AS THE 
C             QUERY HELP FILE.  ALL CHANGES TO JRT'S SDLS4 ARE
C             DENOTED BY A LINE OF DASHES AS UNDERLINES.
C 
C 
CCCC
C 
C  SOURCE: 24999-18050
C  RELOC:  24999-16050
C 
CCCC
      PROGRAM SDLS4(3,99),24999-16050 REV.1938 790919 
      DIMENSION IPRAM(5),IREG(2),IREQ(20),IBUF(1153)
      DIMENSION ITITL(40),IDBLOK(43),IPBUF(33),IDCB(144),ISIZE(2) 
      DIMENSION IDCB2(144)
C 
      INTEGER BATCH 
      INTEGER YES,TPFORM,EOBFL
      INTEGER PGLABL(19),FILEFL,FNMBR 
      INTEGER FINDF(27),FNAME(3),SC,CR,FTYPE,FSIZE,RECLN
      INTEGER NBUFR(50) 
C 
      LOGICAL NWREQ,ECHO,PUN
C 
      EQUIVALENCE (X,IREG),(IA,IREG),(IB,IREG(2)) 
      EQUIVALENCE (LU,IPRAM)
      EQUIVALENCE (TPFORM,ITITL),(IREEL,ITITL(40))
      EQUIVALENCE (FNAME,IPBUF(2)),(SC,IPBUF(6))
      EQUIVALENCE (CR,IPBUF(10)),(FTYPE,IPBUF(14))
      EQUIVALENCE (FSIZE,IPBUF(18)),(RECLN,IPBUF(22)) 
C 
      DATA BATCH/0/,NFILE/1/
      DATA YES/2HYE/
      DATA ITITL/35*2H  ,2HRE,2HEL,2H #,2H: ,2H  /
      DATA IREQ/20*2H  /,ISIZE/-1,0/,FILEFL/-1/ 
      DATA PGLABL/2H0 ,3*2H  ,2H P,2HAR,2HT ,2HNU,2HMB,2HER,2H  , 
     1            2H  ,2H  ,2HTY,2HPE,2H  ,2H L,2HAB,2HEL/
      DATA NWREQ/.FALSE./,ECHO/.FALSE./,PUN/.FALSE./
C 
C 
C STATEMENT FUNCTIONS:
C 
      IWORD(I)=IBUF(INDEX+I)
C 
C 
C 
C   TAKE CARE OF THE AMENITIES FIRST... 
C 
      CALL RMPAR(IPRAM) 
      IF(LU.EQ.0)LU=1 
      ILU=LU+400B 
      LLU=LU
      WRITE(LU,1000)
1000  FORMAT("24999-16050 1938 SOFTWARE SERVICE KIT SYSTEM 1000"/)
C 
      WRITE(LU,100) 
100   FORMAT(/"/SDLS4: MAG TAPE LU = _")
      READ(LU,*)MTLU
C 
C  TRY TO LOCK THE MAG TAPE 
C 
      X=LURQ(100001B,MTLU,1)
C 
C 
C  REWIND THE TAPE
C 
4     CALL EXEC(3,MTLU+400B)
C 
C*******************************************************
C 
C 
C   MAIN LOOP 
C 
C 
10    IF(BATCH.NE.0)CALL CLOSE(IDCB2,IERR)
      BATCH=0 
      IUPFL=0 
      IREQ=2H 
      WRITE(LU,110) 
110   FORMAT(/"/SDLS4: TASK: _")
      CALL REIO(1,ILU,IREQ,3) 
      IF(IREQ.EQ.2HDI)GO TO 20
      IF(IREQ.EQ.2HLO)GO TO 50
      IF(IREQ.EQ.2HBA)GO TO 40
      IF(IREQ.EQ.2HUP)GO TO 46
      IF(IREQ.EQ.2HRE)GO TO 26
      IF(IREQ.EQ.2HN )GO TO 87
      IF(IREQ.EQ.2HLL)GO TO 85
      IF(IREQ.EQ.2HLA)GO TO 21
      IF(IREQ.EQ.2HPU)GO TO 8000
      IF((IREQ.EQ.2HEN).OR.(IREQ.EQ.2HEX))GO TO 90
      IF(IREQ.EQ.2H??)GO TO 200 
C 
C 
C*******************************************************
C 
C 
C   ERROR SECTION 
C 
11    WRITE(LU,111) 
111   FORMAT("/SDLS4: INPUT ERROR!")
      GO TO 10
C 
12    IF(INDEX.NE.0)GO TO 14
      WRITE(LU,112) 
      GO TO 10
C 
14    IF(INDEX.NE.-4)GO TO 16 
      WRITE(LU,116)NFILE
      GO TO 10
C 
16    WRITE(LU,117)INDEX
      GO TO 10
112   FORMAT("/SDLS4: END OF TAPE") 
116   FORMAT("/SDLS4: BREAK AT FILE"I5) 
117   FORMAT("/SDLS4: ERROR"I4".  PLEASE REFER TO LISTINGS...") 
C 
19    WRITE(LU,119)IERR 
119   FORMAT("/SDLS4: FILE ERROR"I5)
      CALL CLOSE(IDCB,IERR) 
      GO TO 10
C 
C  TASK TO REWIND THE TAPE
C 
26    CALL GETRC(IBUF,MTLU,-3,INDEX,NFILE)
      GO TO 10
C*******************************************************
C 
C 
C 
C  DIRECTORY SECTION: 
C     LIST THE ALL PROGRAM I.D. BLOCKS INTO 
C     A SPECIFIED FILE - -  FORMATTED FOR LINE PRINTER * DUMP * 
C 
20    ASSIGN 21 TO IRETN
      WRITE(LU,121) 
121   FORMAT("/SDLS4: LIST FILE: _")
      GO TO 501 
C 
21    IERR=-2 
      IF(FILEFL.GT.0)GO TO 19 
      IF(NFILE.NE.1)CALL GETRC(IBUF,MTLU,-3,INDEX,NFILE)
      CALL GETRC(IBUF,MTLU,0,INDEX,NFILE) 
      IF(INDEX.LE.0)GO TO 12
      IF(IWORD(1).EQ.0)GO TO 23 
      WRITE(LU,123) 
123   FORMAT("/SDLS4: TAPE HAS NO LABEL!!  ???")
      GO TO 26
C 
C  PUT LABEL INFO INTO HEADER FOR LISTING 
C 
23    IBUF(INDEX+16)=2H 
      IBUF(INDEX+25)=2H 
      IBUF(INDEX+31)=2H 
C 
      DO 24 I=2,34
       ITITL(I)=IWORD(I+1)
24    CONTINUE
      CALL CODE 
      WRITE(IREEL,124)IBUF(INDEX+37)
124   FORMAT(I2)
C 
C   IF IT'S A 'LABEL' REQUEST, WE'RE DONE 
C 
      IF(IREQ.NE.2HLA)GO TO 241 
      CALL REIO(2,ILU,ITITL,40) 
      GO TO 10
241   CALL GETRC(IBUF,MTLU,0,INDEX,NFILE) 
      IF(INDEX.LE.0)GO TO 12
      IF(IWORD(1).NE.-2)GO TO 241 
C 
C  SET UP POINTERS... 
C 
25    NLINE=0 
      TPFORM=2H 
      PGLABL(2)=2HFI
      PGLABL(3)=2HLE
      PGLABL(4)=2H
C 
C    ID BLOCK LISTING SECTION 
C 
30    IF(FILEFL.EQ.0)GO TO 31 
      ISIZE=FSIZE 
      IF(ISIZE.EQ.0)ISIZE=-1
      ISIZE(2)=RECLN
      CALL CREAT(IDCB,IERR,FNAME,ISIZE,4,SC,CR) 
      IF(IERR.LT.0)19,33
C 
31    CALL OPEN(IDCB,IERR,FNAME,0,SC,CR)
      IF(IERR.LT.0)GO TO 19 
C   LOOP
C 
C 
33    CALL GETRC(IBUF,MTLU,1,INDEX,NFILE) 
      IF(INDEX)39,38,32 
32    IF(IWORD(1).NE.4)GO TO 34 
      WRITE(LU,130) 
130   FORMAT("/SDLS4: END OF DIRECTORY")
      GO TO 38
C 
34    N=NFILE 
      IBUF(INDEX+31)=IOR(IAND(IWORD(13),77400B),40B)
      IBUF(INDEX+11)=2H 
      IBUF(INDEX+13)=IOR(IAND(IBUF(INDEX+13),77400B),40B) 
      IBUF(INDEX+31)=2H 
C 
      IF(NLINE/50*50.NE.NLINE)GO TO 36
      CALL WRITF(IDCB,IERR,ITITL,40)
      TPFORM=2H1
      CALL WRITF(IDCB,IERR,PGLABL,19) 
      CALL WRITF(IDCB,IERR,PGLABL(11),2)
C 
36    CALL CODE 
      WRITE(IDBLOK,136)N,(IBUF(INDEX+I),I=3,13),(IBUF(INDEX+J),J=18,44) 
136   FORMAT(1X,I4,":   "11A2,1X,27A2)
      CALL WRITF(IDCB,IERR,IDBLOK,43) 
      IF(IERR.LT.0)GO TO 19 
      NLINE=NLINE+1 
      GO TO 33
C 
C   END LOOP
C 
38    CALL WRITF(IDCB,IERR,ITITL,1) 
      IF(IERR.LT.0)GO TO 19 
39    CALL LOCF(IDCB,IERR,IREC,IRB,IOFF,ISEC) 
      ITRUN=ISEC/2-IRB-1
      CALL CLOSE(IDCB,IERR,ITRUN) 
      IF(INDEX.LE.0)GO TO 12
      IF(BATCH)42,10,42 
C 
C*******************************************************
C 
C 
C   INITIATE BATCH MODE OPERATIONS  - GET INPUT FILE
C 
C      BATCH FILE FORMAT: 
C 
C          FILE NAME (NAMR) 
C          STOCK NUMBER OR FILE NUMBER  (FORWARD SEARCH ONLY IF GIVEN ST #) 
C            .
C            .
C          FILE NAME
C          STOCK NUMBER OR FILE NUMBER
C 
C     ALL FIELDS MUST BE LEFT JUSTIFIED 
C     IF A "/E" IS ENCOUNTERED, THE TAPE WILL BE RE-WOUND 
C 
C 
40    ASSIGN 41 TO IRETN
      WRITE(LU,140) 
140   FORMAT("/SDLS4: ENTER BATCH-FILE NAME: _")
      GO TO 501 
C 
41    IF(FILEFL.EQ.-1)GO TO 11
      BATCH=1 
      WRITE(LU,45)
45    FORMAT("ECHO? _") 
      READ(LU,47)IREPLY 
47    FORMAT(A2)
      IF (IREPLY .EQ. 2HYE) ECHO = .TRUE. 
      CALL OPEN(IDCB2,IERR,FNAME,2,SC,CR) 
      IF(IERR.LT.0)GO TO 19 
C 
42    CALL READF(IDCB2,IERR,IREQ,20,LEN)
      IF(IERR.LT.0)GO TO 19 
      IF(LEN.EQ.-1)GO TO 10 
      IF(IREQ.EQ.2H/E)GO TO 26
      IB=LEN
      ASSIGN 51 TO IRETN
      GO TO 502 
C 
C 
C   INITIATE 'UPDATE MODE OPERATION': 
C     SIMILAR TO BATCH EXCEPT THAT ONLY TAPE FILES WHOSE REV CODES
C     ARE GREATER THAT THOSE SPECIFIED IN THE REQUEST BATCH FILE
C     WILL BE LOADED
C 
46    IUPFL=1 
      GO TO 40
C 
C 
C***************************************************
C 
C     LOAD / STORE  REQUESTS
C 
50    ASSIGN 51 TO IRETN
      WRITE(LU,150) 
150   FORMAT("/SDLS4: LOAD INTO FILE: _") 
      GO TO 501 
C 
51    FNMBR=0 
      DO 552 I=1,20 
       IREQ(I)=2H 
552   CONTINUE
      IF(BATCH.EQ.0)GO TO 551 
      CALL READF(IDCB2,IERR,IREQ,8,LEN) 
      IF(IERR.LT.0)GO TO 19 
      IF(LEN.EQ.-1)11,58
C 
551   WRITE(LU,151) 
151   FORMAT("/SDLS4: ENTER STOCK #  OR FILE #: _") 
      CALL REIO(1,ILU,IREQ,8) 
58    IF (NWREQ) GO TO 6999 
      IF(IAND(IREQ,77400B).EQ.20000B)GO TO 11 
      IF(IREQ(4).NE.2H  )GO TO 60 
      CALL CODE 
      READ(IREQ,*)FNMBR 
      IF(FNMBR.LE.1)GO TO 11
C 
C 
C  TAPE SEARCH  GIVEN FILE NUMBER 
C    (ASSUME REWIND SPEED = 4 X READ SPEED AND ALL FILES SAME SIZE) 
C 
57    IF(FNMBR.GT.NFILE)GO TO 52
      ITIME1=NFILE/4+FNMBR
      ITIME2=NFILE-FNMBR
      IF(ITIME2.LT.ITIME1)GO TO 54
C 
      CALL GETRC(IBUF,MTLU,-3,INDEX,NFILE)
52    DO 53 I=1,FNMBR-NFILE 
       CALL GETRC(IBUF,MTLU,-1,INDEX,NFILE) 
       IF(INDEX.LE.0)GO TO 12 
53    CONTINUE
      GO TO 56
C 
54    DO 55 I=1,ITIME2+1
       CALL GETRC(IBUF,MTLU,-2,INDEX,NFILE) 
       IF(INDEX.LE.0)GO TO 12 
55    CONTINUE
      CALL GETRC(IBUF,MTLU,-1,INDEX,NFILE)
      IF(INDEX.LE.0)GO TO 12
C 
C  TAPE IS NOW POSITIONED...
C 
56    CALL GETRC(IBUF,MTLU,0,INDEX,NFILE) 
      IF(INDEX.LE.0)12,711
C 
C  TAPE SEARCH  GIVEN STOCK NUMBER     (FORWARD SEARCH ONLY)
C 
60    CALL GETRC(IBUF,MTLU,1,INDEX,NFILE) 
      IF (INDEX .LE. 0) GO TO 12
6999  IF (.NOT.(ECHO)) GO TO 61 
      DO 7000 I=1,6 
7000  NBUFR(I) = IWORD(I+2) 
      WRITE(LU,6000) (IREQ(I),I=1,6),(NBUFR(I),I=1,6) 
6000  FORMAT(6A2,4X,6A2)
61    NWREQ = .FALSE. 
      DO 62 I=1,6 
      IF (IWORD(I+2) .NE. IREQ(I)) GO TO 63 
62    CONTINUE
      GO TO 69
63    DO 64 I=1,6 
      IF (IWORD(I+2) .GT. IREQ(I)) GO TO 65 
      IF (IWORD(I+2) .LT. IREQ(I)) GO TO 60 
64    CONTINUE
65    NWREQ = .TRUE.
      GO TO 42
C 
69    IF(IREQ(7).EQ.2H  )GO TO 70 
      IF(IUPFL.EQ.0)GO TO 70
C 
      IF(IWORD(9).GT.IREQ(7))GO TO 71 
      IF((IWORD(9).EQ.IREQ(7)).AND.(IWORD(10).GT.IREQ(8)))71,42 
163   FORMAT(9X,"REV CODE DISCREPANCY:")
C 
C  CHECK PROG TYPE, FIGURE OUT FILE TYPE, CREATE THE FILE 
C 
70    IF(IREQ(7).EQ.2H  )GO TO 711
      IDSCRP=IREQ(7)-IWORD(9)+IREQ(8)-IWORD(10) 
      IF(IDSCRP.NE.0)WRITE(LLU,163) 
C 
C  IF UPDATE MODE,  UPDATE THE BATCH-FILE TO HAVE NEW REV CODES 
C 
71    IF(IUPFL.EQ.0)GO TO 711 
      IREQ(7)=IWORD(9)
      IREQ(8)=IWORD(10) 
      CALL POSNT(IDCB2,IERR,-1) 
      CALL WRITF(IDCB2,IERR,IREQ,LEN) 
C 
711   ITYPE=IAND(IWORD(12),77400B)
      ITYPE=ITYPE+ITYPE/256 
      FTYPE=0 
      IF(ITYPE.EQ.2HSS)FTYPE=4
      IF(ITYPE.EQ.2HRR)FTYPE=5
      IF(ITYPE.EQ.2HAA)FTYPE=7
      IF(ITYPE.EQ.2HDD)FTYPE=1
C------------------------------------------------------------ 
      IF(FTYPE.NE.0)GO TO 72
      WRITE(LU,170)ITYPE
170   FORMAT("/SDLS4: ILLEGAL PROGRAM TYPE: "A2)
      GO TO 10
C 
72    WRITE(LLU,172)(FNAME(I),I=1,3),(IBUF(INDEX+I),I=3,10),
     &              (IBUF(INDEX+I),I=18,44) 
172   FORMAT(1X,3A2,": ",8A2,1X,27A2) 
      N = 1 
      DO 175 I=3,10 
      NBUFR(N) = IBUF(INDEX+I)
175   N = N+1 
      NBUFR(N) = 2H 
      N = N + 1 
      DO 176 I=18,44
      NBUFR(N) = IBUF(INDEX+I)
176   N = N+1 
      NBUFR(N) = 0
      IF(FILEFL.NE.-1)GO TO 74
      ISIZE=FSIZE 
      ISIZE(2)=RECLN
      IF(ISIZE.EQ.0)ISIZE=-1
      CALL CREAT(IDCB,IERR,FNAME,ISIZE,FTYPE,SC,CR) 
      IF(IERR.LT.0)19,75
C 
74    CALL OPEN(IDCB,IERR,FNAME,0,SC,CR)
      IF(IERR.LT.0)GO TO 19 
      IF((FILEFL.NE.-1).AND.(IERR.GT.0))WRITE(LLU,174)FNAME 
174   FORMAT(9X"DUPLICATE FILE NAME - - "3A2) 
      FILEFL=IERR 
C 
C    LOOP    READ TAPE, LOAD FILE 
C 
C   CHECK THE DATA TYPE  (IWORD(1)):
C                                                       TYPE
C        A) EOB BLOCKS   =>  WRITE 0-LENGTH RECORD *      3 
C        B) EOF BLOCKS   =>  WRITE EOF                    4 
C        C) DATA BLOCKS  =>  THAT'S FINE!!!              -1 
C        D) PHYSICAL EOF =>  DONE!                       -2 
C        E) ELSE         =>  ERROR
C 
C          *  EXCEPT THE FIRST AND LAST ONES
C 
C 
C    ALSO, CHECK GETRC STATUS (INDEX):
C 
C     ANY ERROR (OR BREAK) ENCOUNTERED DURING PROGRAM LOAD WILL 
C   RESULT IN THE LOAD FILE BEING PURGED (EXCEPT IF TYPE 0) AND 
C   THE TAPE BEING POSITIONED BACK TO THE START OF THAT FILE
C 
C 
      IF ((FILEFL .NE. 0) .OR. (.NOT.(PUN))) GO TO 700
      CALL ALPHA (NBUFR,LUP)
700   IRECN=0 
75    CALL GETRC(IBUF,MTLU,0,INDEX,NFILE) 
      IF(INDEX.LE.0)GO TO 80
      NWDS=IBUF(INDEX)
      IF(IWORD(1).NE.4)GO TO 755
      CALL WRITF(IDCB,IERR,IBUF,-1) 
      GO TO 75
755   IF(IWORD(1).NE.3)GO TO 76 
756   IF(IRECN.NE.0)EOBFL=1 
      GO TO 75
76    IF(IWORD(1).EQ.-2)GO TO 77
      IF(EOBFL.NE.0)CALL WRITF(IDCB,IERR,IBUF,0)
      EOBFL=0 
      IF(IWORD(1).NE.-1)GO TO 78
C 
      IF(NWDS.EQ.0)GO TO 756
      IRECN=1 
      CALL WRITF(IDCB,IERR,IBUF(INDEX+2),NWDS)
      IF(IERR.LT.0)19,75
C 
C   EOF  FOUND
C 
77    WRITE(LU,177) 
177   FORMAT("/SDLS4: LOAD COMPLETE") 
      GO TO 39
C 
C  RECORD OUT OF SEQUENCE 
C 
78    INDEX=-14 
C 
C  BREAK DURING LOAD:  PURGE ACTIVE FILE (UNLESS TYPE 0)
C                      SET TAPE TO START OF CURRENT FILE
C 
80    CALL CLOSE(IDCB,IERR) 
      IF(FILEFL.EQ.0)GO TO 81 
      CALL PURGE(IDCB,IERR,FNAME,SC,CR) 
      IF(IERR.LT.0)GO TO 19 
81    CALL GETRC(IBUF,MTLU,-2,IDUMY,NFILE)
C-----------------------------------------IDUMY INSTEAD OF INDEX
      CALL GETRC(IBUF,MTLU,-1,IDUMY,NFILE)
C-----------------------------------------NO MORE 129 ERRORS! 
      GO TO 12
C 
C******************************************************** 
C 
C   PRINT CURRENT FILE NUMBER 
C 
87    WRITE(LU,187)NFILE
187   FORMAT("/SDLS4: CURRENT MAG TAPE FILE ="I5) 
      GO TO 10
C 
C   CHANGE LOG LU 
C 
85    WRITE(LU,185) 
185   FORMAT("/SDLS4: ENTER LOG LU: _") 
      READ(LU,*)LLU 
      GO TO 10
C 
C   PRINT ALL SDLS4 COMMANDS
C 
200   WRITE(LU,219) 
      WRITE(LU,201) 
      WRITE(LU,203) 
      WRITE(LU,205) 
      WRITE(LU,206) 
      WRITE(LU,207) 
      WRITE(LU,209) 
      WRITE(LU,211) 
      WRITE(LU,212) 
      WRITE(LU,213) 
      WRITE(LU,214) 
      WRITE(LU,202) 
      WRITE(LU,204) 
      WRITE(LU,206) 
      WRITE(LU,208) 
      WRITE(LU,215) 
      WRITE(LU,216) 
      WRITE(LU,218) 
      WRITE(LU,217) 
219   FORMAT(/" TASK      FUNCTION"/) 
201   FORMAT("LABEL     PRINT TAPE LABEL")
203   FORMAT("DIRECTORY LIST ALL FILE IDENTIFICATION ON TAPE")
205   FORMAT("REWIND    REWIND THE TAPE") 
207   FORMAT("N         PRINT CURRENT FILE POSITION NUMBER")
209   FORMAT("LL        CHANGE THE LOG DEVICE, LU # WILL BE ASKED") 
211   FORMAT("LOAD      LOAD A FILE FROM THE TAPE TO DISC") 
212   FORMAT("          NAME & PART # OR FILE # WILL BE ASKED") 
213   FORMAT("BATCH     GET LOAD COMMANDS FROM A FILE") 
214   FORMAT("          TAPE FORMAT: NAMR") 
202   FORMAT("                       PART # OR FILE #") 
204   FORMAT("                       NAMR") 
206   FORMAT("                         .")
208   FORMAT("                       /E   TERMINATES THE COMMANDS") 
215   FORMAT("UPDATE    SAME AS BATCH,BUT MUST USE PART #. IT LOADS") 
216   FORMAT("           FILES WITH LATER REV THAN THAT SPECIFIED IN")
218   FORMAT("           COMMAND FILE") 
217   FORMAT("END/EXIT  EXIT FROM SDLS4") 
      GO TO 10
C 
C 
C*********************************************************
C 
C 
C   'SUBROUTINE' TO OPEN AND CREATE REQUIRED FILES
C 
C   NOTES:  INPUTS 'NAMR' 
C           TRIES AN EXCLUSIVE OPEN ON THE FILE 
C             IF IT EXISTS AS TYPE 1, CLOSE IT 'TILL NEEDED 
C             IF NON-EXISTANT, FLAG IT AS 'NEEDED'
C    ( WHY TIE UP A FILE (OR DISC) IF YOU HAVE TO SEARCH THE TAPE FIRST)
C 
501   DO 511 I=1,20 
      IREQ(I)=2H
511   CONTINUE
      X=REIO(1,ILU,IREQ,20) 
502   DO 504 I=1,IB 
       IF(IAND(IREQ(I),77400B).NE.35000B)GO TO 503
       IREQ(I)=IOR(IAND(IREQ(I),377B),26000B) 
503    IF(IAND(IREQ(I),177B).NE.72B)GO TO 504 
       IREQ(I)=IOR(IAND(IREQ(I),177400B),54B) 
504   CONTINUE
C 
      IB=IB*2 
      CALL PARSE(IREQ,IB,IPBUF) 
      IF(IPBUF.LE.1)GO TO 11
C 
      FILEFL=-1 
      CALL OPEN(IDCB,IERR,FNAME,0,SC,CR)
      IF(IERR.GE.0)GO TO 512
      IF(IERR.NE.-6)GO TO 19
      GO TO IRETN 
C 
512   FILEFL=IERR 
      CALL CLOSE(IDCB,IERR) 
      GO TO IRETN 
C 
8000  WRITE(LU,8010)
8010  FORMAT("PUNCH LU FOR LABEL IS? _")
      READ(LU,*)LUP 
      PUN = .TRUE.
      GO TO 10
C********************************************************** 
C 
C 
C   END SECTION    REWIND TAPE AND UNLOCK THE LU
C 
C 
90    CALL GETRC(IBUF,MTLU,-3,INDEX,NFILE)
      CALL LURQ(100000B,MTLU,1) 
990   WRITE(LU,190) 
190   FORMAT("/SDLS4: DONE!"/)
C 
      END 
ASMB,R,B,L,C
* 
      NAM GETRC,7  VERSION 2  REV.1938 790919 
* 
*     THIS VERSION WILL HANDLE DATA FILES SUCH AS THE QUERY 
*     HELP FILE.  ALL CHANGES MADE TO JRT'S GETRC FOR THIS
*     FEATURE ARE DENOTED BY A LINE OF DASHES AS UNDERLINES.
* 
* 
      ENT GETRC 
      EXT EXEC,.ENTR,IFBRK
* 
* 
* 
* 
*    CALLING INFORMATION: 
* 
*   IFLAG:   -3  REWIND THE TAPE
*            -2  REVERSE 1 FILE (SET TAPE TO PREVIOUS FILE) 
*            -1  FORWARD FILE (FIND EOF)
*             0  FIND NEXT SEQUENTIAL RECORD
*             1  FIND PROGRAM ID BLOCK
*             2  FIND LIBRARY DIRECTORY RECORD
*             3  FIND EOB BLOCK 
*             4  FIND AN EOF BLOCK
*             ELSE REWIND & START ALL OVER....
* 
* 
*    IBUF IS 1153 WORDS LONG AND RESIDENT IN THE CALLING PROGRAM. 
*    GETRC READS INTO IBUF FROM MAG TAPE (MTLU) AND SETS 'INDEX'
*    TO POINT TO THE DESIRED ITEM (RECORD).  RECORD STRUCTURE ON
*    THE MTLS TAPE IS A HIERARCHY OF DATA RECORDS => LOGICAL RECORDS
*    => PHYSICAL RECORDS.  GETRC KEEPS TRACK OF THIS CRAP.
*      WHEN DATA RECORDS ARE SPLIT BETWEEN TWO PHYSICAL MAG TAPE RECORDS
*    GETRC WILL MOVE  THE FIRST PORTION OF THE RECORD INTO LOW-INDEXED
*    PART OF 'IBUF' THEN READ THE NEXT MAG TAPE RECORD TO GET THE REST
*    OF THE DATA RECORD.  THIS IS WHY 'IBUF' MUST BE 1153 WORDS LONG
*    EVEN THOUGH THE LARGEST MAG TAPE RECORD IS 1024 WORDS.  THE
*    ROUTINE USES  "CFLAG"  AS A FLAG TO INDICATE A RECORD REQUIRES 
*    CONTINUATION.  MAG TAPE RECORDS ARE READ INTO 'IBUF' STARTING
*    AT IBUF(129) IN ORDER TO LEAVE ROOM FOR A POSSIBLE MOVE AS 
*    DESCRIBED HERE.
* 
* 
*    GETRC RETURNS THE CURRENT PHYSICAL FILE NUMBER IN 'NFILE'
* 
*    RETURN FORMAT IN 'IBUF': 
* 
*       IBUF(INDEX)     =  LENGTH OF DATA RECORD
*       IBUF(INDEX+1)   =  RECORD TYPE  1-4 AS ABOVE
*                                        0 = TAPE LABEL RECORD
*                                       -1 = DATA RECORD
*                                       -2 = PHYSICAL EOF ENCOUNTERED 
*       IBUF(INDEX+2)   =  FIRST DATA WORD
* 
* 
* 
      SKP 
* 
* 
* 
*    RETURN FORMAT FOR 'INDEX': 
* 
*          -14 = RECORD OUT OF SEQUENCE 
*          -13 = ILLEGAL PROGRAM TYPE 
*          -12 = DATA RECORD LENGTH > 255 
*          -11 = INTERNAL ERROR  SEE LISTING
*          -10 = INTERNAL ERROR  SEE LISTING
*           -9 = INTERNAL ERROR  SEE LISTING
*           -8 = LOGICAL RECORD LENGTH ERROR
*           -7 = ILLEGAL RECORD  LENGTH 
*           -6 = LOGICAL RECORD OUTSIDE OF PHYSICAL BOUNDS
*           -5 = INTERNAL ERROR  SEE LISTING
*           -4 = BREAK FLAG WAS SET 
*           -3 = ILLEGAL LOGICAL RECORD TYPE
*           -2 = CHECKSUM ON DATA RECORD
*           -1 = CHECKSUM ERROR ON PHYSICAL RECORD
*            0 = END OF TAPE
*           >0 = POINTER INTO IBUF FOR DESIRED RECORD 
* 
*    NOTES:  IPOINT  IS LOCAL BUFFER POINTER
*            PMAX    POINTS TO END OF LOGICAL RECORD
*            NMAX    POINTS TO END OF PHYSICAL RECORD 
*            LRLNTH  IS LENGTH OF LOGICAL RECORD
* 
* 
* 
* 
* 
      SKP 
* 
* 
* 
IBUF  BSS 1 
MTLU  BSS 1 
IFLAG BSS 1 
INDEX BSS 1 
NFILE BSS 1 
* 
GETRC NOP 
      JSB .ENTR 
      DEF IBUF
* 
*  SET UP OFT-USED ADDRESSES INTO DATA BUFFER 
* 
      LDA IBUF
      ADA D128      SET ADDRESS OF START OF ACTIVE
      STA IB129     PART OF DATA BUFFER 
      INA 
      STA IB130     AND NEXT WORD,TOO.
* 
      LDA D129      SET RETURN-POINTER TO START OF
      STA INDEX,I   DATA ARRAY AS WELL. 
      LDA IFLAG,I   CHECK FOR 'QUICKIE'S 1ST
      CPA DM3 
      JMP RWIND     -3 = REWIND THE TAPE
      CPA DM2 
      JMP RVFIL     -2 = REVERSE 1 FILE 
      CPA DM1 
      JMP FWFIL     -1 = FORWARD ONE FILE 
      SSA           IFLAG CAN'T BE <-3 OR >4... 
      JMP RWIND     ELSE TAPE REWINDS 
      ADA DM5 
      SSA 
      JMP PHYSR     IF O.K., GET A DATA RECORD
* *q
* 
* 
      SKP 
* 
* 
RWIND LDA B400      REWIND CODE...
      JSB TAPE      GO DO IT... 
      CLA,INA       RESET MAG TAPE FILE # TO 1
      STA FILE
RTRN0 CLA           '0' RETURN POINT (EOF RETURN) 
      STA PMAX      RESET ALL LOCAL POINTERS
      STA NMAX
      STA BPNTR 
      LDA DM2       SET DATA WORD 2 = -2
      STA IB130,I   AS INDICATION OF EOF
* 
RTRN1 LDA FILE      '1' RETURN, PASS RESULTS TO CALLER
      STA NFILE,I 
      JSB BCHK      CHECK BREAK FLAG
      JMP GETRC,I 
* 
*  REVERSE 1 FILE ON THE TAPE 
* 
RVFIL LDA B1400     REV FILE CODE 
      JSB TAPE      GO DO IT... 
      LDA B1400     GO DO IT AGAIN... 
      JSB TAPE
      LDA FILE
      ADA DM2       RESET THE FILE COUNTER
      SZA,RSS       IF FILE # <=0 SET IT
      CLA,INA       EQUAL TO 1
      SSA 
      CLA,INA 
      STA FILE      ELSE, IT'S O.K. 
* 
*  FORWARD SPACE ONE FILE 
* 
FWFIL LDA B1300     FORWARD FILE CODE 
      JSB TAPE      GO DO IT... 
      ISZ FILE      INCREMENT FILE COUNTER
      JMP RTRN0     RETURN THRU 'EOF RETURN'
* 
* 
      SKP 
* 
* 
* START LOOKING FOR A TAPE DATA RECORD HERE 
* 
PHYSR LDA BPNTR     IF LOCAL POINTER IS WITHIN
      LDB NMAX      DATA BUFFER BOUNDS, THEN WE DON'T 
      JSB .GE.      NEED A PHYSICAL TAPE READ YET...
      SEZ,RSS 
      JMP LR.1      SO GO GET THE NEXT LOGICAL RECORD!
* 
PHSR2 JSB BCHK      IF NEED A TAPE READ, CHECK BREAK
      LDA D129      FLAG FIRST.  ALL O.K., PRESET RETURNED
      STA INDEX,I   POINTER.  RESET LOCAL RECORD
      CLA           POINTERS ALSO.
      STA PMAX
      STA NMAX
* 
      JSB EXEC      GO GET THAT MOTHA!!!
      DEF *+5 
      DEF ONE 
      DEF MTLU,I
IB129 NOP 
      DEF D1024 
      STB TLOG      SAVE TRANSMISSION LOG  (AAMCO TOOT TOOT)
* 
      JSB EXEC      IS IT AN EOF? 
      DEF *+4 
      DEF D13 
      DEF MTLU,I
      DEF ISTAT 
* 
      LDA ISTAT 
      AND B200
      SZA,RSS 
      JMP GOT1      IF NOT AN EOF, PROCESS THE RECORD!
* 
*  EOF PROCESSING 
* 
      LDA DM2       SET IBUF(130) = -2 TO SIGNAL CALLER 
      STA IB130,I 
      ISZ FILE      INCREMENT FILE COUNTER
      ISZ EOTFL     COUNT # OF EOF'S IN A ROW...
      JMP PCNT1     IF NOT 2 IN A ROW, CONTINUE 
      CLA           ELSE CLEAR EOF FLAG AND SIGNAL
      STA INDEX,I   CALLER THAT THIS IS IT!!! 
      STA EOTFL     RESET EOT FLAG
      JMP RTRN1     TAPES ALL DONE!!! 
* 
PCNT1 CCA           GOT 1 EOF, GET SET FOR
      STA EOTFL     POSSIBLE NEXT ONE.
      LDA IFLAG,I   IF OP CODE = 0 (FIND NEXT 
      SZA,RSS       SEQUENTIAL RECORD) THEN RETURN. 
      JMP RTRN1     IF HE WANTS SOMETHING SPECIAL 
      JMP PHSR2     GO TRY AGAIN
* 
      SKP 
* 
* 
*  START PROCESSING MAG TAPE RECORDS HERE...
* 
*  CHECK TAPE RECORD'S CHECKSUM 
* 
GOT1  STA EOTFL     RESET EOT FLAG
      LDA TLOG      CHECK THAT RECORD WAS < 1024
      LDB D1024 
      JSB .LE.
      SEZ 
      JMP CHK.1     ALL'S O.K.  GO TO CHK.1 
      LDA DM7       ELSE, -7 = ERROR CODE!
.BAD  STA INDEX,I   THIS IS BAD GUY RETURN! 
      JMP RTRN0     NOW TO 'EOF RETURN'!
* 
CHK.1 LDB IB130     <B> = DATA ADDRESS START
      LDA IB129,I   GET SIO COUNT 
      ARS           CHANGE TO WORD COUNT
      ADA IB129     ADD STARTING ADDRESS
      STA END       <A> = END = DATA ADDRESS END
      LDA B,I       SET UP CHECKSUM 
      STA CHKSM 
LOOP1 INB           INCREMENT ADDRESS 
      CPB END       = LAST ADDRESS? 
      JMP CHK.2     YES, CHECK CHECKSUMS
      ADA B,I       NO, KEEP ADDING.... 
      JMP LOOP1     DO IT AGAIN, DO IT AGAIN, DO IT...
* 
CHK.2 CPA B,I       OURS = THEIRS???
      JMP PH.OK     YES, PHYS. RECORD O.K.
      CCA           NO, FUCK YOU!!! 
      JMP .BAD
* 
PH.OK STB NMAX      SAVE 'END' AND MAX PHYS REC 
      LDA IB130     ADDRESS. RESET WORK POINTER 
      STA BPNTR 
* 
* 
      SKP 
* 
* 
*  START PROCESSING LOGICAL RECORDS HERE... 
* 
*  THERE'S A LOT OF CHECKING TO DO: 
*    1)  MAYBE WE ONLY NEED A DATA RECORD (ASCII LINE, ABSOLUTE RECORD
*        ETC.).  IF WE ACTUALLY DO NEED A NEW LOGICAL RECORD GO TO '3)' 
*        ELSE WE'RE STILL PROCESSING THE PREVIOUS ONE AND...
*    2)  IF WE'RE HERE, WE HAVE PROGRAM DATA SINCE  MTLS  INFO-RECORDS
*        MUST BY DEFINITION BE PROCESSED COMPLETELY BEFORE ASKING FOR 
*        A NEW ONE.  THUS, IF THE OP-CODE (IFLAG IN CALL) IS NOT A
*        REQUEST FOR NEXT-SEQUENTIAL-RECORD (0) IT IS FOR AN MTLS 
*        RECORD AND THEREFOR EVEN IF WE ARE NOT DONE WITH THIS ONE WE 
*        NEED A NEW ONE ANYHOW (GO TO '3)')  ELSE GO PROCESS DATA...
*    3)  IF WE'RE DONE WITH THE LOGICAL RECORD SEE IF THERE'S ANOTHER 
*        ALREADY IN MEMORY.  IF NOT, GO GET ANOTHER MAG TAPE RECORD 
*        (PHYSICAL READ VS. LOGICAL READ) 
*    4)  THE LOGICAL RECORD LENGTH SHOULD BE CONSISTENT WITH PHYSICAL 
*        RECORD BOUNDS.  AS OF 4/75, THERE ARE MTLS TAPES OUT WITH ERRORS 
*        IN PROGRAM ID BLOCK RECORDS (THEY'RE MISSING A WORD) SO THIS 
*        CHECK CAN'T BE DONE YET. 
*    5)  CHECK LOGICAL RECORD TYPE.  IF IT'S AN MTLS RECORD, IT'S LENGTH
*        SHOULD AGREE WITH THE TABLE VALUES (SEE 'LNTAB') 
* 
* 
LR.1  LDA BPNTR 
      LDB PMAX      <A> = BPNTR . IF WORK POINTER EXCEEDS 
      JSB .GE.      LOG REC POINTER, SO NEED A
      SEZ           NEW LOGICAL RECORD. ELSE WE 
      JMP GETLR     GOT DATA.  CHECK THAT OP-CODE 
      LDA IFLAG,I   IS 0, OR ELSE WE NEED A 
      SZA           NEW LOGICAL RECORD. 
      JMP NXTLR 
      LDA PRGTP     PROCESS DATA ACCORDING TO 
      CPA SS        PROGRAM TYPE (S, R, OR ABS) 
      JMP SRC.2     IF TYPE = 'SS', HAVE SOURCE.
      JMP REL.1     ELSE CHECK FOR RELOCATABLE... 
* 
* 
      SKP 
* 
* 
*   GET A NEW LOGICAL RECORD
* 
GETLR LDA BPNTR     NEED A PHYSICAL RECORD FIRST? 
      LDB NMAX      (I.E. IS WORK POINTER OUT OF BOUNDS)
      JSB .GE.
      SEZ 
      JMP PHSR2     YES, GET ONE
* 
      LDA BPNTR,I   NO, GET LR RECORD LENGTH
      CMA,INA 
      STA LRLNT     SAVE IT.
      SSA,RSS       IF (-) = WORDS
      JMP *+5       IF(+) = CHARACTERS. CONVERT 
      CMA,INA       TO (+) WORDS
      INA 
      ARS 
      STA LRLNT     SAVE IT 
      INA           SET PMAX = POINTER + LENGTH + 1 
      ADA BPNTR 
      STA PMAX      THIS IS MAX LR ADDRESS
* 
*  TAKE AWAY *'S TO ENABLE THIS SECTION 
* 
*      LDB NMAX      IF LR BOUND EXCEEDS PHYS REC 
*      JSB .GT.      BOUND, THEN NO GOOD! 
*      SEZ           SET EOF (THIS SHOULD MUCK THINGS UP! 
*      JMP RTRN0
* 
      SKP 
* 
* 
*  PROCESS A NEW LOGICAL RECORD...
* 
*  IF LENGTH >= 0 HAVE A DATA RECORD:   SOURCE
*                                       RELOCATABLE 
*                                       ABSOLUTE
* 
*   LENGTH < 0 & WE HAVE AN MTLS-INFO RECORD
* 
*   WORD 2     MEANING             LENGTH 
*    0       TAPE LABEL             37
*    1       PROGRAM I.D. BLOCK    129
*    2       LIBRARY DIRECTORY     129
*    3       EOB BLOCK               1
*    4       EOF BLOCK               3
* 
* 
*-------------------------------------------------------------- 
* 
*  THERE IS A PROBLEM HERE, HOWEVER, SINCE A DATA TYPE FILE MAY 
*  CONTAIN NEGATIVE DATA WHERE THIS PROGRAM THINKS IT HAS A LENGTH
*  WORD.  SO, IF BPNTR DOES NOT POINT TO IB130 AND PROGRAM TYPE 
*  IS DD AND IFLAG IS ZERO, SKIP DIRECTLY TO SRC.1. 
* 
*-------------------------------------------------------------
* 
* 
      LDA BPNTR 
*-------------------------------------------------------------- 
      CPA IB130 
*---------------------------------------------------------------
      JMP ROKAY 
*---------------------------------------------------------------
      LDA PRGTP 
*---------------------------------------------------------------
      CPA DD
*---------------------------------------------------------------
      RSS 
*---------------------------------------------------------------
      JMP ROKAY 
*---------------------------------------------------------------
      LDA IFLAG,I 
*---------------------------------------------------------------
      SZA,RSS 
*---------------------------------------------------------------
      JMP SRC.1 
*---------------------------------------------------------------
* 
ROKAY LDA BPNTR,I   GET LENGTH AGAIN
*---------------------------------------NEW LABEL 
      SSA           IF < 0, PROCESS MTLS STUFF
      JMP .MTLS     (CHECK IT FIRST...) 
      LDA IFLAG,I   CHECK OP-CODE: MUST BE = 0! 
      SZA,RSS       OR GET A NEW LOGICAL RECORD 
      JMP SRC.1     IF = 0, WE HAVE DATA, O.K.
      JMP NXTLR     ELSE GET NEXT LOGICAL RECORD. 
* 
* 
      SKP 
* 
* 
*   PROCESS MTLS-INFO RECORDS 
* 
.MTLS CLA           RESET 'CONTINUATION' FLAG 
      STA CFLAG     SO WE KNOW THAT NEXT DATA 
      LDA BPNTR     RECORD IS A NEW ONE...
      INA 
      LDA A,I       GET RECORD TYPE 
      STA RECTP     SAVE IT 
      CPA IFLAG,I   IS IT WHAT HE WANTS?
      JMP GOTIT     YES, GO TO IT BABY!!! 
      LDB IFLAG,I   NO, WILL HE TAKE ANYTHING?
      SZB,RSS       YES, WE GOT THAT, TOO!
      JMP GOTIT 
* 
NXTLR LDA PMAX      GET NEXT LOGICAL RECORD 
      STA BPNTR     RESET WORK POINTER
      JMP GETLR     GO THRU NORMAL CHANNELS.
* 
* 
* 
      SKP 
* 
* 
* 
*  PROCESS MTLS INFO RECORDS
* 
* 
* 
GOTIT CPA FOUR      IF WITHIN 0 TO 4, O.K.
      JMP *+6 
      AND THREE 
      CPA RECTP 
      JMP *+3 
      LDA DM3       ELSE ERROR CODE = -3
      JMP .BAD
* 
      ADA LNTAB     INDEX INTO LENGTH TABLE 
      LDA A,I       AND VERIFY RECORD LENGTH
      CPA LRLNT     IF AGREE, ALL'S WELL... 
      JMP M.OK
      LDB BPNTR     EXECEPTION!: THE LAST PROG
      ADB THREE     ID BLOCK IN THE LIBRARY IS
      LDB B,I       A SHORT ONE INDICATING THE END
      CPB .99       OF THE LIBRARY. IT'S FOR
      JMP M.OK      PART NUMBER 99999-99 ETC
      LDA DM8       ELSE ERROR CODE = -8
      JMP .BAD
* 
M.OK  STA BPNTR,I   SET POINTERS, ETC:
      LDA IBUF      SET (+) LR LNTH IN BUFFER 
      CMA,INA       SET 'INDEX' = INDEX INTO ARRAY
      ADA BPNTR     SET LOCAL POINTER = PMAX
      INA            SO NEXT ROUND GETS NEW RECORD
      STA INDEX,I   IF HAVE ID BLOCK, SAVE PROG TYPE
      LDA PMAX      RETURN TO CALLER
      LDB BPNTR 
      STA BPNTR 
      LDA RECTP 
      CPA ONE 
      RSS 
      JMP RTRN1 
* 
      ADB TWELV     GET PROG TYPE CHARACTER 
      LDA B,I       ISOLATE IT & DUPLICATE IT 
      AND UPPER     SO IT'S 'SS' OR 'AA' OR 'RR'
      STA B 
      BLF,BLF 
      IOR B 
      STA PRGTP     SAVE IT 
      JMP RTRN1     RETURN
* 
* 
      SKP 
* 
* 
*   PROCESS PROGRAM DATA
* 
* 
SRC.1 ISZ BPNTR     POINT TO DATA INFO
      LDA PRGTP 
      CPA SS        IS IT SOURCE DATA?
      RSS 
      JMP REL.1     NO, CHECK FOR RELOCATABLE 
* 
* 
*  SOURCE RECORDS  (THE WORST)
* 
*     PHYSICALLY MOVE 'EM FROM WHERE THEY ARE  (IBUF(129) OR ABOVE) TO
*     LOW IN THE BUFFER (IBUF(1)).  GOTTA DO THIS 'CAUSE CR & LF NOT
*     NECESSARILY IN THE SAME WORD.   SDLS (VS. MTLS) DOES SOME CLEANUP Px
*     OF TAPE RECORDS TO TRY TO HAVE THAT, BUT IT CAN'T BE GUARANTEED...
*     ALSO, PREFACE THE RECORD WITH FAKE LENGTH AND TYPE TO MAINTAIN
*     FORMAT COSISTENCY WITH MTLS-INFO RECORDS. 
* 
* 
*     NOTES         BBYTE:  SOURCE/DESTINATION BYTE 
*                   DBYTE:        POINTERS
*                   DPNTR:  DESTINATION BUFFER ADDRESS
*                   LFFLG:  LINE-FEED FLAG
* 
* 
      LDA B177
      XOR SHIFT     RE-SET:  SOURCE BYTE POINTER
      STA BBYTE              LINE FEED FLAG 
      CLA                    CONTINUATION FLAG
      STA LFFLG 
      LDB CFLAG     IF IT'S NOT A CONTINUATION, RESET 
      STA CFLAG      THE DESTINATION BYTE POINTER AND 
      SZB            ADDRESS POINTER
      JMP SRC.3 
SRC.2 LDA TWO       NOTE: CONTINUATION OCCURS WHEN
      ADA IBUF      A DATA RECORD IS SPLIT 'TWIXT 
      STA DPNTR     TWO MAG TAPE RECORDS. 
      LDA B177
      STA DBYTE 
* 
* 
      SKP 
* 
* 
* 
*   LOOP FOR PROCESSING SOURCE CODE 
* 
SRC.3 LDA BPNTR     IF WE'RE OUT OF THE BUFFER
      LDB PMAX      WE NEED A NEW RECORD
      JSB .GE.
      SEZ,RSS 
      JMP SRC.4 
      CLA,INA 
      STA CFLAG     SET CONTINUATION FLAG 
      JMP GETLR     GO GET A RECORD 
* 
SRC.4 LDA BPNTR,I   GET BYTE W/O PARITY 
      AND BBYTE 
      STA B 
      AND DBYTE     HAVE TO SHIFT IT? 
      SZA           IE. DO WE WANT THE CHAR WHERE 
      BLF,BLF       'DBYTE' AIN'T?
      LDA B         IF SO, SHIFT ALREADY! 
      CPA HI.CR     IGNORE IT IF IT'S 
      RSS           A CARRIAGE RETURN 
      CPA LO.CR 
      JMP IGNOR 
      CPA HI.LF     IF IT'S A LINE FEED THEN
      RSS           MAKE IT A SPACE AND SET 
      CPA LO.LF     THE LINE FEED FLAG
      RSS 
      JMP STUFF     ELSE STUFF IT IN BUFFER 
      ALS,ALS       LINE UP LF BITS WITH SPACE
      AND DBLSP     (DON'T KNOW HI OR LO) 
      STA LFFLG 
STUFF STA CHAR      SAVE THE CHARACTER
* 
      LDA DBYTE     GET GOOD BYTE FROM DESTINATION
      AND DPNTR,I 
      IOR CHAR      INSERT NEW CHARACTER
      STA DPNTR,I   PUT IN DESTINATION BUFFER 
* 
      LDA DBYTE     RESET BYTE POINTERS 
      XOR SHIFT 
      STA DBYTE 
      SLA 
      ISZ DPNTR 
* 
* 
* 
      SKP 
* 
* 
IGNOR LDA BBYTE     SET UP NEXT SOURCE BYTE 
      XOR SHIFT     MASK
      STA BBYTE     IF GETTING HIGH BITS NEXT,
      SLA,RSS       INCREMENT WORD POINTER. 
      ISZ BPNTR 
* 
      LDA LFFLG     GET A LINE FEED?
      SZA,RSS 
      JMP SRC.3     NO, LOOP SOME MORE
      CLA           YES, RESET THE FLAG 
      STA LFFLG          SET THE RECORD LENGTH
      LDA IBUF
      ADA TWO        (2 FOR LENGTH & TYPE)
      CMA,INA 
      ADA DPNTR 
      STA IBUF,I
* 
      LDB IBUF      RETURN RECORD TYPE
      INB 
      CCA 
      STA B,I 
      CLA,INA       SET POINTER = 1 
      STA INDEX,I 
      JMP RTRN1     RETURN... 
* 
* 
      SKP 
* 
* 
*   RELOCATABLE & ABSOLUTE RECORDS
* 
* 
REL.1 LDA CFLAG     IS IT A CONTINUATION? 
      SZA,RSS 
      JMP REL.2     NO, CONTINUE NORMALLY 
      LDA TEMP1     YES, RESET TEMP VALUES
      STA BPNTR 
      LDA TEMP2 
      STA IB129,I   OVERWRITE OLD SIO COUNTS WITH 
      LDA TEMP3     NEW DATA
      STA IB130,I 
      CLA 
      STA CFLAG 
* 
*REL.2 LDB PMAX 
*--------------REMOVED FOR PROCESSING OF DATA TYPE
REL.2 LDA PRGTP     IS THIS A DATA FILE?
*---------------------------------------------------------------
      CPA DD
*---------------------------------------------------------------
      JMP DAT.1     YES, GO PROCESS DATA TYPE.
*---------------------------------------------------------------
      LDB PMAX
*     --------REPLACING INSTRUCTION REMOVED ABOVE 
      LDA BPNTR,I   GET ADDRESS OF FIRST NON- 
      SZA           ZERO WORD (RECORD LENGTH) 
      JMP REL.3     GOT IT! GO PROCESS
      ISZ BPNTR 
      CPB BPNTR     IF RUN OUT OF DATA, GO
      JMP GETLR     GET ANOTHER RECORD
      JMP REL.2+1   ELSE KEEP LOOKING 
* 
REL.3 AND UPPER     ISOLATE WORD COUNT
      CPA BPNTR,I   A LEGITIMATE VALUE? 
      JMP *+3 
      LDA DM12      NO, ERROR CODE = -12
      JMP .BAD
      ALF,ALF       GET BITS WHERE THEY BELONG..
      STA RECLN     YES, SAVE RECORD LENGTH 
      LDB PRGTP     PROG TYPE ABSOLUTE? 
      CPB AA
      RSS 
      JMP REL.4     NO, GO PROCESS RELOCATABLE
* 
* 
      SKP 
* 
* 
*  ABSOLUTE RECORDS 
* 
* 
      ADA BPNTR     IF RECORD IS NOT ENTIRELY 
      ADA TWO       IN MEMORY, GO DO CONTINUATION 
      STA END       TRICK.  ELSE PROCESS
      INA 
      LDB PMAX
      JSB .GE.
      SEZ 
      JMP CNTNU 
* 
      LDB BPNTR     CHECK THE RECORD'S CHECKSUM 
      INB 
      LDA B,I 
ABS.2 INB 
      CPB END 
      JMP ABS.3 
      ADA B,I 
      JMP ABS.2 
ABS.3 CPA B,I       CHECKSUMS AGREE?
      JMP ABS.4     YES, GO ON... 
      LDA DM2       NO, ERROR CODE = -2 
      JMP .BAD
* 
ABS.4 LDA BPNTR     SET TYPE - -1 
      ADA DM1 
      CCB 
      STB A,I I@
      ADA DM1 
      LDB RECLN     SET LENGTH = ABS RECORD 
      ADB THREE     RECORD-LENGTH 
      STB A,I 
      LDA IBUF      SET INDEX INTO ARRAY
      CMA,INA 
      ADA BPNTR 
      ADA DM1 
      STA INDEX,I 
      ADB BPNTR     RESET POINTER FOR NEXT RECORD 
      STB BPNTR 
      JMP RTRN1     RETURN
* 
* 
      SKP 
* 
* 
*   PROCESS RELOCATABLE RECORDS 
* 
* 
REL.4 CPB RR        IS PROG TYPE RELOCATABLE? 
      JMP *+3       YES, CONTINUE 
      LDA DM13      ELSE ERROR CODE = -13 
      JMP .BAD      SOCK IT TO 'IM!!! 
      ADA BPNTR     IS RECORD ENTIRELY WITHIN 
      STA END       MEMORY? 
      LDB PMAX
      JSB .GE.
      SEZ 
      JMP CNTNU     NO, GO GET CONTINUATION 
* 
      LDA BPNTR 
      INA 
      LDB A,I       GET 1ST VALUE 
      INA 
LOOPR INA 
      CPA END 
      JMP REL.5 
      ADB A,I 
      JMP LOOPR 
* 
REL.5 LDA BPNTR 
      ADA TWO 
      CPB A,I       CHECKSUMS AGREE?
      JMP *+3 
      LDA DM2       NO, ERROR CODE = -2 
      JMP .BAD
* 
      ADA DM3 
      CCB 
      STB A,I 
      ADA DM1 
      LDB RECLN 
      STB A,I 
      CMA,INA 
      ADA IBUF
      CMA,INA 
      INA 
      STA INDEX,I 
      LDA BPNTR 
      ADA RECLN 
      STA BPNTR 
      JMP RTRN1     RETURN TO CALLER
* 
* 
      SKP 
**----------------------------------------------------------- 
**
**   THIS WHOLE SECTION WAS ADDED FOR PROCESSING OF DATA
**   TYPE FILES.  THE UNDERSCORING IS DISCONTINUED DURING 
**   THIS SECTION.  THE SECTION ENDS WITH THE SKP INSTRUCTION 
**   IMMEDIATELY PRECEDING THE CONTINUATION SECTION.
**
**----------------------------------------------------------- 
* 
* 
*   PROCESS DATA FILE RECORDS 
* 
* 
DAT.1 LDA D128      GET DATA RECORD LENGTH
      STA RECLN 
      ADA BPNTR     IF RECORD IS NOT ENTIRELY 
      STA END         IN MEMORY,
      LDB NMAX
      CPA B         (IF SAME ALL OKAY)
      JMP DAT.2 
      JSB .GE.
      SEZ 
      JMP CNTNU       GO GET CONTINUATION.
* 
*  END OF FILE IS SIGNIFIED ON DATA FILES BY 2 DC3 CHARACTERS IN THE
*  FIRST WORD OF THE CURRENT LOGICAL RECORD.  CHECK FOR THIS.  IF 
*  IT IS AN END OF FILE, RETURN WITH TYPE = -2 INSTEAD OF -1. 
* 
DAT.2 LDA BPNTR,I 
      CPA .2DC3 
      RSS 
      JMP DAT.3 
      LDA BPNTR     END OF FILE,
      ADA DM1         SET TYPE TO -2
      LDB DM2 
      STB A,I 
      JMP DAT.4       AND CONTINUE WITH PROCESSING. 
* 
DAT.3 LDA BPNTR     SET TYPE = -1 
      ADA DM1 
      CCB 
      STB A,I 
DAT.4 ADA DM1       SET RECORD LENGTH = 128 
      LDB RECLN 
      STB A,I 
      LDA IBUF      SET INDEX INTO ARRAY
      CMA,INA 
      ADA BPNTR 
      ADA DM1 
      STA INDEX,I 
      ADB BPNTR     RESET POINTER FOR NEXT RECORD 
      STB BPNTR 
      JMP RTRN1     RETURN
* 
* 
      SKP 
      SKP 
* 
* 
* 
*  RECORD CONTINUATION SECTION
* 
CNTNU LDA PMAX      CHECK IF THIS IS REALLY 
      LDB NMAX      NECESSARY 
      JSB .GE.
      LDA DM9       SET ERROR CODE  = -9
      SEZ,RSS 
      JMP .BAD
* 
      ADA DM1       SHOULD NOT HAVE CONTINUATION HERE.
      LDB CFLAG 
      SZB 
      JMP .BAD
* 
      ADA DM1       PRESET ERROR = -11
      LDB BPNTR     MUST NOW MOVE EXISTING DATA 
      CMB,INB       OUT OF THIS AREA INTO LOW BUFFER. 
      ADB NMAX      BUT ONLY FAR ENOUGH SO THAT 
      STB NMOVE     IT'LL BE CONTIGUOUS WITH
      CMB,INB       NEW DATA TO BE READ IN.  THIS 
      ADB D131      PART CHECKS THAT THE MOVE IS
      SSB           ENTIRELY WITHIN THE BUFFER. 
      JMP .BAD
* 
      LDA NMOVE 
      CMA,INA       SAVE AS START, NEXT TIME. 
      ADA IB130     CLACULATE END OF MOVE 
      INA 
      STA TEMP1 
      STA DPNTR 
      LDB BPNTR 
LOOPM LDA B,I       MOVE-LOOP...
      STA DPNTR,I 
      ISZ DPNTR 
      INB 
      CPB PMAX
      RSS 
      JMP LOOPM 
* 
      LDA IB129,I   SAVE DATA IN WORD-COUNT 
      STA TEMP2     AND TYPE WORDS. 
      LDA IB130,I 
      STA TEMP3 
      CCA           SET CONTINUATION FLAG 
      STA CFLAG 
      JMP PHSR2     GO READ THE MAG TAPE... 
* 
* 
      SKP 
* 
* 
* 
* 
* 
*   UTILITY ROUTINES
* 
* 
*   PERFORMS  <A> .OP. <B>   E = 1/0 FOR TRUE/FALSE 
* 
.LE.  NOP 
      CMA,INA       A<=B IF B-A IS (+)
      ADA B 
      CLE,SSA,RSS 
      CCE 
      JMP .LE.,I
* 
.GE.  NOP 
      CMB,INB       A>=B IF A-B IS (+)
      ADA B 
      CLE,SSA,RSS 
      CCE 
      JMP .GE.,I
* 
* 
      SKP 
* 
* 
TAPE  NOP 
      IOR MTLU,I    <A> = CONTROL CODE
      STA CONWD 
      JSB EXEC
      DEF *+3 
      DEF THREE 
      DEF CONWD 
      JMP TAPE,I    RETURN
* 
* 
BCHK  NOP 
      JSB IFBRK     CHECK BREAK FLAG
      DEF *+2 
      DEF * 
      SSA,RSS       IF SET, SET CODE = -4 
      JMP BCHK,I    AND RETURN TO CALLER
      LDA DM4 
      JMP .BAD
* 
* 
      SKP 
* 
* 
*   BUFFERS, CONSTANTS, AND STORAGE.....
* 
* 
LNTAB DEF *+1 
D37   DEC 37        * TABLE OF VALID MTLS 
D129  DEC 129       *  RECORD LENGTHS 
      DEC 129       * 
ONE   DEC 1         * 
THREE DEC 3         * 
* 
FILE DEC 1          GETS MODIFIED...
NMAX  NOP           INPUT TAPE-RECORD MAX ADDRESS 
PMAX  NOP           LOGICAL RECORD MAX ADDRESS
EOTFL NOP           END-OF-TAPE FLAG
CFLAG NOP           CONTINUATION FLAG 
NMOVE NOP 
* 
PRGTP NOP           PROGRAM TYPE  SS AA RR
.99   ASC 1,99
SS    ASC 1,SS
RR    ASC 1,RR
AA    ASC 1,AA
DD    ASC 1,DD
RECTP NOP           MTLS INFO RECORD TYPE 
LRLNT NOP           LOGICAL RECORD LENGTH 
* 
BPNTR  NOP           DATA BUFFER POINTER
DPNTR NOP           DEST. BUFFER POINTER
BBYTE NOP           BUFFER BYTE SELECT MASK 
DBYTE NOP           DEST. BUFR BYTE SELECT
* 
* 
      SKP 
* 
*  CONSTANTS
* 
* 
DM13  DEC -13 
DM12  DEC -12 
DM9   DEC -9
DM8   DEC -8
DM7   DEC -7
DM5   DEC -5
DM4   DEC -4
DM3   DEC -3
DM2   DEC -2
DM1   DEC -1
* 
TWO   DEC 2 
FOUR  DEC 4 
TWELV DEC 12
D13   DEC 13
D128  DEC 128 
D131  DEC 131 
D256  DEC 256 
D1024 DEC 1024
D1025 DEC 1025
* 
B177  OCT 177 
B200  OCT 200 
B400  OCT 400 
B1400 OCT 1400
B1300 OCT 1300
UPPER OCT 77400 
SHIFT OCT 77577 
HI.CR OCT 6400
LO.CR OCT 15
HI.LF OCT 5000
LO.LF OCT 12
DBLSP ASC 1,   *
.2DC3 OCT 11423 
* 
*  STORAGE
* *q
IB130 BSS 1 
TLOG  BSS 1 
ISTAT BSS 1 
CHKSM BSS 1 
CHAR  BSS 1 
LFFLG BSS 1 
TEMP1 BSS 1 
TEMP2 BSS 1 
TEMP3 BSS 1 
END   BSS 1 
RECLN BSS 1 
CONWD BSS 1 
* *q
A     EQU 0 
B     EQU 1 
* 
* 
     END
ASMB,R,B,L,C
      NAM ALPHA,7  REV A 750120 
* DOES AN ALPHABETIC SORT ON 3-WORD FIELD IN (NAMES) IFILE FIELDS LONG. 
* IT ALSO SETS BIT 8 OF THE TRACK SECTOR WORD IF IT IS AN EXTENT. 
* CALLED FROM FTN BY:  CALL ALPHA(NAMES,IFILE)
      ENT ALPHA 
      EXT .ENTR 
NAMES BSS 1 
IFILE BSS 1 
ALPHA NOP 
      JSB .ENTR 
      DEF NAMES 
      CLA 
      STA RPEAT 
      LDA IFILE,I 
      CMA,INA 
      STA CNTR1 
LOOP1 EQU * 
      LDA CNTR1 
      ADA IFILE,I 
      ALS,ALS 
      ADA NAMES 
      STA ADDR1 
      STA PNTR1 
      LDA CNTR1 
      CPA RPEAT 
      JMP OUT 
      INA 
      SZA,RSS 
      JMP OUT 
      STA CNTR2 
LOOP2 EQU * 
      LDA CNTR2 
      ADA IFILE,I 
      ALS,ALS 
      ADA NAMES 
      STA ADDR2 
      STA PNTR2 
      LDA DM3 
      STA CNTR3 
      LDA ADDR1 
LOOP3 EQU * 
      LDB ADDR2,I 
      CMB,INB 
      ADB A,I 
      INA 
      ISZ ADDR2 
      SSB 
      JMP END2
      SZB 
      JMP SWTCH 
      ISZ CNTR3 
      JMP LOOP3 
      STA B 
      LDA A,I 
      IOR IFLAG     SET A FLAG
      STA B,I         IF A FILE 
      LDA ADDR2,I       EXTENT
      IOR IFLAG 
      STA ADDR2,I 
      JMP END2
SWTCH EQU * 
      LDA DM4 
      STA CNTR4 
      LDA ADDR1 
      STA PNTR1 
LOOP4 EQU * 
      LDA PNTR1,I 
      LDB PNTR2,I 
      SWP 
      STA PNTR1,I 
      STB PNTR2,I 
      ISZ PNTR1 
      ISZ PNTR2 
      ISZ CNTR4 
      JMP LOOP4 
END2 EQU *
      ISZ CNTR2 
      JMP LOOP2 
      ISZ CNTR1 
      JMP LOOP1 
OUT   EQU * 
      JMP ALPHA,I 
CNTR1 BSS 1 
CNTR2 BSS 1 
CNTR3 BSS 1 
CNTR4 BSS 1 
PNTR1 BSS 1 
PNTR2 BSS 1 
RPEAT BSS 1 
ADDR1 BSS 1 
ADDR2 BSS 1 
IFLAG OCT 200 
DM4   DEC -4
DM3   DEC -3
A     EQU 0 
B     EQU 1 
      END 
                                          