FTN4,L
C 
C  PROGRAM: SCB 
C 
C  WRITTEN BY: CARL E. DAVIDSON - 110278
C              HEWLETT-PACKARD
C              DATA SYSTEMS DIVISION
C              CUPERTINO, CALIFORNIA
C 
C  MODIFIED 2-13-79, TO NOT PRINTOUT PASSWORD 
C 
C 
C 
C  DESCRIPTION
C  -----------
C 
C  THIS PROGRAM DUMPS THE SESSION CONTROL BLOCK (SCB) CONTENTS
C  FOR A SPECIFIED SESSION TO THE SESSION CONSOLE OR OTHER
C  DESIGNATED LIST DEVICE.
C 
C 
C  INSTRUCTIONS 
C  ------------ 
C 
C   SCB IS SCHEDULED AS FOLLOWS:
C 
C     RU,SCB[,LIST[,SESID]] 
C 
C       WHERE:
C 
C         LIST = DESTINATION LOGICAL UNIT FOR SCB LISTING 
C                  (DEFAULT IS SESSION CONSOLE) 
C 
C        SESID = SESSION IDENTIFIER FOR DESIRED SCB 
C                  (DEFAULT IS CURRENT SESSION) 
C 
C 
C  ENVIRONMENT AND RESOURE REQUIREMENTS 
C  ------------------------------------ 
C 
C  SCB OPERATES ONLY IN THE RTE-IV SESSION MONITOR ENVIRONMENT
C    AND REQUIRES THE FOLLOWING EXTERNAL SUBROUTINES/FUNCTIONS: 
C 
C    NAME          DESCRIPTION
C    ----          -----------
C 
C    IGETB         BYTE GET UTILITY 
C    MOVCA         BYTE MOVE UTILITY
C    BLANC         FILLS WORDS W BLANKS 
C    JASC          BINARY TO ASCII
C    GTSAD         GETS SCB ADDRESS 
C 
C 
C 
      PROGRAM SCB(3,75),24999-16247 REV.1938 790213 
      IMPLICIT INTEGER(A-Z) 
      INTEGER BUFR(200),PARM(5),FRMT(50),DCB(144),ARECD(128)
      INTEGER USER(5),GROUP(5),PASS(5)
      LOGICAL SHALF 
      CALL RMPAR(PARM)
      LIST=PARM(1)
      IF(LIST.EQ.0) LIST=LOGLU(DMY) 
      LOG=LOGLU(DMY)
C 
C  IF REQUESTED SCB IS FOR OTHER THAN THE CURRENT SESSION,
C    GET SCB ADDRESS. 
C 
      SESID=PARM(2) 
      IF(SESID.EQ.0) GO TO 1
      CALL GTSAD(SESID,ADRES) 
      IF(ADRES.EQ.-1) WRITE(LOG,100)
      IF(ADRES.EQ.-1) GO TO 8000
      IF(ADRES.EQ.0) WRITE(LOG,400)PARM(2)
400   FORMAT(/,X,"SYSTEM LU#",I3," NOT LOGGED ON")
      IF(ADRES.EQ.0) GO TO 9001 
      ADRES=ADRES+15
C 
C GET CONTENTS OF SESSION CONTROL BLOCK.
C 
1     CALL GTSCB(BUFR,200,LEN,ADRES)
      IF(LEN.EQ.-1) WRITE(LOG,100)
      IF(LEN.EQ.-1) GO TO 8000
100   FORMAT(/,X,"** SCB RUNS UNDER SESSION ONLY **") 
C 
C  OPEN ACCOUNTS FILE.
C 
      CALL OPEN(DCB,ERROR,6H+@CCT!,1,-31178)
      IF(ERROR.LT.0) WRITE(LOG,500)ERROR
500   FORMAT(/,X,"FMP ERROR ",I4," IN SCB WHILE OPENING ACCOUNTS FILE") 
      IF(ERROR.LT.0) GO TO 8000 
C 
C  COMPUTE ACCOUNT FILE RECORD NUMBER FOR RECORD CONTAINING 
C    DIRECTORY ENTRY FOR SESSION'S ACCOUNT. 
C 
      CALL READF(DCB,ERROR,ARECD,128,LTH,1) 
      IF(ERROR.LT.0) WRITE(LOG,600)ERROR
600   FORMAT(/,X,"FMP ERROR ",I4," IN SCB WHILE READING FROM ACCOUNTS"
     C" FILE")
      IF(ERROR.LT.0) GO TO 8000 
      BASE=ARECD(5) 
      ORDNL=BUFR(2)+1 
      REC=BASE+(ORDNL/8)-1
      IF(MOD(ORDNL,8).NE.0) REC=BASE+(ORDNL/8)
C 
C  GET RECORD CONTAINING DIRECTORY ENTRY FOR SESSION'S ACCOUNT. 
C 
      CALL READF(DCB,ERROR,ARECD,128,LTH,REC) 
      IF(ERROR.LT.0) WRITE(LOG,600)ERROR
      IF(ERROR.LT.0) GO TO 8000 
C 
C  COMPUTE ENTRY NUMBER (1-8) IN CURRENT RECORD CONTAINING 16-WORD
C    DIRECTORY ENTRY FOR SESSION'S ACCOUNT. 
C 
      ENTRY=MOD(ORDNL,8)
      IF(MOD(ORDNL,8).EQ.0) ENTRY=8 
C 
C  MOVE 16-WORD DIRECTORY ENTRY INTO FIRST 16 WORDS OF ARRAY "ARECD". 
C 
      CALL MOVCA(ARECD(16*ENTRY-15),1,ARECD(1),1,32)
C 
C  GET USER AND GROUP NAMES FOR SESSION'S ACCOUNT.
C 
      NUSR=IGETB(ARECD(1),1)
      CALL BLANC(USER(1),5) 
      CALL MOVCA(ARECD(2),1,USER(1),1,NUSR) 
      NGRP=IGETB(ARECD(1),2)
      CALL BLANC(GROUP(1),5)
      CALL MOVCA(ARECD(7),1,GROUP(1),1,NGRP)
C 
C  GET PASSWORD FROM SESSION'S USER ACCOUNT ENTRY.
C 
      SHALF=.FALSE. 
      IF(ARECD(15).LT.0) SHALF=.TRUE. 
      IF(ARECD(15).LT.0) ARECD(15)=IAND(ARECD(15),77777B) 
      CALL READF(DCB,ERROR,ARECD,128,LTH,ARECD(15)) 
      IF(ERROR.LT.0) WRITE(LOG,600)ERROR
      IF(ERROR.LT.0) GO TO 8000 
      IF(SHALF) CALL MOVCA(ARECD(65),1,ARECD(1),1,128)
      NPAS=IGETB(ARECD(1),2)
      CALL BLANC(PASS(1),5) 
      IF(NPAS.NE.0) CALL MOVCA(ARECD(2),1,PASS(1),1,NPAS) 
      IF(NPAS.EQ.0) NPAS=2
C 
C  DUMP USER NAME, GROUP NAME AND PASSWORD TO LIST DEVICE.
C 
      CALL EXEC(3,1100B+LIST,-1)
      WRITE(LIST,700)USER,GROUP,BUFR(1) 
700   FORMAT(3X,"USER: ",5A2,X,"GROUP: ",5A2
     C/,3X,"CURRENTLY LOGGED ONTO SYSTEM LU#",I3) 
C 
C  DUMP SCB LIST HEADER TO LIST DEVICE. 
C 
      WRITE(LIST,200) 
200   FORMAT(/,3X,"-SCB-",11X,"-----DECIMAL------",/, 
     C3X,"INDEX   OCTAL   UPPER LOWER  WORD   ASCII",9X,
     C"DESCRIPTION",/,
     C3X,"-----  -------  ----- ----- ------  -----",2X,25("-"))
C 
C  INITIALIZE FORMAT SPECIFICATIONS ARRAY.
C 
      CALL CODE 
      WRITE(FRMT,300) 
300   FORMAT("(5X,I2,3X,@6,4X,I3,3X,I3,X,I6,4X,A2,2X,") 
C 
C  DUMP SCB CONTENTS TO LIST DEVICE.
C 
      DO 150 I=1,LEN
      INDEX=I+2 
      UPPER=IGETB(BUFR(I),1)
      LOWER=IGETB(BUFR(I),2)
      ASCII=BUFR(I) 
C 
C IF UPPER OR LOWER BYTE CONTAINS NON-PRINTING ASCII CHARACTERS 
C   REPLACE WITH A BLANK BEFORE OUTPUT. 
C 
      IF((UPPER.LT.40B).OR.(UPPER.GT.176B)) 
     C  ASCII=IAND(ASCII,377B)+20000B 
      IF((LOWER.LT.40B).OR.(LOWER.GT.176B)) 
     C  ASCII=IAND(ASCII,177400B)+40B 
C 
C  MASK DESCRIPTION INFORMATION FOR CURRENT SCB ENTRY INTO
C    FORMAT SPECIFICATIONS ARRAY. 
C 
      DO 5 J=21,50
5     FRMT(J)=2H
      IF(INDEX.NE.3) GO TO 15 
      CALL MOVCA(24H5X,"SESSION IDENTIFIER"),1,FRMT(20),2,24) 
      GO TO 99
15    IF(INDEX.NE.4) GO TO 20 
      CALL MOVCA(29H3X,"ACCT. DIRECTORY ENTRY #"),1,FRMT(20),2,29)
      GO TO 99
20    IF(INDEX.NE.5) GO TO 25 
      CALL MOVCA(22H6X,"CAPABILITY LEVEL"),1,FRMT(20),2,22) 
      GO TO 99
25    IF((INDEX.LT.6).OR.(INDEX.GT.9)) GO TO 30 
      CALL MOVCA(20H7X,"ERROR MNEMONIC"),1,FRMT(20),2,20) 
      GO TO 99
30    IF((INDEX.LT.10).OR.(INDEX.GT.11)) GO TO 35 
      CALL MOVCA(15H9X,"CPU USAGE"),1,FRMT(20),2,15)
      GO TO 99
35    IF(INDEX.NE.12) GO TO 40
      CALL MOVCA(14H10X,"USER ID"),1,FRMT(20),2,14) 
      GO TO 99
40    IF(INDEX.NE.13) GO TO 45
      CALL MOVCA(15H10X,"GROUP ID"),1,FRMT(20),2,15)
      GO TO 99
45    IF(INDEX.NE.14) GO TO 50
      CALL MOVCA(16H9X,"DISC LIMIT"),1,FRMT(20),2,16) 
      GO TO 99
50    IF(INDEX.NE.15) GO TO 55
      CALL MOVCA(18H8X,"- SST LENGTH"),1,FRMT(20),2,18) 
      GO TO 99
55    IF((INDEX.LT.16).OR.(INDEX.GT.-BUFR(13)+15)) GO TO 65 
      IF(BUFR(I).NE.-1) GO TO 60
      CALL MOVCA(15H9X,"SST SPARE"),1,FRMT(20),2,15)
      GO TO 99
60    CALL MOVCA(29H2X,"SYS LU#    / SES LU#   "),1,FRMT(20),2,29)
      CALL JASC(UPPER+1,FRMT,51,3)
      CALL JASC(LOWER+1,FRMT,64,3)
      GO TO 99
65    IF(INDEX.NE.-BUFR(13)+16) GO TO 70
      CALL MOVCA(21H6X,"- DISC CAPACITY"),1,FRMT(20),2,21)
      GO TO 99
70    IF(BUFR(I).NE.0) GO TO 75 
      CALL MOVCA(16H9X,"DISC SPARE"),1,FRMT(20),2,16) 
      GO TO 99
75    CALL MOVCA(30H2X,"      /         / LU#   "),1,FRMT(20),2,30) 
      IF(IAND(BUFR(I),40000B).NE.40000B) GO TO 80 
      CALL MOVCA(5HGROUP,1,FRMT(27),1,5)
      GO TO 85
80    CALL MOVCA(7HPRIVATE,1,FRMT(26),2,7)
85    IF(IAND(BUFR(I),100000B).NE.100000B) GO TO 90 
      CALL MOVCA(5HADDED,1,FRMT(22),2,5)
      GO TO 95
90    CALL MOVCA(5HEXIST,1,FRMT(22),2,5)
95    DLU=IAND(BUFR(I),377B)
      CALL JASC(DLU,FRMT,65,3)
99    WRITE(LIST,FRMT)INDEX,BUFR(I),UPPER,LOWER,BUFR(I),ASCII 
150   CONTINUE
      GO TO 9000
8000  WRITE(LOG,800)
800   FORMAT(/,X,"SCB ABORTED") 
      GO TO 9001
9000  CALL EXEC(3,1100B+LIST,-1)
      CALL EXEC(3,1100B+LIST,-1)
9001  WRITE(LOG,900)
900   FORMAT(X,"$END SCB")
      END 
      END$
ASMB
      HED ** S/P IGETB  (21MX ONLY)  F. GAULLIER  07/SEP/77 
      NAM IGETB,7 . 92903-16001 REV.1805  760907
* 
*     SOURCE 92903-18020
* 
      SPC 2 
**************************************************************
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  ALL RIGHTS    *
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
* PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
**************************************************************
      SPC 2 
      EXT .ENTR 
      ENT IGETB 
* 
*   THIS PROGRAM GETS A BYTE IN A STRING, RIGHT JUSTIFIED 
*   THE RETURNED WORD : - RIGHT : THIS BYTE 
*                       - LEFT  : ALL ZERO
* 
DM1   DEC -1
* 
.BUFF NOP          BUFFER ADDRESS 
.N    NOP          REL. ADDR. OF BYTE 
* 
IGETB NOP 
      JSB .ENTR 
      DEF .BUFF 
      LDB .BUFF 
      CLE,ELB 
      ADB DM1 
      ADB .N,I
      LBT 
      JMP IGETB,I 
* 
      END 
ASMB
      HED ** S/P MOVCA  (21MX ONLY)  F. GAULLIER   07/SEP/77
      NAM MOVCA,7 . 92903-16001 REV.1805  760907
* 
*     SOURCE 92903-18040
* 
      SPC 2 
**************************************************************
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  ALL RIGHTS    *
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
* PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
**************************************************************
      SPC 2 
      EXT .ENTR 
      ENT MOVCA 
      SUP 
* 
*   THIS PROGRAM MOVES A STRING 
*   21MX INSTRUCTIONS ARE USED
* 
DM1   DEC -1
* 
.BUF1 NOP 
.N1   NOP 
.BUF2 NOP 
.N2   NOP 
.NC   NOP 
* 
MOVCA NOP 
      JSB .ENTR 
      DEF .BUF1 
* 
      LDA .BUF1 
      CLE,ELA 
      ADA DM1 
      ADA .N1,I 
      LDB .BUF2 
      CLE,ELB 
      ADB DM1 
      ADB .N2,I 
      MBT .NC,I 
      JMP MOVCA,I 
      END 
ASMB
      HED S/P BLANC   (21MX ONLY)  PS  24/08/77 
      NAM BLANC,7 . 92903-16001 REV.1805  770824
* 
*     SOURCE 92903-18006
* 
      SPC 2 
**************************************************************
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  ALL RIGHTS    *
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
* PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
**************************************************************
      SPC 2 
      EXT .ENTR 
      ENT BLANC 
* 
* THIS ROUTINE BLANKS A BUFFER
* 
BUF   NOP 
NMOT  NOP 
* 
BLANC NOP 
      JSB .ENTR 
      DEF BUF 
      CCA 
      ADA NMOT,I
      SSA 
      JMP BLANC,I 
      STA NMOT
      LDB BL
      STB BUF,I    INIT. FIRST WORD 
      SZA,RSS 
      JMP BLANC,I 
      LDA BUF 
      STA 1 
      INB 
      MVW NMOT
      JMP BLANC,I 
* 
BL    OCT 20040 
      END 
FTN4
      SUBROUTINE JASC(IVAL,IBUF,JBYT
     .,NBYTE),. 92903-16001 REV.1805  770721
C 
C     SOURCE 92903-18031
C 
C 
C 
C     **************************************************************
C     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  ALL RIGHTS    *
C     * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
C     * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
C     * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
C     **************************************************************
C 
C 
C*********************************************************************
C*                                                                   *
C*                    THIS SUBROUTINE IS USED TO CONVERT ANY INTEGER *
C*  NUMBER (POSITIVE OR NEGATIVE) IN AN ASCII STRING .               *
C*                                                                   *
C*           PARAMETERS :                                            *
C*                                                                   *
C*                 IVAL : INTEGER VALUE                              *
C*                 IBUF : BUFFER TO STORE ASCII STRING               *
C*                 IBYT : FIRST BYTE # TO STORE STRING               *
C*                        IF IBYT IS NEGATIVE LEADING BLANKS IN      *
C*                        STRING ARE CHANGED TO ZEROS                *
C*                NBYTE : # OF BYTES OF THE STRING                   *
C*                                                                   *
C*********************************************************************
C 
C 
      DIMENSION IBUF(1),ITEMP(3)
C 
      IBYT=JBYT 
      IF(JBYT.LT.0) IBYT=-JBYT
      IF((IBYT.LT.1).OR.(NBYTE.LT.1)) RETURN
      CALL BLAN(IBUF,IBYT,NBYTE)
      JVAL=IVAL 
      IF(IVAL.LT.0) JVAL=-IVAL
      CALL CNUMD(JVAL,ITEMP)
      DO 100 I=1,6
      IF(IGET1(ITEMP,I).NE.1H ) GO TO 200 
100   CONTINUE
200   IF(IVAL.GE.0) GO TO 300 
      I=I-1 
      CALL PUTCA(ITEMP,1H-,I) 
300   IF(7-I.GT.NBYTE) RETURN 
      CALL MOVCA(ITEMP,I,IBUF,IBYT+NBYTE-7+I,7-I) 
      IF(JBYT.GT.0) RETURN
      DO 350 K=IBYT,IBYT+NBYTE-1
      IF(IGET1(IBUF,K).EQ.1H ) CALL PUTCA(IBUF,1H0,K) 
350   CONTINUE
      RETURN
      END 
      END$
ASMB,L
* 
*  UTILITY SUBROUTINE: GTSAD
* 
*  WRITTEN BY: CARL E. DAVIDSON - 112978
* 
* 
*  DESCRIPTION
*  -----------
* 
*  GTSAD IS A FORTRAN CALLABLE SUBROUTINE WHICH RETURNS THE SCB 
*  STARTING ADDRESS ASSOCIATED WITH THE SESSION IDENTIFIER PASSED 
*  BY THE CALLER. 
* 
* 
*  CALLING SEQUENCE 
*  ---------------- 
* 
*  CALL GTSAD(SESID,ADDR) 
* 
*    WHERE: 
* 
*      SESID = SESSION IDENTIFIER 
* 
*       ADDR = SCB ADDRESS RETURNED HERE
*                (SET TO: 0 IF SESID NOT LOGGED ON, 
*                        -1 IF NOT IN SESSION)
* 
* 
      NAM GTSAD,7   GET SCB ADDRESS UTILITY - 112978
      ENT GTSAD 
      EXT $SHED,.ENTR,$SMVE 
PARAM BSS 2 
GTSAD NOP 
      JSB .ENTR     GET CALLER'S PARAMETER ADDRESSES
      DEF PARAM 
      LDA PARAM,I   GET SESSION IDENTIFIER
      STA SESID 
      LDA PARAM+1   GET CALLER'S ADDRESS ADDRESS
      STA SCBAD 
      CLA           CLEAR CALLER'S ADDRESS PARAMETER
      STA SCBAD,I 
      LDA $SHED     GET SCB LIST HEAD ADDRESS 
      STA NXADR 
      SZA           ARE WE IN SESSION?
      JMP NXSCB     YES, ALL'S WELL 
      CCA           NO, SET CALLER'S ADDRESS PARAMETER
      STA SCBAD,I     TO -1 
      JMP GTSAD,I       AND EXIT. 
NXSCB JSB $SMVE     GET FIRST FOUR WORDS
      DEF RETRN       OF NEXT SCB.
      DEF READ      (READ)
      DEF NXADR     (NEXT SCB ADDRESS)
      DEF OFFST     (BEGINNING WITH FIRST WORD) 
      DEF SCB       (INTO BUFFER "SCB") 
      DEF NWRDS     (4 WORDS) 
RETRN LDA SCB+3     GET SESSION ID FOR THIS SCB 
      CPA SESID     IS THIS THE ONE WE'RE LOOKING FOR?
      JMP GTCHA     YES 
      LDA SCB       NO, GET NEXT SCB'S ADDRESS
      STA NXADR 
      SZA           IS THIS THE END OF THE LIST?
      JMP NXSCB     NO, GET NEXT SCB
      JMP GTSAD,I   YES, THAT'S ALL FOLKS!
GTCHA LDA NXADR     RETURN SCB ADDRESS TO CALLER
      STA SCBAD,I     AND 
      JMP GTSAD,I       EXIT. 
* 
*  PROGRAM CONSTANTS
* 
SESID BSS 1         CALLER'S SESSION IDENTIFIER 
SCBAD BSS 1         CALLER'S ADDRESS PARM. ADDRESS
NXADR BSS 1         ADDRESS OF NEXT SCB IN LIST 
READ  DEC 1         $SMBE OP CODE (1=READ, 2=WRITE) 
OFFST DEC 0         $SMVE BUFFER OFFSET 
SCB   BSS 4         $SMVE BUFFER
NWRDS DEC 4         $SMVE NUMBER OF WORDS TO MOVE 
      END GTSAD 
                                                                                                                                                                                        