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