Subroutine Getdir c c *********************************************************************** c * * c * Subroutine Getdir - Driver program to get file directories * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Byte Ctrlc,Filnam(15) Data Ctrlc/3/ 10 Continue c c Get the device name from the user c Write(7,100) 100 Format(' Enter the device to get the directory for, or return', $ ' for the current directory') Read(5,200,END=10,ERR=10) Filnam 200 Format(15A1) Do 20 I=1,15 If (Filnam(I) .EQ. Ctrlc) Call Abort If (Filnam(I) .EQ. Ctrlc) Go To 10 20 Continue c c If no device input, default to DK c Call Filfil(Filnam) c c See if it is a legal device c Call Devchk(Filnam,Iflag) If (Iflag .EQ. 1) Go To 10 c c Get and list out the device directory c Call Direct(Filnam) c Return End Subroutine Direct(Filnam) c c *********************************************************************** c * * c * Subroutine DIRECT - To get the directory of the file device * c * "DEV". The program reads the file directory region on the * c * disk, and translates it into the ASCII names. * c * * c * Input Values: * c * * c * Dev - The name of the logical disk to get the directory * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Include 'Cmain' c Integer Names(40) Byte Fname(80),Filnam(14),Newfil(9) Dimension Iblock(8) Dimension Ibuf(512),Devnam(2) c Equivalence (Names(1),Fname(1)),(Ibuf(1),X(1)), $ (Names(1),Y(1)) c Data Devnam/6R ,6R / c Line = 4 c c Convert the device name to RAD50 format c Call Irad50(3,Filnam,Devnam(1)) c c Start the loop over the directory; the first loop, to find c out how many files and blocks; the second loop, to print c out the file names c Do 60 Loop = 1,2 c c Print out the header on the second pass through c If (Loop .EQ. 2) Then Call Comprs(Filnam) Write(7,200) 27,27,27,Filnam,Ifiles,Iused,Itot-Iused,27 200 Format(1X,1A1,'[H',1A1,'[J',1A1,'[1;7mDirectory',2X, $ 'Device ',14A1,2X,I3,' Files', $ 2X,I5,' Blocks',2X,I5,' Free Blocks',1A1,'[0m'/) Call Filfil(Filnam) End If c c Get channel c Ichan = Igetc() c c See if there is a channel available c If (Ichan .EQ. -1) Go To 90 c c Open the directory area on the disk c Ierr = Lookup(Ichan,Devnam) c c See if there is an open error c If (Ierr .LT. 0) Go To 95 c c Set the first block to read as block # 6 (start of directory) c Also, initialize various pointers. c Ibkno = 6 !**** First block of the directory Ifiles = 0 !**** Number of existing files found Iused = 0 !**** Number of blocks used Itot = 0 !**** Total number of blocks Ifloop = 0 !**** Number of lines printed on screen c c Begin loop to read and translate the directory blocks c 10 Continue c c Read two 256 blocks into "Ibuf" c Ierr = Iread(512,Ibuf,Ibkno,Ichan) c c Pause here until the reading is complete c I = Iwait(Ichan) c c Update the block number to read next time c Ibkno = 4 + Ibuf(2) * 2 c c See if there is a read error c If (Ierr .LT. 0) Go To 97 c c Initialize the pointer for each area containing the file info. c Ipos = -1 c 20 Continue c Ipos = Ipos + 7 c c See if we need to get another segment c If (Ibuf(Ipos) .EQ. "4000 .AND. Ibuf(2) .NE. 0) Go To 10 c c See if we are at the end of this file segment c If (Ibuf(Ipos) .EQ. "4000) Go To 50 c c File exists - so get its name c If (Ibuf(Ipos) .EQ. "2000 .OR. Ibuf(Ipos) .LT. -31000) Then c c See if the file name is good enough c Call R50Asc(9,Ibuf(Ipos+1),Newfil) Call Compar(Newfil,Filnam(4),Iflag) If (Iflag .EQ. 0) Go To 20 c Ifiles = Ifiles + 1 Ifloop = Ifloop + 1 c c Add in a "P" in the 10th character place if the file c is protected; otherwise, put in a blank c If (Loop .EQ. 2) Then If (Ibuf(Ipos) .EQ. "2000) Then Names((Ifloop-1) * 5 + 5) = ' ' Else Names((Ifloop-1) * 5 + 5) = ' P' End If c c Convert the file name from RAD50 format to ASCII c Call R50asc(9,Ibuf(Ipos+1),Names((Ifloop-1) * 5 + 1)) c c Get the file size in blocks c Iblock(Ifloop) = Ibuf(Ipos+4) c c If we have enough file names, print them out c If (Line .EQ. Ifloop) Then c c Pause the screen if it is full c If ((Ifiles/(21*Line)) * 21 * Line .EQ. Ifiles) $ Call Spause c Write(7,300) ((Fname(J+(K-1)*10),J=1,9),Iblock(K), $ Fname(K*10),K=1,Line) 300 Format(1X,6A1,'.',3A1,1X,I4,1A1,(:,' |', $ <8/Line>X,6A1,'.',3A1,1X,I4,1A1)) Ifloop = 0 End If End If Iused = Iused + Ibuf(Ipos+4) Itot = Itot + Ibuf(Ipos+4) c Else c c If not an existing file; increment the total number of blocks c Itot = Itot + Ibuf(Ipos+4) c End If c c Loop back for the next file name c Go To 20 c c The end; so, close the channel and free up the channel c number and return. c 50 Continue I = Iclose(Ichan) I = Ifreec(Ichan) c c If there are more than 80 files to print out, set c the screen in 132 column mode and print 7 columns wide c If (Ifiles .GT. 80 .AND. Loop .EQ. 1) Then Line = 7 Write(7,425) 27 425 Format(1X,1A1,'[?3h') End If 60 Continue If (Ifloop .GT. 0) Then c c Write out the last file names c Write(7,300) ((Fname(J+(K-1)*10),J=1,9),Iblock(K), $ Fname(K*10),K=1,Ifloop) End If c c Re-set screen to 80 columns if we had set it at 132 columns c If (Line .GT. 4) Then Write(7,400) 400 Format(' Directory complete. Press return to reset screen', $ ' to 80 columns. ',$) Read(5,450,END=80,ERR=80) Fname(1) 450 Format(1A1) Write(7,475) 27 475 Format(1X,1A1,'[?3l') End If c 80 Return c c ******** ERROR RETURNS ******* c 90 Continue Write(7,500) 500 Format(' Error in getting a channel'/) Go To 99 95 Write(7,600) 600 Format(' Error in getting the file location'/) Go To 99 97 Write(7,700) 700 Format(' Error in reading the blocks'/) c 99 Continue I = Iclose(Ichan) I = Ifreec(Ichan) c End Subroutine Devchk(Devchr,Iflag) c Byte Devchr(4) Integer Good(10) Byte Filnam(12),Fnam(15),Bgood(20) Data Filnam/':','L','A','S','T','.','F','S','T',3*' '/ Data Good/'SY','DK','DY','WF','WP','DP','LD','DR','DU','DL'/ Equivalence (Bgood(1),Good(1)) c Iblank = 0 Iflag = 0 c c Set the characters to uppercase, and remove the colons. c Do 10 I=1,3 c If (Devchr(I) .NE. ' ') Iblank = I + 1 c 10 Continue c c Look for bad names c Do 20 J=1,10 If ((Devchr(1) .EQ. Bgood((J-1)*2+1) .AND. Devchr(2) .EQ. $ Bgood(J*2)) .AND. ((Devchr(3) .GE. '0' .AND. Devchr(3) $ .LE. '9') .OR. Devchr(3) .EQ. ' ')) Go To 30 20 Continue Go To 70 30 Continue c c Device name is spelled ok, but does it exist? Try by opening a file c Do 40 J = 1,11+Iblank If (J .LT. Iblank) Fnam(J) = Devchr(J) If (J .GE. Iblank) Fnam(J) = Filnam(J-Iblank+1) 40 Continue c Open(Unit=12,Name=Fnam,TYPE='OLD',ReadOnly,ERR=50) Close(Unit=12) Return c 50 Continue c c If the open caused an error, was it due to 1) bad device, or c 2) nonexistant file? Lets see.. c Open(Unit=12,Name=Fnam,Type='NEW',Dispose='DELETE',ERR=60) c c If we are here, it is a good device name. So go home. c Close(Unit=12) Return c c Bad device name c 60 Continue Close(Unit=12) c c Error in the device name c 70 Continue c Write(7,100) 100 Format(' ERROR in the device name - try again') Iflag = 1 Return End Subroutine Getax(Amin,Amax,Aminn,Amaxx,Amajor,Aminor) c c *********************************************************************** c * * c * Subroutine GETAX - To determine the axis data for a plot * c * given only the minimum and maximum values of the data to * c * be plotted. * c * * c * Input values: * c * * c * Amin - The minimum data value to plot * c * Amax - The maximum data value to plot * c * * c * Output values: * c * * c * Aminn - The minimum value of the plotting area * c * Amaxx - The maximum value of the plotting area * c * Amajor - The major tick increment * c * Aminor - The minor tick increment * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Delta = Amax - Amin If (Delta .GE. 1.0) Then Ipower = Int(Log10(Delta)) Else Ipower = Int(Log10(Delta) - 0.999999) End If If (Ipower .GT. 0) Then Dnorm = Delta / 10.0**Ipower Else If (Ipower .LT. 0) Then Dnorm = Delta * 10.0**(-Ipower) Else Dnorm = Delta End If c c Set the major and minor tick values c If (Dnorm .LT. 2.0) Then Amajor = 0.2 Aminor = 0.05 Else If (Dnorm .LT. 5.0) Then Amajor = 0.5 Aminor = 0.1 Else If (Dnorm .LT. 7.0) Then Amajor = 1.0 Aminor = 0.25 Else if (Dnorm .GE. 7.0) Then Amajor = 1.0 Aminor = 0.5 End If c If (Ipower .GT. 0) Then Amajor = Amajor * 10.0**Ipower Aminor = Aminor * 10.0**Ipower Else If (Ipower .LT. 0) Then Amajor = Amajor / 10.0**(-Ipower) Aminor = Aminor / 10.0**(-Ipower) End If c c Compute the minimum, maximum values of the plotting area c If (Amin .GE. 0.0) Then Aminn = Amajor * Int(Amin / Amajor) Amaxx = Amajor * Int(Amax / Amajor + 0.999999) Else Aminn = Amajor * Int(Amin / Amajor - 0.999999) c If (Amax .LE. 0.0) Then Amaxx = Amajor * Int(Amax / Amajor) Else Amaxx = Amajor * Int(Amax / Amajor + 0.999999) End If End If c Return End Subroutine Comprs(Filnam) c c *********************************************************************** c * * c * Subroutine Comprs - To create a file specification from * c * a string returned from Infile. This adds in semicolons * c * and periods, and removes blanks. * c * * c * Programmed by Steven C. Fisher, DTNSRDC Code 1522 * c * * c *********************************************************************** c Byte Filnam(15),Fname(15) c c Load in the device name and add a colon c Iposn = 1 Do 10 I=1,3 If (Filnam(I) .EQ. ' ') Go To 20 Iposn = I Fname(Iposn) = Filnam(I) 10 Continue 20 Continue Iposn = Iposn + 1 Fname(Iposn) = ':' c c Load in the file name with a period c Do 30 I=4,9 If (Filnam(I) .EQ. ' ') Go To 40 Iposn = Iposn + 1 Fname(Iposn) = Filnam(I) 30 Continue 40 Continue Iposn = Iposn + 1 Fname(Iposn) = '.' c c Add in the file extension c Do 50 I=10,12 If (Filnam(I) .EQ. ' ') Go To 60 Iposn = Iposn + 1 Fname(Iposn) = Filnam(I) 50 Continue 60 Continue c c Load in the filename back into Filnam c Do 70 I=1,15 If (I .LE. Iposn) Then Filnam(I) = Fname(I) Else Filnam(I) = ' ' End If If (Filnam(I) .EQ. '/') Filnam(I) = '*' 70 Continue Return End Subroutine Filfil(Filnam) c c Subroutine Filfil - to "fill out" a file name to its c Un-rad50 equivalent c Byte Filnam(15),Fname(15) c Icolon = 0 Iperd = 0 Do 10 J=1,15 Fname(J) = ' ' If (Filnam(J) .GT. 'Z') Filnam(J) = Filnam(J) - 32 If (Filnam(J) .EQ. ':') Icolon = J If (Filnam(J) .EQ. '.') Iperd = J 10 Continue c c Space out the device name c If (Icolon .GT. 0) Then Do 20 J=1,Icolon-1 Fname(J) = Filnam(J) 20 Continue Else Fname(1) = 'D' Fname(2) = 'K' End If c c Load in the file name c If (Iperd-Icolon .GT. 1) Then Do 30 J=Icolon+1,Iperd-1 Fname(J-Icolon+3) = Filnam(J) 30 Continue Else If (Iperd .EQ. 0 .AND. Filnam(Icolon+1) .NE. ' ') Then Do 35 I=1,6 Fname(3+I) = Filnam(I+Icolon) 35 Continue Else Fname(4) = '*' End If c c Load in the file extension c If (Iperd .GT. 0) Then Do 40 J=Iperd+1,Iperd+3 Fname(J-Iperd+9) = Filnam(J) 40 Continue Else Fname(10) = '*' End If Do 50 J=1,15 Filnam(J) = Fname(J) 50 Continue c Return End Subroutine Compar(File1,File2,Iflag) c Byte File1(9),File2(9) c Iflag = 0 Iset = 1 Jset = 1 c c Examine the filenames Do 10 J=1,6 If (File2(J) .EQ. '*' .AND. Jset .LT. J) Then Iiset = 7-Iset Is = Iset If (Jset .EQ. 1 .AND. (File2(Jset) .NE. File1(Iset))) $ Return Call Match(File2(Jset),J-Jset,File1(Iset),Iiset,Is) If (Is .EQ. 0) Return Iset = Iset + Is - 1 Jset = J + 1 Else If (File2(J) .EQ. '*') Then Jset = J + 1 Else If (File2(J) .EQ. ' ') Then Iiset = 7-Iset Is = Iset If (Jset .EQ. J) Go To 20 Call Match(File2(Jset),J-Jset,File1(Iset),Iiset,Is) If (Is .EQ. 0) Return If (Iset+Is-2 .GT. J-Jset .AND. Jset .EQ. 1) Return Iset = Iset + Is - 1 If (File1(Iset) .NE. ' ' .AND. Iset .LT. 7) Return Go To 20 Else If (J .EQ. 6) Then Iiset = 7-Iset If (Jset .EQ. J) Go To 20 Call Match(File2(Jset),J-Jset+1,File1(Iset),Iiset,Iset) If (Iset .EQ. 0) Return End If 10 Continue 20 Continue c c Check the file extension for matches c Iset = 7 Jset = 7 c Do 30 J=7,9 If (File2(J) .EQ. '*' .AND. Jset .LT. J) Then Iiset = 10-Iset Is = Iset If (Jset .EQ. 7 .AND. (File2(Jset) .NE. File1(Iset))) $ Return Call Match(File2(Jset),J-Jset,File1(Iset),Iiset,Is) If (Is .EQ. 0) Return Iset = Iset + Is - 1 Jset = J + 1 Else If (File2(J) .EQ. '*') Then Jset = J + 1 Else If (File2(J) .EQ. ' ') Then Iiset = 10-Iset Is = Iset If (Jset .EQ. J) Go To 40 Call Match(File2(Jset),J-Jset,File1(Iset),Iiset,Is) If (Is .EQ. 0) Return If (Iset+Is-2 .GT. J-Jset .AND. Jset .EQ. 7) Return Iset = Iset + Is - 1 c If (File1(Iset-1) .NE. ' ' .AND. Iset .LE. 10) Return If (File1(Iset) .NE. ' ' .AND. Iset .LT. 10) Return Go To 40 Else If (J .EQ. 9) Then Iiset = 10-Iset If (Jset .EQ. J) Go To 40 Call Match(File2(Jset),J-Jset+1,File1(Iset),Iiset,Iset) If (Iset .EQ. 0) Return End If 30 Continue 40 Continue c Iflag = 1 Return End Subroutine Match(Strin1,Len1,Strin2,Len2,Ipos) c Byte Strin1(1),Strin2(1) c Ipos = 0 If (Len1 .GT. Len2) Return !string too long c Do 30 J=1,Len2-Len1+1 c c If first character matches, check each one byte by byte c If (Strin2(J) .EQ. Strin1(1)) Then Do 20 K=1,Len1 If (Strin1(K) .NE. Strin2(J+K-1)) Go To 30 20 Continue Ipos = J + Len1 ! Set Ipos to the next position after the string Return End If 30 Continue Return End