C PROGRAM TO MAKE DIRECTORIES OF TPC CONTAINER FILES UP. C ASSUMES THE CONTAINER IS OF A FLX TAPE...ALL OTHERS NEED C NOT APPLY. C GLENN C. EVERHART, 3/1981 DIMENSION IDATA(514) ! DATA AREA DIMENSION IIDAT(600) DIMENSION I2DAT(258) EQUIVALENCE(IDATA(1),I2DAT(1)) EQUIVALENCE(IIDAT(1),IDATA(1)) BYTE IIDAT BYTE IK1(2) INTEGER*2 IK2 EQUIVALENCE(IK1(1),IK2) INTEGER * 2 IDATA INTEGER * 2 I2DAT DIMENSION NAMWRK(50) BYTE NAMWRK DIMENSION IFNAM(10) BYTE IFNAM INTEGER * 4 INIT,MASBLK C LIST NAMES, EXT, UIC ONLY...TOO HARD TO DO MUCH MORE. DIMENSION NAMSPC(50) BYTE NAMSPC DO 1 I=1,10 1 IFNAM(I)=32 WRITE(5,780) 780 FORMAT(' "FILE.DOS/" EXTRACTS 1 FILE. "FILE.DOS//" EXTRACTS ALL') WRITE(5,1000) 1000 FORMAT('$ENTER TPC CONTAINER FILESPEC TO LIST>') READ(5,2000)NSSZ,NAMSPC 2000 FORMAT(Q,50A1) NAMSPC(NSSZ+1)=0 MAKFIL=0 ! NO MAKING OF OUTPUT FILES HERE YET MAKMRG=0 ! NO MERGER YET DO 500 I500=1,NSSZ IF(NAMSPC(I500).EQ.'/') GOTO 501 500 CONTINUE GOTO 502 501 CONTINUE IF(NAMSPC(I500+1).EQ.'/')MAKMRG=1 MAKFIL=1 NAMSPC(I500)=0 ! NULL TERMINATE THE FILENAME WRITE(5,503) 503 FORMAT('$ENTER SELECTED FILENAME (NO EXT,UIC)>') READ(5,504)NAMWRK 504 FORMAT(80A1) C CONVERT SELECTED MASK STUFF IF(NAMWRK(1).EQ.'*')GOTO 505 C FILENAME GIVEN...USE IWLDNM=0 CALL IRAD50(3,NAMWRK(1),IDPN1) CALL IRAD50(3,NAMWRK(4),IDPN2) CALL IRAD50(3,NAMWRK(7),IDPN3) C CONVERT FILENAME TO RAD50 FOR MATCH GOTO 506 505 IWLDNM=1 506 CONTINUE WRITE(5,507) 507 FORMAT('$ENTER EXTENSION>') READ(5,504)NAMWRK IF(NAMWRK(1).EQ.'*') GOTO 508 IWLDEX=0 CALL IRAD50(3,NAMWRK(1),IDPEX) GOTO 509 508 IWLDEX=1 509 CONTINUE WRITE(5,510) 510 FORMAT('$ENTER GROUP (400=WILD)>') READ(5,511)IDPGRP 511 FORMAT(O6) IF(IDPGRP.GT.255)IDPGRP=-1 WRITE(5,512) 512 FORMAT('$ENTER USER (400=WILD)>') READ(5,511)IDPUSR IF(IDPUSR.GT.255)IDPUSR=-1 C YES, VIRGINIA, THIS SORT OF ENTRY OF FILESPECS IS A REAL CROCK C BUT IS QUICK & DIRTY AND THE OUTPUT FILE HAS TO BE TECO'ED ANYHOW C TO GET IT TO BE USEFUL. 502 CONTINUE C NOW HAVE FILE SPEC IN NAMSPC C C FORMAT OF DOS FILE LABEL C FIL C NAM C EXT C UIC C PROTECTION CODE C DATE (JULIAN) C SPARE (USED FOR LAST 3 CHARS OF FILENAME) C OPEN(UNIT=1,NAME=NAMSPC,TYPE='OLD',ACCESS='SEQUENTIAL', 1 RECORDTYPE='VARIABLE', 1 READONLY,FORM='UNFORMATTED',RECORDSIZE=129) C WRITE(5,1700) 1700 FORMAT('$ENTER OUTPUT DATASET>') READ(5,2000)INMSZ,NAMSPC NAMSPC(INMSZ+1)=0 IF(MAKFIL.NE.0)GOTO 515 OPEN(UNIT=6,NAME=NAMSPC,TYPE='NEW',ACCESS='SEQUENTIAL', 1 CARRIAGECONTROL='LIST', 1 RECORDTYPE='VARIABLE',FORM='FORMATTED',RECORDSIZE=132) GOTO 516 515 CONTINUE OPEN(UNIT=6,NAME=NAMSPC,TYPE='NEW',ACCESS='SEQUENTIAL', 1 CARRIAGECONTROL='NONE', 1 RECORDTYPE='VARIABLE',FORM='FORMATTED',RECORDSIZE=200) 516 CONTINUE C LOOP OVER FILE GETTING RECORDS. IF A RECORD IS 14 BYTES C LONG, THEN DISPLAY AS A DIRECTORY ENTRY. C C COUNT BLOCKS TOO. MASBLK=0 ! TOTAL BLKS IN ALL FILES NBLKS=0 ! BLKS IN CURRENT FILE INIT=0 ! FILE COUNTER IDIDIT=0 ! FLAG WE ALREADY HAVE FILE OPEN. 100 CONTINUE ISZ=514 CALL GET(1,IDATA,ISZ,ISTAT) IF (ISTAT.LT.0) GOTO 250 IF (ISTAT.NE.14)GOTO 102 C SKIP IT IF PROTECTION HAS ANY HIGH BYTE...JUNK THEN. IF ((IDATA(5).AND."377).NE.IDATA(5))GOTO 102 C IF PROT IS 0 PROBABLY ALSO BOGUS IF (IDATA(5).EQ.0)GOTO 102 IDID=IDIDIT ! SAVE OLD OPEN FLAG IDIDIT=0 IF (MAKFIL.EQ.0.AND.INIT.NE.0)CALL DMPSZ(IN1,IN2,IN3,IEXT,IUIC, 1 IPRT,NBLKS,6) C USE KLUDGE TO SEE IF WE GOT A 14 BYTE RECORD. OTHER LENGTHS ARE NOT C DIRECTORIES. IN1=IDATA(1) IN2=IDATA(2) IN3=IDATA(7) IEXT=IDATA(3) IPRT=IDATA(5) IPRT=IPRT.AND.255 IUIC=IDATA(4) C SAVE DIRECTORY STUFF TILL WE FIND FILE LENGTH MASBLK=MASBLK+NBLKS NBLKS=0 ! SET FILE LENGTH TO 0 AT FIRST INIT=INIT+1 ! COUNT FILES TOO IF(MAKFIL.EQ.0)GOTO 103 IF(ISTAT.EQ.0)GOTO 103 !OMIT 0 LENGTH RECORDS C DUMP OUT FILE IF THIS IS ONE WE WANT IF (IWLDNM.NE.0)GOTO 521 ! GO IF NAME HAS TO BE OK IF (IDPN1.EQ.IN1.AND.IDPN2.EQ.IN2.AND.IDPN3.EQ.IN3) GOTO 521 523 CONTINUE IF(MAKMRG.NE.0)GOTO 782 IF (IDID.NE.0)GOTO 520 ! EXIT IF DONE OUTPUT C IMPLEMENT MERGER OF ALL FILES INTO OUTPUT FILESPEC IF HE TYPED C FILE.DOS// ON COMMAND LINE IN FIRST PLACE. 782 IDID=IDIDIT GO TO 103 521 IF(IWLDEX.NE.0) GOTO 522 IF(IDPEX.EQ.IEXT)GOTO 522 GOTO 523 522 CONTINUE IK2=IUIC IGX=IK1(2) IGX=IGX.AND.255 ! MASK SIGN EXTENSION IUI=IUIC.AND.255 IF(IDPGRP.LT.0)GOTO 524 IF(IDPGRP.EQ.IGX)GOTO 524 GOTO 523 524 IF(IDPUSR.LT.0)GOTO 525 IF(IDPUSR.EQ.IUI)GOTO 525 GOTO 523 525 CONTINUE C NOW WE KNOW WE JUST GOT A MATCHING LABEL RECORD. FLAG THAT WE C SHOULD COPY THE DATA. IDIDIT=1 GOTO 103 ! NOW GO AND GET THE DATA. 102 CONTINUE IF (ISTAT.NE.0)NBLKS=NBLKS+1 IF(IDIDIT.EQ.0)GOTO 103 C HERE COPY DATA TO OUTPUT FILE. N2DO=ISTAT IF(N2DO.LE.0)GOTO 103 NSTLC=1 527 CONTINUE NNOW=100 IF(NNOW.GT.N2DO)NNOW=N2DO N2DO=N2DO-NNOW NNOW2=NNOW+NSTLC WRITE(6,528)(IIDAT(III),III=NSTLC,NNOW2) NSTLC=NNOW2+1 528 FORMAT(110A1) IF(N2DO.GT.0)GOTO 527 103 CONTINUE GO TO 100 250 CONTINUE IF(MAKFIL.EQ.0)CALL DMPSZ(IN1,IN2,IN3,IEXT,IUIC,IPRT,NBLKS,6) MASBLK=MASBLK+NBLKS INIT=INIT+1 IF(MAKFIL.NE.0)GOTO 520 WRITE (6,3000)INIT,MASBLK 3000 FORMAT(' TOTAL FILES= ',I6,' TOTAL BLKS= ',I6) 520 CONTINUE CALL EXIT END SUBROUTINE DMPSZ(KN1,KN2,KN3,KEXT,KUIC,KPRT,KBLKS,LUN) C DUMP A DIRECTORY ENTRY FROM ARGS, ALL INTEGERS DIMENSION NAMEXT(14) BYTE NAMEXT INTEGER * 2 II BYTE I1(2) EQUIVALENCE(I1(1),II) ! USE TO COLLECT UIC C IF ZERO LENGTH FILES (GENERALLY SPURIOUS) ARE SEEN, FORGET THEM. C (MADE A /DE OPTION SINCE THERE CAN BE REAL 0 LENGTH FILES THERE.) D IF(KBLKS.EQ.0)RETURN IN1=KN1 IN2=KN2 IN3=KN3 IEXT=KEXT IPRT=KPRT NBLKS=KBLKS IUIC=KUIC NAMEXT(14)=32 ! SPACE NAMEXT(10)=46 ! DECIMAL C CONVERT FILENAME CALL R50ASC(3,IN1,NAMEXT(1)) CALL R50ASC(3,IN2,NAMEXT(4)) CALL R50ASC(3,IN3,NAMEXT(7)) CALL R50ASC(3,IEXT,NAMEXT(11)) II=IUIC WRITE(LUN,3002)NAMEXT,I1(2),I1(1),IPRT,NBLKS 3002 FORMAT(14A1,'[',O3,',',O3,'] <',O4,'> ',I5) RETURN END