FTN4,L
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS     *
C  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
C  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
C  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
C  ***************************************************************
C 
C     SOURCE PART NUMBER :  92067-18370 
C 
C     RELOCATABLE PART NUMBER : 92067-16362 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
C 
C 
C     ACLIA SUBROUTINE TO LIST
C     SESSION WIDE INFORMATION
C 
      SUBROUTINE ACLIA(JTYPE) ,92067-16362 REV.2001 791020
      LOGICAL IFOND,IFLG
      DIMENSION ITBUF(17),IBUF(128),LUX(2)
      COMMON /ACOM1/NDCB(272),NBUF(256),MBUF(256) 
      COMMON /ACOM6 /LOC(6),IRN 
      COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) 
      COMMON /ACOM4/ ICMND(40)
      COMMON /ACOM7/ IPBUF(11),ISTRC,ISCS 
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR,IDSES,MYCAP,MYDIR,MYGID 
      EQUIVALENCE (IPBUF,IPB) 
C 
      DATA I0,I1,I3,I4,I5,I6/2HI0,2HI1,2HI3,2HI4,2HI5,2HI6 /
      DATA ICR / 2HCR / 
      DATA  LPPG / 54 / 
      DATA LUX / 0,0 /
C 
C      SAVE LIST(4) FOR POSIBLE RESTORE 
C 
      LISV=LIST(4)
      LIST(4)=0 
C 
C     IF FROM SHUT DOWN THEN BYPASS PARSING 
C 
      IPB=1 
      IF(JTYPE.EQ.2) GO TO 50 
C 
C     PARSE LIST DEVICE 
C 
      CALL NAMR(LIST,ICMND,80,ISTRC)
      LIST(4)=IAND(LIST(4),3) 
      CALL ACOPL(IERR,3,24) 
      IF(IERR.NE.0) GO TO 1100
C 
C     COMPUTE GO TO INDEX FROM NEXT PARM
C 
      CALL NAMR(IPBUF,ICMND,80,ISTRC) 
      IF(IPB.EQ.2HAC) IPB=0 
      IF(IPB.EQ.2HPO) IPB=1 
      IF(IPB.EQ.2HCO) IPB=2 
      IF(IPB.EQ.2HAL) IPB=3 
      IF(IPB.LT.0.OR.IPB.GT.3) IPB=3
      IPB=IPB+1 
C 
C     GET FILE HEADER 
C 
   50 CALL READF(NDCB,IERR,NBUF,128,LEN,1)
      IF(IERR.LT.0) GO TO 1100
      CALL ACSTR
      IF(JTYPE.EQ.2) GO TO 80 
      CALL ACFMT (IERR,-14,26,26HACCOUNT SYSTEM INFORMATION  )
      CALL ACFMT (IERR) 
      CALL ACFMT (IERR,14,14HSESSION LIMIT: ,-16,I3,-NBUF(28),
     1 9,10H SESSIONS  )
C 
C     IF NOT SYSTEM MANAGER DON'T GIVE SC 
C 
      ISC=NBUF(10)
      IF(IDSES.NE.7777B) ISC=0
      IX=-10
      IF(NBUF(7).EQ.2H   ) IX=-80 
      CALL ACFMT (IERR,20,20HSYSTEM MESSAGE FILE: ,IX,0,6,
     1 NBUF(7),1,2H: ,ICR,ISC,1,2H: ,ICR,NBUF(11))
      CALL ACFMT (IERR,21,22HCRN OF MESSAGE FILES   ,-10,ICR,NBUF(26))
   80 LINES=7 
      GO TO (90,201,601,90),IPB 
   90 CALL ACFMT (IERR) 
      CALL ACFMT (IERR,16,16HACTIVE SESSIONS: ) 
      CALL ACFMT (IERR) 
      CALL ACFMT (IERR,15,16HSESSION    USER  ,-15,11,12HLOG-ON TIME  ) 
      CALL ACFMT (IERR,15,16H-------    ----  ,-15,11,12H-----------  ) 
      LINES=LINES+5 
C 
C     READ ACTIVE SESSION BLOCKS
C 
      I=128 
      LC=LOC(1)-1 
  100 I=I+4 
      IF(I.LT.128) GO TO 150
      LC=LC+1 
      IF(LC.GE.LOC(2)) GO TO 200
      I=1 
      CALL READF(NDCB,IERR,MBUF,128,LEN,LC) 
  150 LU=MBUF(I)
      IF(LU.EQ.0) GO TO 100 
C 
      CALL ACLTM(MBUF(I+1),ITBUF) 
      ID=MBUF(I+3)*16+1 
      CALL READF(NDCB,IERR,NBUF,256,LEN,LOC(5)+ID/128)
      ID=MOD(ID,128)
      IBL=NBUF(ID)
      IBL=MBYTE(IBL)+LBYTE(IBL)-22
      CALL ACFMT (IERR,I4,LU,-5,0,10,NBUF(ID+1),1,2H. ,0, 
     1 10,NBUF(ID+6),IBL,14,ITBUF,4,ITBUF(13),2,2H  ,2,ITBUF(11)) 
      LINES=LINES+1 
      GO TO 100 
C 
C     PRINT DISC POOL 
C 
  200 GO TO (1000,201,601,201),IPB
  201 CALL ACFMT (IERR) 
      CALL ACFMT (IERR,10,10HDISC POOL: ) 
      CALL ACFMT (IERR,32,32H  DISC LU   SIZE      MOUNTED TO  )
      CALL ACFMT (IERR,32,32H  -------   ----      ----------  )
      LINES=LINES+3 
      CALL ACFST(MBUF)
      JJ=0
C 
C     READ DISC POOL
C 
  300 CALL READF(NDCB,IERR,NBUF,256,LEN,LOC(3)) 
      JJ=JJ+1 
      IFOND=.FALSE. 
      LU=NBUF(JJ) 
      IF(LU.EQ.0) GO TO 600 
C 
C     GET SIZE OF DISC
C 
      ITRKS=0 
      ISCS=0
      LUX(1)=IOR(LU,100000B)
      CALL XLUEX(100015B,LUX,IDVRT) 
      GO TO 310 
  305 IDVRT=IAND(IDVRT,37400B)/256
      IF(IDVRT.GE.30B.AND.IDVRT.LE.33B) GO TO 325 
      ITRKS=IDVRT/8 
      ISCS=MOD(IDVRT,8) 
C 
C     WRITE DRIVER TYPE 
C 
      CALL ACFMT(IERR,I6,LU,-4,2,2HDV,I1,ITRKS,I1,ISCS) 
      GO TO 300 
C 
C     WRITE ABORTING ERROR AND CONTINUE 
C 
  310 CALL ABREG(IA,IB) 
      CALL ACFMT(IERR,I6,LU,-4,8,8HERROR = ,2,IA,2,IB)
      GO TO 300 
C 
  325 CALL XLUEX(1,LUX,ISCS,1,-1,0) 
      CALL ABREG(IDVRT,ITRKS) 
C 
C     SEARCH FOR MOUNTED DISC 
C 
      DO 350 J=1,256,4
      IF(MBUF(J).EQ.0) GO TO 575
      LU2=LBYTE(MBUF(J))
      IDCDE=MBUF(J+3) 
      IF(LU.NE.LU2) GO TO 350 
      IF(IDCDE.EQ.0) GO TO 550
      GO TO 370 
  350 CONTINUE
      GO TO 575 
C 
C     SEARCH FOR ID IN  ACTIVE SESSIONS 
C 
  370 LASB=LOC(1) 
  380 I=-3
      IF(LASB.GE.LOC(2)) GO TO 450
      CALL READF(NDCB,IERR,IBUF,128,LEN,LASB) 
      LASB=LASB+1 
  400 I=I+4 
      IF(I.GT.125) GO TO 380
      IF(IBUF(I).EQ.0) GO TO 400
      ID=IBUF(I+3)*16+1 
      CALL READF(NDCB,IERR,NBUF,256,LEN,LOC(5)+ID/128)
      ID=MOD(ID,128)
      IF(NBUF(ID+11).NE.IDCDE) GO TO 425
      LINES=LINES+1 
      IF(IFOND) GO TO 410 
      CALL ACFMT (IERR,I6,LU,-2,I5,ITRKS,1,2H* ,I3,ISCS,-4, 
     1 0,10,NBUF(ID+1),1,2H. ,0,10,NBUF(ID+6))
      IFOND=.TRUE.
      GO TO 400 
  410 CALL ACFMT (IERR,-23,0,10,NBUF(ID+1),1,2H. ,
     1 0,10,NBUF(ID+6)) 
      IFOND=.TRUE.
      GO TO 400 
C 
C     GROUP CARTRIDGE 
C 
  425 IF(NBUF(ID+12).NE.IDCDE) GO TO 400
      CALL ACFMT (IERR,I6,LU,-2,I5,ITRKS,1,2H* ,I3,ISCS,-4, 
     1 0,10,NBUF(ID+6)) 
      IFOND=.TRUE.
      LINES=LINES+1 
C 
C     NOT MOUNTED TO ANY ACTIVE SESSION 
C 
  450 IF(IFOND) GO TO 300 
      IREC=0
  460 ID=1
      CALL READF(NDCB,IERR,NBUF,256,LEN,LOC(5)+IREC)
  475 IF(NBUF(ID).EQ.0) GO TO 550 
      IF(NBUF(ID).LT.0) GO TO 490 
      IF(NBUF(ID+11).NE.IDCDE) GO TO 480
      CALL ACFMT (IERR,I6,LU,-2,I5,ITRKS,1,2H* ,I3,ISCS,-4, 
     1 0,10,NBUF(ID+1),1,2H. ,0,10,NBUF(ID+6),14,14H (NOT ACTIVE)  )
      LINES=LINES+1 
      GO TO 300 
  480 IF(NBUF(ID+12).NE.IDCDE) GO TO 490
      CALL ACFMT (IERR,I6,LU,-2,I5,ITRKS,1,2H* ,I3,ISCS,-4, 
     1 0,10,NBUF(ID+6),14,14H (NOT ACTIVE)  ) 
      LINES=LINES+1 
      GO TO 300 
  490 ID=ID+16
      IF(ID.LT.128) GO TO 475 
      IREC=IREC+1 
      GO TO 460 
C 
C     NOT MOUNTED TO ANY SESSION
C 
  550 CALL ACFMT (IERR,I6,LU,-2,I5,ITRKS,1,2H* ,I3,ISCS,-4, 
     1 1,2H- ,I0,IDCDE) 
      LINES=LINES+1 
      GO TO 300 
C 
C     DISC NOT MOUNTED
C 
  575 CALL ACFMT (IERR,I6,LU,-2,I5,ITRKS,1,2H* ,I3,ISCS,-4, 
     1 16,16HDISC NOT MOUNTED   ) 
      LINES=LINES+1 
      GO TO 300 
C 
C     PRINT CONFIGURATION TABLE 
C 
  600 GO TO (1000,1000,601,601),IPB 
  601 IFLG=.FALSE.
      IDX=0 
      LINES=LINES+4 
  700 LNGTH=ACNFG(IERR,IDX)-1 
      IF(LNGTH.LT.0) GO TO 1000 
      I1=2
      IF(LINES+LNGTH.LE.LPPG) GO TO 825 
  750 LINES=5 
      CALL ACFMT (IERR) 
      CALL ACSTR
      CALL ACWRL(2H1 ,1)
      CALL ACSTR
      GO TO 850 
  825 IF(IFLG) GO TO 875
  850 CALL ACFMT (IERR) 
      CALL ACFMT (IERR,20,20HCONFIGURATION TABLE:  )
      CALL ACFMT (IERR,33,34H  STATION  SESSION LU / SYSTEM LU  ) 
      CALL ACFMT (IERR,33,34H  -------  ---------   ----------  ) 
C 
  875 IFLG=.TRUE. 
      IF(I1.GT.2) GO TO 880 
      LINES=LINES+1 
      ISSN=ACNFG(IERR,IDX)
      IF(LNGTH.EQ.0) GO TO 900
      ISST=ACNFG(IERR,IDX)
      ISTN=IAND(255,MBYTE(ISSN)+1)
      ISYS=IAND(255,MBYTE(ISST)+1)
      ISES=IAND(255,LBYTE(ISST)+1)
      CALL ACFMT (IERR,I6,ISTN,-3,I6,ISES,-7,I6,ISYS) 
  880 IF(LNGTH.LT.I1) GO TO 700 
      ISTRT=I1
      DO 800 I1=ISTRT,LNGTH 
      IF(LINES.GT.LPPG) GO TO 750 
      LINES=LINES+1 
      ISST=ACNFG(IERR,IDX)
      ISYS=IAND(255,MBYTE(ISST)+1)
      ISES=IAND(255,LBYTE(ISST)+1)
  800 CALL ACFMT (IERR,-9,I6,ISES,-7,I6,ISYS) 
      GO TO 700 
C 
C     SESSION LU ONLY 
C 
  900 CALL ACFMT (IERR,I6,MBYTE(ISSN)+1)
      GO TO 700 
 1000 CALL ACFMT (IERR) 
      CALL ACSTR
 1100 IF(IERR.NE.0) CALL ACERR(IERR)
      IF(JTYPE.EQ.2) GO TO 1200 
      CALL ACCLL
      RETURN
 1200 LIST(4)=LISV
      RETURN
      END 
                                      