FTN4,L
C 
C   VERSION  12 - 20 - 77   LAW (FOR NEW FTN4)
C 
      PROGRAM CLASS(3,99),REV 780913 FOR RTE-III/IV 
C 
      DIMENSION LU(5),IREG(2),IBUF(20),IPBUF(33)
      DIMENSION IPROG(3,3),JPROG(9),IGTPRG(3) 
      INTEGER CLASAD,OUTBF(40)
C 
      EQUIVALENCE (IB,IREG(2)),(X,IREG),(IPROG,JPROG) 
      EQUIVALENCE (N1,IPBUF(6)),(N2,IPBUF(10)),(LLU,IPBUF(14))
      EQUIVALENCE (ICMND,IPBUF(2)),(IFLAG,LU(2))
C 
      DATA JPROG/9*2H  /,NIDS/0/,IPBUF/33*0/
      DATA IGTPRG/3*2H  / 
      DATA CLASAD/0/
C 
C 
C   PRELIMINARIES...
C      GET COMMUNICATION LU 
C      GET CLASS TABLE PARAMETERS & CHECK 
C      GO TO 'TASK' LOOP
C 
      CALL RMPAR(LU)
      IF(LU.EQ.0)LU=1 
      ILU=LU+400B 
      N1=LU(3)
      N2=LU(4)
C 
C 
      KEYBLK=IXGET(1657B) 
6     IF(IXGET(KEYBLK).EQ.0)GO TO 7 
      NIDS=NIDS+1 
      KEYBLK=KEYBLK+1 
      GO TO 6 
C 
7     CALL GETCL(ITADRS,INUMB)
      IF(IFLAG.NE.0)GO TO 20
C 
98    CONTINUE
      WRITE(LU,101)ITADRS,INUMB 
101   FORMAT(/"/CLASS: CLASS TABLE IS AT "K6" WITH"I3" ENTRIES!") 
C 
      WRITE(LU,102) 
102   FORMAT(/"/CLASS: FOLLOWING COMMANDS ARE ACCEPTED:"/,
     &   "  DISPLAY,N1,N2,LU  -  DISPLAY STATUS OF CLASS TABLE FOR",/,
     &   "                       CLASS NUMBERS N1 THROUGH N2",/,
     &   "  LIST,LU           -  LIST CONTENTS OF CLASS TABLE ON LU",/, 
     &   "  CLEAR,N           -  CLEAR OUT PENDING CLASS BUFFERS",/,
     &   "                       ON CLASS NUMBER 'N'",/,
     &   "  ??                -  HELP"/ 
     &   "  END               -  END")
C 
10    WRITE(LU,110) 
110   FORMAT(/"/CLASS: TASK: _")
      X=EXEC(1,ILU,IBUF,20) 
      CALL PARSE(IBUF,IB*2,IPBUF) 
      IF(ICMND.EQ.2HEN)GO TO 90 
      IF(ICMND.EQ.2HEX)GO TO 90 
      IF(ICMND.EQ.2H/E)GO TO 90 
      IF(ICMND.EQ.2H??)GO TO 98 
      IF(ICMND.EQ.2HDI)GO TO 20 
      IF(ICMND.EQ.2HLI)GO TO 40 
      IF(ICMND.EQ.2HCL)GO TO 30 
12    WRITE(LU,111) 
111   FORMAT("/CLASS: INPUT ERROR!")
      GO TO 10
C 
C 
C   PROCESS DISPLAY REQUEST    REQUEST FORMAT:  DISPLAY,N1,N2,LU
C       WHERE   N1, N2  ARE START, END CLASS NUMBERS
C               LU IS LIST LU 
C 
20    IF(LLU.EQ.0)LLU=LU
      IF((N2.EQ.0).OR.(N2.LT.N1))N2=N1
      IF(N1.GT.0)GO TO 201
      N2=INUMB
      N1=1
201   IF((N1.GT.0).AND.(N2.LE.INUMB))GO TO 21 
      WRITE(LU,120)INUMB
120   FORMAT("/CLASS: ONLY CLASS NUMBERS 'TWEEN 0 AND"I3" PLEASE!") 
      GO TO 10
C 
21    CALL CODE 
      WRITE(OUTBF,121)
121   FORMAT(/,29X,"GET PROG OR BUFFER PRAMS")
      CALL EXEC(2,LLU,OUTBF,27) 
      CALL CODE 
      WRITE(OUTBF,1211) 
1211  FORMAT(" CLASS  POSSIBLE OWNERS SECU  #RQ  SIZE  OPT1   OPT2"/) 
      CALL EXEC(2,LLU,OUTBF,27) 
C 
      DO 29 I=N2,N1,-1
       ISECU=0
       NPRQ=0 
       IBLOK=0
       IOPT1=0
       IOPT2=0
C 
C   IF CLASS AVAILABLE SAY SO & GO TO NEXT ONE.  IF IN AUTO MODE
C   DON'T PRINT 'AVAILABLE' 
C 
       CLASAD=ITADRS+I
       IF(IXGET(CLASAD).NE.0)GO TO 24 
      CALL CODE 
       WRITE(OUTBF,122)I
122    FORMAT(I5,2X," ** AVAILABLE **") 
      CALL EXEC(2,LLU,OUTBF,12) 
       GO TO 29 
C 
C  GET NON-ZERO CLASS WORD FOR ANALYSIS (ICLAS) 
C 
24     IF(IXGET(CLASAD).LT.0)GO TO 25 
       CLASAD=IXGET(CLASAD) 
       GO TO 24 
25     ICLAS=IXGET(CLASAD)
C 
C   GET POSSIBLE OWNERS:   SECURITY CODE = OWNER'S ID # MODULO 31 
C 
       DO 22 J=1,9
        JPROG(J)=2H 
22     CONTINUE 
       ISECU=IAND(ICLAS,17400B)/256 
       J=1
26     IDADRS=IXGET(IXGET(1657B)+ISECU-1) 
       IF(IXGET(IDADRS+12).EQ.0)GO TO 261 
       IF(IAND(IXGET(IDADRS+14),20B).NE.0)GO TO 261 
       IPROG(1,J)=IXGET(IDADRS+12)
       IPROG(2,J)=IXGET(IDADRS+13)
       IPROG(3,J)=IOR(IAND(IXGET(IDADRS+14),177400B),40B) 
261    J=J+1
       ISECU=ISECU+32 
       IF((ISECU.LE.NIDS).AND.(J.LE.3))GO TO 26 
       ISECU=IAND(ISECU,37B)
C 
C   FIND OUT IF SOMEONE'S IN GET SUSPEND, IF SO, SAY SO & GO TO NEXT ONE
C 
       IF(IAND(ICLAS,40000B).EQ.0)GO TO 262 
       IWORD=ITADRS+I 
       CALL WHOGT(IWORD,IGTPRG) 
       CALL CODE
       WRITE(OUTBF,123)I,IPROG,ISECU,IGTPRG 
123    FORMAT(2X,I3,2X,9A2,K3,4X,3A2) 
       CALL EXEC(2,LLU,OUTBF,18)
       GO TO 29 
C 
C   ANALYZE QUEUED-UP CLASS BUFFERS, IF ANY 
C 
262    NPRQ=IAND(ICLAS,377B)
       ICLAS=IXGET(ITADRS+I)
       IF(ICLAS.GT.0)GO TO 27 
       CALL CODE
       WRITE(OUTBF,127)I,IPROG,ISECU,NPRQ 
       CALL EXEC(2,LLU,OUTBF,27)
       GO TO 29 
C 
27     IBLOK=IXGET(ICLAS+3) 
       IOPT1=IXGET(ICLAS+6) 
       IOPT2=IXGET(ICLAS+7) 
C 
       CALL CODE
       WRITE(OUTBF,127)I,IPROG,ISECU,NPRQ,IBLOK,IOPT1,IOPT2 
127    FORMAT(2X,I3,2X,9A2,K3,I5,I5,2(2X,K6)) 
       CALL EXEC(2,LLU,OUTBF,27)
C 
C   CHECK FOR ADDITIONAL QUEUED-UP BLOCKS 
C 
28     ICLAS=IXGET(ICLAS) 
       IF(ICLAS.LE.0)GO TO 29 
       IBLOK=IXGET(ICLAS+3) 
       IOPT1=IXGET(ICLAS+6) 
       IOPT2=IXGET(ICLAS+7) 
       ICNWD=IXGET(ICLAS+1) 
       CALL CODE
       WRITE(OUTBF,129)IBLOK,IOPT1,IOPT2
129    FORMAT(35X,I3,2(2X,K6))
       CALL EXEC(2,LLU,OUTBF,27)
       GO TO 28 
C 
29    CONTINUE
      IF(IFLAG)99,10,99 
C 
C 
C  PROCESS CLEAR REQUEST
C 
30    ICL=IPBUF(6)
      IF((ICL.LE.0).OR.(ICL.GT.INUMB))GO TO 10
C 
      ICLAS=IXGET(ITADRS+ICL) 
      IF(ICLAS.LE.0)GO TO 38
C 
31    ICLAS=IXGET(ICLAS)
      IF(ICLAS.GT.0)GO TO 31
C 
      ICLAS=IOR(IAND(ICLAS,17400B),ICL) 
34    CALL EXEC(21,ICLAS,IBUF,10,IP1,IP2,IP3) 
      IF(IXGET(ITADRS+ICL).NE.0)GO TO 34
C 
C 
38    WRITE(LU,138)ICL
138   FORMAT("/CLASS: CLASS"I3" NOW HAS NO OUTSTANDING BUFFERS!") 
      GO TO 10
C 
C   SECTION TO LIST CONTENTS OF CLASS TABLE 
C 
40    LLU=LU
      IF(N1.NE.0)LLU=N1 
C 
      CALL CODE 
      WRITE(OUTBF,140)
140   FORMAT(/,5X,"CLASS   ADDRESS    CONTENTS"/) 
      CALL EXEC(2,LLU,OUTBF,17) 
      DO 45 I=INUMB,1,-1
       CLASAD=ITADRS+I
       ICLAS=IXGET(CLASAD)
       CALL CODE
       WRITE(OUTBF,142)I,CLASAD,ICLAS 
142    FORMAT(6X,I3,5X,K6,5X,K6)
       CALL EXEC(2,LLU,OUTBF,16)
42     IF(ICLAS.LE.0)GO TO 45 
       DO 44 J=ICLAS,ICLAS+7
        IWORD=IXGET(J)
        CALL CODE 
        WRITE(OUTBF,143)IWORD 
143     FORMAT(34X,K6)
        CALL EXEC(2,LLU,OUTBF,20) 
44     CONTINUE 
      ICLAS=IXGET(ICLAS)
      GO TO 42
45    CONTINUE
      GO TO 10
C 
C 
C  END PROCESSING 
C 
90    WRITE(LU,190) 
190   FORMAT("/CLASS: DONE!"/)
      CALL EXEC(6)
C 
99    CALL EXEC(6,0,0,LU,IFLAG) 
C 
      END 
C 
C   SUBROUTINE TO IDENTIFY PROGRAM IN 'GET' FOR A GIVEN CLASS 
C 
      SUBROUTINE WHOGT(IWORD,IGTPRG)
C 
      DIMENSION IGTPRG(3) 
C 
C 
      KEYWD=IXGET(1657B)
      IGTPRG=2H** 
      IGTPRG(2)=2H**
      IGTPRG(3)=2H* 
C 
10    IDADR=IXGET(KEYWD)
      IF(IDADR.EQ.0)RETURN
      IF(IXGET(IDADR+1).EQ.IWORD)GO TO 20 
      KEYWD=KEYWD+1 
      GO TO 10
C 
20    IGTPRG=IXGET(IDADR+12)
      IGTPRG(2)=IXGET(IDADR+13) 
      IGTPRG(3)=IOR(IAND(IXGET(IDADR+14),77400B),40B) 
      RETURN
C 
90    END 
      END$
ASMB,R,L
      NAM GETCL,7 
      ENT GETCL 
      EXT $CLAS,.ENTR 
* 
A     EQU 0 
* 
* 
ADRS  BSS 1 
NMBR  BSS 1 
GETCL NOP 
      JSB .ENTR 
      DEF ADRS
* 
      LDA DCLAS     GET CLASS TABLE ADDRESS 
      SSA,RSS 
      JMP *+4 
      ELA,CLE,ERA 
      LDA A,I 
      JMP *-4 
* 
      STA ADRS,I
      LDA A,I 
      STA NMBR,I
* 
      JMP GETCL,I 
* 
DCLAS DEF $CLAS 
* 
      END 
ASMB,L
      NAM IXGP,7
      ENT IXGET,IXPUT 
      EXT $LIBR,$LIBX 
* 
* 
* 
*GET  NOP 
*     DLD IGET,I
*     SWP 
*     LDA A,I 
*     LDA A,I 
*     JMP B,I 
* 
* 
* 
IXGET NOP 
      DLD IXGET,I 
      SWP 
      LDA A,I 
      XLA A,I 
      JMP B,I 
* 
* 
* 
*PUT  NOP 
*     JSB $LIBR 
*     NOP 
*     LDA IPUT,I
*     STA IGET
*     ISZ IPUT
*     DLD IPUT,I
*     LDA A,I 
*     LDB B,I 
*     STB A,I 
*     JSB $LIBX 
*     DEF IGET
* 
* 
* 
IXPUT NOP 
      JSB $LIBR 
      NOP 
      LDA IXPUT,I 
      STA IXGET 
      ISZ IXPUT 
      DLD IXPUT,I 
      LDA A,I 
      LDB B,I 
      XSB A,I 
      JSB $LIBX 
      DEF IXGET 
* 
* 
A     EQU 0 
B     EQU 1 
      END 
                                                                                                                                                                      