C V1A Edit #33 3-Aug-84 Autor: -tf- File: CPDIR.FOR C C C P D I R . F O R : DIRECTORY OPERATIONS FOR CP/M - SD FLOPPIES C C CP/M CONVENTION : 1 BLOCK = 8 RECORDS = 1024 BYTES (~ 1 KBYTE) C 1 RECORD = 128 BYTES ( = 1 FLOPPY SECTOR,S.D.) C C H.P. STOEHREL C C *** V1 *** 1-DEC-81 C *** V2 *** 4-DEC-81 : SUBROUTINE,USES CPRD C *** V3 *** 8-DEC-81 : READS FULL DIRECT.,ENTERS & DELETES FILE C *** V4 *** 12-DEC-81 : "EXTENT"-HANDLING C *** V5 *** 17-DEC-81 : ENTER FILES C *** V6 *** 22-DEC-81 : CORRECT. C *** V7 *** 26-MAR-82 : CORRECT. C *** V8 *** 1-APR-82 : CORRECT. C *** V9 *** 2-APR-82 : CORRECT. C *** V10 *** 7-APR-82 : CORRECT. C *** V11 *** 25-JUL-84 : CORRECT. (SEMPERT, KUSTER) C SUBROUTINE CPDIR (IFUNC,NAME,IRNO,IDIR,IBLK,ISLO,IFCB) C C IFUNC : FUNCTION OF CPDIR C = 1 : LIST DIRECTORY C = 2 : FIND FILNAME AND RETURN BLK.NOS. C FILENAME IN "NAME",ALL PERTINENT BLK. NOS. C RETURNED IN "IBLK" C = 3 : FIND FREE ENTRY AND RETURN BLK.NOS. C DIRECTORY INDEX IS MAINTAINED IN "INDX" C = 4 : ENTER NEW FILE AND USED BLK.NOS. C = 5 : DELETE FILE C = 6 : ZERO DIRECTORY C C NAME : FILENAME TO BE SEARCHED FOR C (MUST BE DIMENSIONED IN CALLING PROG. TO 11) C IRNO : NO. OF BLOCKS OF FILE (= -1 IF FILE NOT FOUND) C IBLK : BLOCK NOS. OF FILE C (MUST BE DIMENSIONED IN CALLING PROG. TO 256) C ISLO : ARRAY, CONTAINS EMPTY FILE CONTROL BLOCKS (FCB-SLOTS) C (MUST BE DIMENSIONED IN CALLING PROG. TO 256) C IFCB : CURRENT FILE CONTROL BLOCK AS SETUP BY CPWOUT C C THE CP/M DIRECTORY IS CONTAINED IN BLOCKS 0 & 1 C C--------------------------------------------------------------------- C INTEGER*2 IDIR(2),NAME(2),IBLK(2),NARQ(11),IDAT(5),ISLO(2), 1IFCB(2) C BYTE FILENAME(80),IAX BYTE DUMMY C DATA IDAT/5*0/ ! INITIALIZE DATE ARRAY C IDENS=0 C IF (IFUNC.EQ.4) GOTO 10 ! THE ONLY EXCEPTION C CALL CPRD (IDIR(1),0) ! READ DIRECTORY BLK. 0 CALL CPRD (IDIR(1025),1) ! READ DIRECTORY BLK. 1 C 10 GOTO (1000,2000,3000,4000,5000,6000),IFUNC C C--------------------------------------------------------------------- C C LIST DIRECTORY C 1000 CALL CPRTN (FILENAME, 'CPMDSK DIR') CALL ASSIGN (1,FILENAME) C 1080 CALL DATE (IDAT) WRITE(1,1095)IDAT 1095 FORMAT(/' CP/M Directory',10X,'DATE : '5A2// 1' RECS BYTES EX FILENAME.TYP'/) C NZF=0 KBALL=0 C DO 1100 K=1,64 J=(K-1)*32+1 IF((IDIR(J).EQ."345).OR.(IDIR(J+15).EQ.0)) GOTO 1100 C NZF=NZF+1 KB=IDIR(J+15)/8 ! 8 RECORDS = 1KB NREC=IDIR(J+15) IF(NREC.GT.(KB*8)) KB=KB+1 KBALL=KBALL+KB IEX=IDIR(J+12)+1 C IF (IDIR(J+31).EQ.0) GOTO 1300 ! IF LAST BLK# OF FCB=0 > NO EXTENT C C>>>>>> C TYPE 1197,J C1197 FORMAT(' CPDIR INDX='I5) C>>>>>> DO 1220 N=1,11 C C>>>>>> C TYPE 1199,NAME(N),NAME(N),IDIR(J+N),IDIR(J+N) C1199 FORMAT(2(O8,2X,A1)) C>>>>>> C 1220 NAME(N)=IDIR(J+N) ! FILENAME TO BE SEARCHED FOR C K2A=K+1 DO 1200 K2=K2A,64 ! SEARCH REST OF DIRECTORY CALL CPLK (K2,IDIR,NAME,IRNUM) ! FOR THAT FILE. IF (IRNUM.EQ.-1) GOTO 1200 C C>>>>>> C TYPE 999,K2A,K2 C999 FORMAT(2I8) C>>>>>> C J2=(K2-1)*32+1 NREC=NREC+IDIR(J2+15) IEX=IDIR(J2+12)+1 KB2=IDIR(J2+15)/8 IF (IDIR(J2+15).GT.KB2*8) KB2=KB2+1 KB=KB+KB2 KBALL=KBALL+KB2 IDIR(J2)="345 ! NEVER WRITE THIS DIRECTORY BACK !! IF (IDIR(J2+31).EQ.0) GOTO 1300 ! ANY MORE EXTENTS ? 1200 CONTINUE C 1300 WRITE (1,1111) NREC,KB,IEX,(IDIR(L),L=J+1,J+11) 1111 FORMAT (X,I4,I5,'K',I3,3X,8A1,'.',3A1,20I3) C C>>>>>>> C WRITE (1,1113) (IDIR(J+M+15),M=1,16) ! WRITE USED BLK.NOS. C1113 FORMAT(16I4,/) C>>>>>>> C 1100 CONTINUE C KBR=241-KBALL ! TOTALLY AVAILABLE ARE 241KB WRITE(1,1119)NZF,KBALL,KBR 1119 FORMAT(/ 1I4,' Files using ',I4,' KBytes - ',I4,' KBytes available'/) C IF (FILENAME(1).NE.'T'.OR.FILENAME(2).NE.'T' - .OR.FILENAME(3).NE.':') GOTO 1199 TYPE 16 16 FORMAT('$press RETURN to continue ') ACCEPT 17,DUMMY 17 FORMAT(A1) 1199 CLOSE (UNIT=1) RETURN C C--------------------------------------------------------------------- C C 2000 DO 2004 J=1,256 2004 IBLK(J)=0 C IFND=0 IRNO=0 C DO 2002 ISL=1,64 CALL CPLK(ISL,IDIR,NAME,IRNUM) IF(IRNUM.LT.0) GOTO 2002 C IFND=1 ! REQUESTED FILE FOUND K=(ISL-1)*32 IRNO=IRNO+IDIR(K+16) DO 2220 N=1,16 L=K+N+16 M=IDIR(L) IBLK(M)=M C C>>>>>> C TYPE 1221,IBLK(M) C1221 FORMAT(' BLOCK# ',I5) C>>>>>> C 2220 CONTINUE C 2002 CONTINUE C IF (IFND.NE.0) RETURN C TYPE 2109,(NAME(N),N=1,11) 2109 FORMAT(/' ?CPMRT-W-CP/M File ',8A1,'.',3A1,' not found'/) IRNO=-1 RETURN C C--------------------------------------------------------------------- C C FIND FREE ENTRY (SLOT) AND RETURN BLK.NOS. C C FIRST, CHECK WHETHER FILE ALREADY EXISTS C 3000 IRNO=0 !INITIALIZE IRNO !! DO 3004 ISL=1,64 CALL CPLK (ISL,IDIR,NAME,IRNUM) ! LOOKUP FILE IF(IRNUM.EQ.-1) GOTO 3004 ! IRNUM=-1 : FILE NOT FOUND TYPE 3007,(NAME(N),N=1,11) 3007 FORMAT(/' ?CPMRT-W-CP/M File ',8A1,'.',3A1,' allready exists'/) IRNO=-1 ! FLAG EXISTENCE RETURN C 3004 CONTINUE C C NO SUCH FILE C 3008 DO 3002 J=1,256 3002 IBLK(J)=0 DO 3010 J=1,64 3010 ISLO(J)=0 C C COLLECT ALL BLOCK NOS. C 3100 NZR=0 ! USED SECTOR COUNT IFBS=0 C DO 3200 J=1,64 K=(J-1)*32+1 ! IDIR(K+15)=FCB(16)=NO.OF BLOCKS USED BY FILE C C>>>>>> D TYPE 3902,J,IDIR(K),IDIR(K+12),IDIR(K+15) D3902 FORMAT(' SLOT#',I3,' FCB(1)=',I3,' FCB(13)=',I3,' FCB(16)=',I3) C>>>>>> NRCT=IDIR(K+15) IF (NRCT.EQ.0.OR.NRCT.EQ."345) GOTO 3200 NZR=NZR+NRCT ! COUNT USED SECTORS C ISLO(J)=J ! MARK USED SLOTS C DO 3110 N=1,16 ! SLOT IN USE - COLLECT BLOCK# M=IDIR(K+N+15) IBLK(M)=M C>>>>> D TYPE 3099,J,N,M D3099 FORMAT(' CPDIR- J N M ',3I8) C>>>>> IF (M.EQ.0) IFBS=1 ! FLAG "AT LEAST 1 EMPTY BLOCK" 3110 CONTINUE 3200 CONTINUE C DO 3300 J=1,64 ! LOOK FOR EMPTY SLOTS C>>>>> D TYPE 3301,J,ISLO(J) D3301 FORMAT(2I6) C>>>>> IF (ISLO(J).EQ.0) GOTO 3400 3300 CONTINUE GOTO 3900 ! NO SLOT - ERROR C 3400 NZR=0 ! LOOK FOR EMPTY BLOCKS DO 3500 J=2,242 IF (IBLK(J).EQ.0) NZR=NZR+1 3500 CONTINUE IF (NZR.EQ.0) GOTO 3800 ! JUST ONE BLOCK LEFT ? C C>>>>>>> D TYPE 3595 D3595 FORMAT(/' USED SLOTS :'/) D TYPE 3597,(ISLO(J),J=1,64) ! TYPE ALL SLOT-# D TYPE 3593 D3593 FORMAT(/' USED BLOCKS :'/) D TYPE 3597,(IBLK(J),J=1,256) ! TYPE ALL BLOCK-# D3597 FORMAT(X,20I3) C>>>>>>> C RETURN C 3800 TYPE 3021 3021 FORMAT(/' ?CPMRT-W-No room on volume - all records used'/) IRNO=-1 3600 RETURN C 3900 TYPE 3901 3901 FORMAT(/' ?CPMRT-W-No room on volume - 64 File Entries'/) IRNO=-1 RETURN C C--------------------------------------------------------------------- C C WRITE DIRECTORY BACK C 4000 CONTINUE C>>>>>> C TYPE 4597,(IDIR(J),J=1,1024) ! TYPE ALL DIR.SLOTS C4597 FORMAT(X,16O4) C>>>>>>> CALL CPWR (IDIR(1),0) ! WRITE DIRECTORY BLK. 0 CALL CPWR (IDIR(1025),1) ! WRITE DIRECTORY BLK. 1 C RETURN C C--------------------------------------------------------------------- C C DELETE FILE C 5000 IDEXT=0 ! THINK ON FILE EXTENTS C 5020 DO 5002 ISL=1,64 CALL CPLK(ISL,IDIR,NAME,IRNUM) ! LOOKUP FILE IF(IRNUM.GE.0) GOTO 5100 5002 CONTINUE C IF (IDEXT.EQ.1) GOTO 4000 ! WRITE DIRECTORY BACK C TYPE 2109,(NAME(N),N=1,11) RETURN C 5100 KXI=32*(ISL-1) C C A DIRECTORY ENTRY IS CONSIDERED EMPTY IF FCB(16)=0 (RECORD COUNTER). C IN ADDITION, WE SET FCB(1)="345 (=e) C IDIR(KXI+1)="345 IDIR(KXI+16)=0 IDEXT=1 GOTO 5020 ! TRY ONCE AGAIN C C--------------------------------------------------------------------- C C ZERO DIRECTORY C C THE DIRECTORY IS FILLED WITH "345 (=e), SO ITS LOOKS LIKE C NEWLY FORMATTED . C 6000 TYPE 6001 6001 FORMAT(/'$?CPMRT-I-Zero CP/M Directory: are you sure (Y/N) ? ') ACCEPT 6003,IAX 6003 FORMAT(A1) IF(IAX.NE.'Y') GOTO 6600 C DO 6002 J=1,2048 6002 IDIR(J)="345 C GOTO 4000 ! WRITE DIRECTORY BACK C 6600 RETURN C END