C C *********************** C * [311,77]DISKUSE.FTN * C *********************** C C------- ACCOUNT FOR DISK USAGE C BYTE PIP(31),BUIC(2) C INTEGER UIC(2) INTEGER GROUPS(30) C INTEGER*4 IBLK C DIMENSION IBUF(7) C LOGICAL*1 DONE,ERROR C EQUIVALENCE (BUIC(1),IBUF(1)) EQUIVALENCE (IBLK,IBUF(3)) EQUIVALENCE (IFL,IBUF(5)) C DATA IBUF(6) /"1000/ C DATA TBLK /0.0/ , TFIL /0.0/ C C------- STORE DATE CALL DTSTOR (IBUF(2)) C C------- DISABLE NO SUCH FILE MESSAGE CALL ERRSET(29,.TRUE.,.FALSE.,.TRUE.,.FALSE.) C C------- GET NUMBER OF GROUPS CALL GETGR (NREC,GROUPS) C C------- SPAWN PIP TO DO DIRECTORY SUMS DO 5 I=1,NREC ENCODE (30,1,PIP) GROUPS(I) 1 FORMAT('PIP [10,10]DISK.CNT=[',O3,',*]/TB') C CALL SPAWN (RAD50('...PIP'),,7,,PIP,30) C C------- WAIT FOR SPAWN CALL STOPFR (7) 5 CONTINUE C C------- OPEN THE REPORT FILE OPEN (UNIT=4,NAME='DISKUSE.LST',TYPE='NEW',DISPOSE='PRINT') C C------- OPEN DIRECTORY/SUM FILE 2 OPEN (UNIT=1,NAME='[10,10]DISK.CNT',TYPE='OLD',ERR=100, 1 DISPOSE='DELETE') C DONE = .FALSE. C C------- GET DISK USAGE 10 CALL GETDU (UIC,BLOCKS,FILES,DONE) IF (DONE) GO TO 30 C WRITE (4,20) UIC,BLOCKS,FILES 20 FORMAT(' [',O3,',',O3,'] BLOCKS =',F8.1,', FILES =',F8.1) C C------- FORM ACCOUNTING RECORD BUIC(2) = UIC(1) BUIC(1) = UIC(2) IBLK = BLOCKS IFL = FILES C C------- OPEN ACCOUNTINF FILE CALL OPNACT (3,IERR) IF (IERR .NE. 0) GO TO 25 C C------- COMPUTE THE CHECK SUM IBUF(7) = 0 DO 21 I=1,6 IBUF(7) = IBUF(7) + IBUF(I) 21 CONTINUE C C------- WRITE THE RECORD WRITE(3,22) IBUF 22 FORMAT(7A2) C C------- CLOSE THE FILE CLOSE (UNIT=3) C C------- ACCUMULATE BLOCKS AND FILES 25 TBLK = TBLK + BLOCKS TFIL = TFIL + FILES C GO TO 10 C 30 CLOSE (UNIT=1) C GO TO 2 C 100 WRITE(4,110) TBLK,TFIL 110 FORMAT(' TOTAL BLOCKS =',F8.1,', FILES =',F8.1) C CALL EXIT C END SUBROUTINE GETDU (UIC,BLOCKS,FILES,DONE) C C------- READ DIRECTORY/SUM FILE AND EXTRACT: C UIC -- UIC C BLOCKS -- BLOCKS ALLOCATTED FOR UIC C FILES -- NUMBER OF FILES IN DIRECTORY C C DONE SET WHEN FILE FINISHED C DIMENSION UIC(2) C INTEGER UIC C LOGICAL*1 DONE C BYTE LINE(150),NUMB(15) C C------- READ FIRST LINE 5 READ (1,10,END=25) NC,(LINE(I),I=1,NC) 10 FORMAT (Q,150A1) C C------- GET UIC C C------- SKIP TO '[' DO 20 I=1,NC IF (LINE(I) .EQ. '[') GO TO 30 20 CONTINUE C C------- IF NOT FOUND THEN GRAND TOTAL LINE - SET DONE 25 DONE = .TRUE. RETURN C C------- STORE FIRST PART OF UIC FOR DECODE 30 N = 0 DO 40 K=I+1,NC IF (LINE(K) .EQ. ',') GO TO 50 N = N + 1 NUMB(N) = LINE(K) 40 CONTINUE C C------- ERROR IS = 40 44 WRITE(5,45)IS 45 FORMAT(' GETDU LOGIC ERROR STMT =',I4) CALL EXIT C C------- DECODE FIRST PART OF UIC 50 DECODE (N,60,NUMB) UIC(1) 60 FORMAT(O15) C C------- CHECK FOR 0 IF (UIC(1) .NE. 0) GO TO 65 C C------- READ SECOND LINE 62 READ (1,10) NC,(LINE(I),I=1,NC) GO TO 5 C C------- EXTRACT SECOND PART OF UIC 65 N = 0 DO 70 I=K+1,NC IF (LINE(I) .EQ. ']') GO TO 80 N = N + 1 NUMB(N) = LINE(I) 70 CONTINUE C C------- ERROR IS = 70 GO TO 44 C C------- DECODE SECOND PART OF UIC 80 DECODE (N,85,NUMB) UIC(2) 85 FORMAT(O3) C C------- CHECK FOR 0 IF (UIC(2) .EQ. 0) GO TO 62 C C------- READ SECOND LINE OF DIRECTORY/SUM READ (1,10) NC,(LINE(I),I=1,NC) C C------- SEARCH FOR BLOCKS ALLOCATTED DO 90 I=1,NC IF (LINE(I) .EQ. '/') GO TO 100 90 CONTINUE C C------- ERROR IS = 90 GO TO 44 C C------- EXTRACT BLOCKS FOR DECODE 100 N = 0 DO 110 K=I+1,NC IF (LINE(K) .EQ. ' ') GO TO 120 N = N + 1 NUMB(N) = LINE(K) 110 CONTINUE C C------- ERROR IS = 110 GO TO 44 C C------- DECODE BLOCKS ALLOCATTED 120 DECODE (N,130,NUMB) BLOCKS 130 FORMAT (F15.0) C C------- EXTRACT FILES FOR DECODE DO 140 I=K,NC IF (LINE(I) .EQ. 'N') GO TO 150 140 CONTINUE C C------- ERROR IS = 140 GO TO 44 C C------ EXTRACT FILES 150 N = 0 DO 160 K=I+2,NC IF (LINE(K) .EQ. ' ') GO TO 170 N = N + 1 NUMB(N) = LINE(K) 160 CONTINUE C C------- ERROR IS = 160 GO TO 44 C C------- DECODE FILES 170 DECODE (N,130,NUMB) FILES C RETURN C END SUBROUTINE GETGR (NREC,GROUPS) C C------- GET RECOGNIZABLE GROUPS C DIMENSION GROUPS(30) C INTEGER GROUPS C C------- OPEN GROUPS FILE OPEN (UNIT=1,NAME='[70,24]GROUPS.DAT',TYPE='OLD',DISPOSE='SAVE') C C------- READ RECORD READ (1,10) NREC,(GROUPS(I),I=1,NREC) 10 FORMAT(I10,31O10) C CLOSE (UNIT=1) C RETURN C END SUBROUTINE OPNACT (LUN,IERR) C C------- OPEN THE ACCOUNTING FILE C C------- ARGUMENTS: C C LUN - AVAILABLE LUN C IERR - ERROR INDICATOR: C 0=ALL OK C 1=OPEN ERROR C IERR = 0 C C------- OPEN THE ACCOUNTING FILE 100 OPEN (UNIT=LUN,NAME='LB0:[1,100]PDSACT.ACT',TYPE='UNKNOWN', 1 CARRIAGECONTROL='LIST',ACCESS='APPEND',ERR=200) C C------- SUCCESSFUL OPEN RETURN C C------- FILE OPEN ERROR 200 CALL ERRSNS (IF4P,IFCS) C C------- TRY AGAIN TESTS C C------- WRITE ACCESSED IF (IFCS .EQ. -29) GO TO 250 C C------- LOCKED FROM READ/WRITE IF (IFCS .EQ. -27) GO TO 250 C C------- ALREADY OPEN IF (IFCS .EQ. -53) GO TO 250 C C------- ERROR TO TERMINAL AND OPERATOR 220 TYPE 230,IFCS 230 FORMAT(' ACCOUNTING FILE FAILURE CODE =',I4) CALL ASSIGN (LUN,'TT0:') WRITE(LUN,230) IFCS CLOSE (UNIT=LUN) C C------- SET ERROR 240 IERR = 1 RETURN C C------- WAIT A SECOND AND TRY AGAIN 250 CALL WAIT (1000,1,M) GO TO 100 C END