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