C+
C DSCDIR.FTN
C
C THIS PROGRAM SCANS DSC TAPES AND PRINTS A SUMMARY
C MODIFIED JUNE 85 TO USE LUN 5 FOR ALL TERMINAL I/O DUE TO BUG
C IN F77OTS THAT CRASHES PGM IF FIRST LUN USE IS A READ F.BORGER
C
C SUBROUTINES REQUIRED
C
C      PICKI4 - CONVERT 4 BYTES TO INTEGER*4
C      PRTDIR - DECODE AND PRINT FILES-11 DIRECTORY ENTRIES
C      RDTAPE - DO QIO READS OF MAGTAPE
C
C TASK BUILDING
C
C    ASG=TI:5   ; PROMPTING OUTPUT USER INPUT
C    ASG=MT:3   ; DSC TAPE INPUT
C    ASG=LP:4   ; FORMATTED OUTPUT
C
C DSCDIR.FTN  VERSION 1.2
C
C 28-AUG-81 WB-004 DONT UNLOAD AFTER REWINDING
C 11-JUN-81 WB-003 FIX ERROR WITH EMPTY AND SHORT DIRECTORIES
C 10-JUN-81 WB-002 FIX ERROR ON INTERPRETING .DIR FILES
C 10-JUN-81 WB-001 ALLOW 1600 BPI TAPE
C     
C 31-MAR-81, WILLIAM D. BURTON
C            TEXAS RESEARCH INSTITUTE OF MENTAL SCIENCES
C            1300 MOURSUND
C            HOUSTON, TEXAS  77030
C            (713) 797-1976 EXT 501
C-
      PARAMETER NRLTH=2064, HDRLTH=16
C
      LOGICAL*1 BUF(NRLTH)
      INTEGER DSCHDR(HDRLTH/2), WORDS(NRLTH/2), DATA((NRLTH-HDRLTH)/2)
C
      INTEGER*4 NREC, NTOTB, NBUSE, NFILES, NBLKAL, NBLKDR
      LOGICAL*1 ANS, BDATE(9), BTIME(8), TAPE(4), LUNNO
      LOGICAL*1 IFDIR, IFPDIR, IFFRST
      INTEGER R50DIR, LUNBUF(6), MSKDEN, NDEN, NB(2)
C
      EQUIVALENCE (BUF(1),DSCHDR(1)), (BUF(HDRLTH+1),DATA(1)),
     1  (BUF(1),WORDS(1))
C
      EQUIVALENCE (LUNBUF(2),LUNNO), (NB(1),NBLKAL)
C
      LOGICAL*1 FILNAM(9), FILEXT(3), TFILE(9)
      INTEGER FILNBR, FILSQN, FILVER
C
      PARAMETER IORWU=1376, IORWD=1280, IOSMO=1392, IOATT=768,
     1   IODET=1024, IOSTC="2500
      PARAMETER IDENS=2048
C
      DATA R50DIR/3RDIR/
C
C TERMINAL I/O FORMATS
 1000 FORMAT (1H0, 'SCAN DSC TAPE V 1.2')
 1001 FORMAT (1H$, 'INPUT TAPE SPECIFIER [DDU:]   ')
 1002 FORMAT (1H$, '   TAPE DENSITY (800 OR 1600 BPI)? [I]   ')
 1003 FORMAT (1H$, 'PRINT CONTENTS OF DIRECTORY FILES? [Y/N]   ')
C
 2000 FORMAT (Q, 4A1)
 2001 FORMAT (A1)
 2002 FORMAT (I6)
C
C PRINTER MESSAGES
 4000 FORMAT (1H1, 20X, 9A1, 2X, 8A1, 5X, 'SCAN OF DSC TAPE ', A2, I1,
     1   ':', / 1H0, 3X, 'RECORD', / 1H , 4X, 'NBR.', 3X, 'LENGTH', 4X,
     2   'CONTENTS', /)
C
 4001 FORMAT (1H , I8, '.  ', I5, '. ** FILE NUMBER OF DATA BLOCK DID',
     1   ' NOT MATCH, FILE NBR (', O5, ',', O5, ')', / 1H , 21X,
     2   'FIRST 8 WORDS', 8O8)
C
 4002 FORMAT (1H , I8, '.  ', I5, '. ** UNIDENTIFIED, FIRST 8 WORDS',
     1   8O8)
C
 4003 FORMAT (1H , I8, '.  ', I5, '.    FILE HEADER  ( ', O5, ',',
     1  O5, ')   [', O3, ',', O3, '] ', 9A1, '.', 3A1, ';', O4, 2X,
     2   2A1, '-', 3A1,  '-', 2A1, 2X, 2A1, ':', 2A1, ':', 2A1)
C
 4004 FORMAT (1H , I8, '.  ', I5, '.    DSC INITIALIZATION RECORD')
 4005 FORMAT (1H , 26X, 'OUTPUT FILE NAME : ', 12A1, / 1H , 26X,
     1   'INPUT DEVICE     : ', 12A1, / 1H , 26X,
     2   'INPUT VOLUME NAME: ', 12A1)
C
 4006 FORMAT (1H , 26X, 'TOTAL BLOCKS ON INPUT DEVICE=', I8, '.' /  1H ,
     1   26X, 'BLOCKS IN USE =', 14X, I8, '. (EXCLUDING BAD BLOCKS)',
     2   / 1H , 26X, 'FILES PRESENT =', I8, '.',  / 1H0, 32X,
     3   'FILE NUMBER, SEQ.', 5X, 'OWNER  FILE NAME.EXT; VER  CREATION',
     4   /)
C
 4007 FORMAT (1H , I8, '.  ', I5, '.    ', 80A1)
 4008 FORMAT (1H0, I8, '.  ', I5, '.    DIRECTORY CONTENTS ', 9A1, '.',
     1   3A1, 3X, 'FILE NBR, SEQ', 7X, 'NAME.EXT; VER', /)
C
 4009 FORMAT (1H )
C
C FORMATS FOR ERROR MESSAGES
 4800 FORMAT (1H , I8, '.  ', I5, '. ** RDTAPE ERROR NUMBER', I5, '.')
 4810 FORMAT (1H , I8, '.  ', I5, '. ** EOF **')
 4811 FORMAT (1H , I8, '.  ', I5, '. ** EOV **')
C
C START THE PROGRAM BY IDENTIFYING AND WAITING FOR TAPE
      WRITE (5,1000)
C
C PROMPT FOR INPUT TAPE DEVICE-UNIT
   10 CONTINUE
      WRITE (5,1001)
      READ (5,2000, END=900, ERR=10) NQT, TAPE
C
C WB-001 PROMPT FOR DENSITY
   12 CONTINUE
      WRITE (5,1002)
      READ (5,2002, END=900, ERR=12) NDEN
C
C ASSUME 800 BPI UNLESS 1600 WAS ANSWERED
      MSKDEN = 4
      IF (NDEN .EQ. 1600) MSKDEN = IDENS
C END OF WB-002
C
C ASSIGN TAPE UNIT TO FORTRAN LUN=3, ATTACH IT AND POSITION AT BEGINNING
      CALL ASSIGN (3, TAPE, 4)
C
C FIND OUT WHICH DEVICE REALLY ASSIGNED
      CALL GETLUN (3, LUNBUF)
C
      CALL WTQIO (IOATT, 3, 3, 0)
C
C TRY TO REWIND TAPE
      CALL WTQIO (IORWD, 3, 3, 0)
C
C SET DENSITY (WB-002)
      CALL WTQIO (IOSTC, 3, 3, 0,, MSKDEN)
C
C SEE IF WANT TO PRINT CONTENTS OF DIRECTORY FILES
   20 CONTINUE
      WRITE (5,1003)
      READ (5,2001, END=900, ERR=20) ANS
      IFPDIR = .FALSE.
      IFNDSP = .FALSE.
      IF (ANS .EQ. 'Y') IFPDIR = .TRUE.
C
C BEGIN, LABEL THE OUTPUT
      OPEN (UNIT=4, DISPOSE='PRINT',STATUS='NEW')
      CALL DATE(BDATE)
      CALL TIME(BTIME)
      WRITE (4,4000) BDATE, BTIME, LUNBUF(1), LUNNO
C
      NEOF = 0
      NREC = 0
C
C
C MAIN PROCESS LOOP, TRY TO READ A RECORD
  100 CONTINUE
      NREC = NREC + 1
      NBYTES = NRLTH
      CALL RDTAPE (3, NBYTES, BUF, IFERR)
C
C GO TO ERROR PROCESSING IF IFERR RETURN, UNLESS END-OF-REEL (=-62)
      IF (IFERR .LE. 0 .AND. IFERR .NE. -62) GO TO 800
C
C NO ERROR TURN OFF END-OF-FILE COUNTER
      NEOF = 0
C
C -- DECODE RECORD TYPE --
C COMPUTE LENGTH OF DATA SECTION (WORDS)
      NWDATA = (NBYTES - HDRLTH) / 2
C
C CHECK FOR ANSI LABELING RECORD (LENGTH = 80 BYTES)
      IF (NBYTES .EQ. 80) GO TO 600
C
C   NOT ANSI, CHECK FOR A SPECIAL HEADER (DSC CODE OCTAL-40)
      IF (DSCHDR(2) .EQ. "40) GO TO 500
C
C NOT A SPECIAL HEADER, IS IT A REAL HEADER (FILE HEADER)
      IF (DSCHDR(2) .EQ. "4) GO TO 400
C
C IF IT IS A TYPE 2 RECORD, SKIP IT (DON'T KNOW WHAT IT IS)
      IF (DSCHDR(2) .EQ. "2) GO TO 100
C
C IF IT IS NOT A TYPE 1 RECORD (DATA RECORD) DUMP THE BEGINNING
      IF (DSCHDR(2) .NE. 1) GO TO 250
C
C PROCESS A TYPE 1 DSC RECORD, FILE DATA
C
C CHECK FOR FILE ID NUMBER MATCH FILE NOW WORKING ON
      IF (FILNBR .NE. DSCHDR(5) .OR. FILSQN .NE. DSCHDR(6)) GO TO 200
C
C MATCHED, SEE IF WE ARE CURRENTLY PRINTING DIRECTORY
C IF FIRST TIME, PRINT HEADER
      IF (.NOT. (IFPDIR .AND. IFDIR)) GO TO 110
      IF (IFFRST) WRITE (4,4008) NREC, NBYTES, FILNAM, FILEXT
      IFFRST = .FALSE.
      IFNDSP = .TRUE.
C
C WB-003 LIMIT PRINT TO BLOCKS ACTUALLY IN USE
C   GOT INFO FROM DISK HEADER WHILE DECIDING ON .DIR
C   COMPUTE NUMBER OF DISK BLOCKS REPRESENTED BY THIS READ
      NDPRT = NWDATA/256
C
C LIMIT TO BLOCKS ACTUALLY LEFT TO DO
      NDPRT = MIN(NDPRT,NBLKDR)
C
C NOW COUNT DOWN BLOCKS LEFT TO DO
      NBLKDR = NBLKDR - NDPRT
C
C CONVERT PRINT LIMIT TO WORDS FOR SUBROUTINE
      NDPRT = NDPRT * 256
      CALL PRTDIR (4, DATA, NDPRT)
C
C CHECK IF DIRECTORY IS ALL DONE
      IF (NBLKDR .LE. 0) IFDIR = .FALSE.
  110 CONTINUE
C
C  COUNT NUMBER OF DISK BLOCKS REPRESENTED BY DATA IN THIS RECORD
      NUSED = (NBYTES - HDRLTH) / 512
C
C      NBLOKS = NBLOKS - NUSED
C      IF (NBLOKS .GT. 0) GO TO 100
C
      GO TO 100
C
C ERROR - FILE NUMBER DIDN'T MATCH
  200 CONTINUE
      WRITE (4,4001) NREC, NBYTES, FILNBR, FILSQN, DSCHDR
      GO TO 100
C
C UNIDENTIFIED DSC RECORD TYPE
  250 CONTINUE
      IF (IFNDSP) WRITE (4,4009)
      IFNDSP = .FALSE.
      WRITE (4,4002) NREC, NBYTES, DSCHDR
      GO TO 100
C
C DSC TYPE 4 RECORD, FILE HEADER
  400 CONTINUE
      IF (IFNDSP) WRITE (4,4009)
      IFNDSP = .FALSE.
C
C COMPUTE OFFSETS TO ID AREAS
      IDOFSW = BUF(HDRLTH+1) .AND. "377
      IDOFSB = IDOFSW * 2
C
C PICK UP AND STORE FILE NUMBER, FILE SEQUENCE NUMBER
      FILNBR = DATA(2)
      FILSQN = DATA(3)
C
C GROUP NUMBER, MEMBER NUMBER
      NMB = BUF(HDRLTH+9) .AND. "377
      NGP = BUF(HDRLTH+10) .AND. "377
C
C PICK UP RADIX-50 FILE NAME AND EXTENSION, DECODE INTO BYTES
      CALL R50ASC (9, BUF(HDRLTH+IDOFSB+1), FILNAM)
      CALL R50ASC (3, BUF(HDRLTH+IDOFSB+7), FILEXT)
C
C PICK UP VERSION NUMBER
      FILVER = DATA(IDOFSW+5)
C
C PICK UP REVISION NUMBER
      FILREV = DATA(IDOFSW+6)
C
C PRINT THE FILE HEADER INFORMATION
      WRITE (4,4003) NREC, NBYTES, FILNBR, FILSQN, NGP, NMB, FILNAM,
     1  FILEXT, FILVER , (BUF(HDRLTH+IDOFSB+25+I), I=1,13)
C
C CHECK TO SEE IF THIS IS A DIRECTORY TYPE FILE
      IFDIR = .FALSE.
C
C CHECK FOR 'DIR' EXTENSION
      IF (R50DIR .NE. DATA(IDOFSW+4) ) GO TO 499
C
C WB-003 PICK UP LENGTH USED, IF ONLY 1 BLOCK, DIRECTORY IS EMPTY
      NB(1) = DATA(13)
      NB(2) = DATA(12)
C
      IF (NBLKAL .LE. 1) GO TO 499
C
C SAVE NUMBER OF BLOCKS TO DO FOR PRINT
      NBLKDR = NBLKAL - 1
C
C HAD 'DIR' EXTENSION, SEE IF NAME IS 000000 OR NAME MATCHES OWNING UIC
C WB-002 FIX PROBLEM WITH NON-NUMERICS IN NAME
      ENCODE (9, 3000, TFILE, ERR=499) NGP, NMB
 3000 FORMAT (2O3, 3X)
C
C ZERO FILL FIRST 6 CHARACTERS
      DO 493 I = 1,6
         IF (TFILE(I) .EQ. "40) TFILE(I) = "60
  493 CONTINUE
C
C LOOK FOR '000000' DIRECTORY
      DO 494 I = 1,6
         IF (FILNAM(I) .NE. "60) GO TO 496
  494 CONTINUE
      DO 495 I = 7,9
         IF (FILNAM(I) .NE. "40) GO TO 496
  495 CONTINUE
C
C FALLS THROUGH ON '000000' DIR.
      GO TO 498
C
C SEE IF NAME STRINGS MATCH
  496 CONTINUE
      DO 497 I = 1,9
         IF (TFILE(I) .NE. FILNAM(I)) GO TO 499
  497 CONTINUE
C
C PASSED ALL TESTS FOR DIRECTORY, SET FLAG FOR POSSIBLE PRINT OF DATA
  498 CONTINUE
      IFDIR = .TRUE.
      IFFRST = .TRUE.
  499 CONTINUE
      GO TO 100
C
C PROCESS SPECIAL DSC HEADER RECORD TYPE 40
  500 CONTINUE
      IF (IFNDSP) WRITE (4,4009)
      IFNDSP = .FALSE.
      WRITE (4,4004) NREC, NBYTES
      WRITE (4,4005) (BUF(HDRLTH+I),I=1,12), (BUF(HDRLTH+12+I),I=1,12),
     1   (BUF(HDRLTH+36+I), I=1,12)
C
C PICK UP TOTAL NUMBER OF BLOCKS USED
      CALL PICKI4 (NTOTB, BUF(HDRLTH+55))
C
C PICK UP NUMBER OF BLOCKS IN USE
      CALL PICKI4 (NBUSE, BUF(HDRLTH+59))
C
C PICK UP NUMBER OF FILES IN USE
      CALL PICKI4 (NFILES, BUF(HDRLTH+63))
C
      WRITE (4,4006) NTOTB, NBUSE, NFILES
C
C COPY HEADER RECORD DOWN TO FRONT OF DSC RECORD AND PROCESS
C  LIKE ANY OTHER DSC FILE HEADER RECORD
      DO 510 I = 1,(NBYTES-255)/2
         DATA(I) = DATA(256+I)
  510 CONTINUE
      NBYTES = NBYTES - 512
      GO TO 400
C
C PROCESS ANSI LABEL RECORD
  600 CONTINUE
      IF (IFNDSP) WRITE (4,4009)
      IFNDSP = .FALSE.
      WRITE (4,4007) NREC, NBYTES, (BUF(I), I=1,80)
      GO TO 100
C
C PROCESS TAPE ERROR
  800 CONTINUE
C
C SEE IF ERROR IS FROM TAPEMARK (IE.EOF = -10.)
      IF (IFERR .EQ. -10) GO TO 810
C
C NOT EOF, SEE IF IT IS END-OF-VOLUME (=-11.)
      IF (IFERR .EQ. -11) GO TO 811
C
C
C UNDIAGNOSED ERROR -- PRINT ERROR MESSAGE
      WRITE (4,4800) NREC, NBYTES, IFERR
      GO TO 899
C
C PROCESS END-OF-FILE
  810 CONTINUE
      NEOF = NEOF + 1
C
C IF 2 SUCCESSIVE EOF CONDITIONS, THEN PROCESS AS END-OF-VOLUME
      IF (NEOF .EQ. 2) GO TO 811
C
      WRITE (4,4810) NREC, NBYTES
      GO TO 899
C
C PROCESS AN END-OF-VOLUME
  811 CONTINUE
      WRITE (4,4811) NREC, NBYTES
C
C REWIND THE TAPE
C WB-004 DONT UNLOAD AFTER REWIND
      CALL WTQIO (IORWD, 3, 3, 0)
C
C DETACH THE DEVICE
      CALL WTQIO (IODET, 3, 3, 0)
C
      CLOSE (UNIT=3)
      CLOSE (UNIT=4)
C
C GO BACK TO START
      GO TO 10
C
C END OF PROCESSING TAPE ERRORS
  899 CONTINUE
      GO TO 100
C
C ALL DONE, EXIT
  900 CONTINUE
      CALL EXIT
      END
      SUBROUTINE PICKI4 (N, STRING)
C+
C PICKI4.FTN
C
C THIS SUBROUTINE MOVES 4 BYTES FROM STRING INTO THE INTEGER*4
C   ARGUMENT N
C-
      BYTE STRING(1), NS(4)
      INTEGER*4 N, NN
      EQUIVALENCE (NS(1),NN)
C
      DO 100 I = 1,4
         NS(I) = STRING(I)
  100 CONTINUE
      N = NN
      RETURN
      END
      SUBROUTINE PRTDIR (LUN, BUF, NWORD)
C+
C THIS SUBROUTINE INTERPRETS AND PRINTS FILES-11 DIRECTORY FILE ENTRIES.
C
C CALLING SEQUENCE:
C                 CALL PRTDIR (LUN, BUF, NWORD)
C
C INPUT ARGUMENTS:
C
C     LUN = LOGICAL UNIT NUMBER FOR FORMATTED OUTPUT
C     BUF = INTEGER WORD BUFFER OF FILE ENTRIES (1 DISK VIRTUAL BLOCK)
C     NWORD = NUMBER OF WORDS IN BUF
C
C RETURN ARGUMENTS:  NONE
C
C ERROR CONDITIONS: NONE
C
C SUBROUTINES AND FUNCTIONS REQUIRED:
C     R50ASC - RADIX-50 TO ASCII CONVERSION SUBROUTINE
C-
      BYTE FILNAM(9), FILEXT(3)
      INTEGER BUF(1)
C
C OFFSETS TO DIRECTORY ITEMS
      PARAMETER NFNBR=0, NFSEQ=1, NFNAM=3, NFEXT=6, NFVER=7, NFLTH=8
C
C DISPLAY FORMAT

 1000 FORMAT (1H , 56X, O6, ',', O6, 2X, 9A1, '.', 3A1, ';', O6)
C
      NBASE = 1
C
C IF FILE NUMBER OR SEQUENCE NUMBER IS ZERO, FILE IS DELETED, NO ENTRY
   10 CONTINUE
      IF (BUF(NBASE+NFNBR) .EQ. 0) GO TO 20
      IF (BUF(NBASE+NFSEQ) .EQ. 0) GO TO 20
C
C ALSO CHECK VERSION NUMBER, IF ZERO, FILE IS DELETED
      IF (BUF(NBASE+NFVER) .EQ. 0) GO TO 20
C
C HAVE A LIVE ENTRY, UNRAVEL RADIX-50 FILE-NAME AND FILE-EXTENSION
      CALL R50ASC(9, BUF(NBASE+NFNAM), FILNAM)
      CALL R50ASC(3, BUF(NBASE+NFEXT), FILEXT)
C
C NOW PRINT
      WRITE (LUN, 1000, ERR=900) BUF(NBASE+NFNBR), BUF(NBASE+NFSEQ),
     1   FILNAM, FILEXT, BUF(NBASE+NFVER)
C
C DONE WITH ONE ENTRY
   20 CONTINUE
      NBASE = NBASE + NFLTH
      IF (NBASE .LT. NWORD) GO TO 10
C
C ALL DONE
  900 CONTINUE
      RETURN
      END
      SUBROUTINE RDTAPE (LUN, NBYTES, BUF, IFERR)
C+
C RDTAPE.FTN
C
C THIS SUBROUTINE DOES EXECUTIVE-LEVEL (QIO) READS FROM MAGNETIC TAPE
C  DIRECTLY INTO THE USER TASK
C
C CALLING SEQUENCE:     CALL RDTAPE (LUN, NBYTES, BUF, IFERR)
C
C INPUT ARGUMENTS:     LUN = THE LOGICAL UNIT NUMBER ASSIGNED TO THE
C                             INPUT MAGNETIC TAPE (INTEGER)
C                      NBYTES = THE NUMBER OF BYTES TO TRY TO READ.
C                               ** WARNING ** THE ACTUAL BYTE COUNT
C                           IS RETURNED TO NBYTES, DO NOT USE A
C                               CONSTANT AS AN ACTUAL ARGUMENT.
C RETURN ARGUMENTS:    BUF = ARRAY INTO WHICH BYTES ARE PUT
C                      IFERR = STATUS RETURN
C                               +1 = SUCCESS
C                               -N = OPERATION ERROR CODE (SEE FCS)
C                               -N-1000 = DIRECTIVE ERROR CODE
C
C SUBROUTINES REQUIRED:
C
C      GETADR = SYSTEM ROUTINE TO RETURN ADDRESS OF ARGUMENT
C      WTQIO  = SYSTEM LEVEL I/O CALL TO OPERATE TAPE.
C-
C
      PARAMETER IORLB=512
      BYTE BUF(1), IOSTAT
      INTEGER IOSB(2), IPRL(6)
      EQUIVALENCE (IOSB(1), IOSTAT)
C
C ASSUME SUCCESSFUL COMPLETION
      IFERR = 1
C
C SET UP PARAMETERS FOR QIO CALL, START ADDRESS
      CALL GETADR(IPRL(1), BUF(1))
C   NUMBER OF BYTES TO TRY
      IPRL(2) = NBYTES
C
C CALL THE EXECUTIVE AND WAIT FOR COMPLETION OF READ
      CALL WTQIO (IORLB, LUN, LUN, 0, IOSB, IPRL, IDS)
C
C CHECK FOR A DIRECTIVE ERROR (-N)
      IF (IDS  .LE. 0) GO TO 800
C
C NOT DIRECTIVE ERROR, CHECK FOR DRIVER ERROR, BR IF NOT
      IF (IOSTAT .GT. 0) GO TO 900
         IFERR = IOSTAT
         GO TO 900
C
  800 CONTINUE
      IFERR = IDS-1000
C
  900 CONTINUE
      NBYTES = IOSB(2)
      RETURN
      END
