Trailing-Edge
-
PDP-10 Archives
-
decuslib10-12
-
43,50553/pakdir.for
There are no other files named pakdir.for in the archive.
C RENBR(PAKDIR/PACK MONTHLY BACKUP DIRECTORIES)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS PROGRAM READS THE FILES PRODUCED BY BACKUP
C CONTAINING THE DIRECTORIES OF THE HBS MONTHLY BACKUPS
C OF THE PUBLIC STRUCTURES, AND PRODUCES A MUCH
C COMPACTED VERSION OF THESE WHICH CAN BE READ BY THE
C FNDFIL PROGRAM.
C
DIMENSION IBUFFR(132),JBUFFR(132),
1LSTNAM(6),LSTEXT(3),NEWNAM(6),NEWEXT(3),
2LSTOWN(30),LSTDSK(6),NEWOWN(30),NEWDSK(6),
3NEWLNG(6),KBUFFR(132),LA5MTH(12),LTRMRK(8)
DIMENSION IDIGIT(36),LTRDAY(50),KNTDAY(7),
1LTRPER(19),KNTPER(4),LTRWEK(10),KNTWEK(10),
2LBUFFR(6),LTRTYP(20),KNTTYP(3),MBUFFR(6)
COMMON/FNDLOC/LOCFIL
CHARACTER*20 LOCFIL
DOUBLE PRECISION FILNAM,FILOUT
DATA LTRMRK/1H',1H,,1H.,1H*,1H[,1H],1H:,1H /
DATA LTRTYP/
11HB,1HA,1HC,1HK,1HU,1HP,
21HD,1HI,1HR,1HE,1HC,1HT,
31HC,1HH,1HE,1HC,1HK,1HS,1HU,1HM/
DATA KNTTYP/6,6,8/
DATA LA5MTH/
13HJAN,3HFEB,3HMAR,3HAPR,3HMAY,3HJUN,
23HJUL,3HAUG,3HSEP,3HOCT,3HNOV,3HDEC/
DATA MAXOUT/132/
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,
11HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
21HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
31HU,1HV,1HW,1HX,1HY,1HZ/
DATA LTRWEK/1HA,1HB,1HC,1HD,1HE,1H1,1H2,1H3,1H4,1H5/
DATA KNTWEK/1,1,1,1,1,1,1,1,1,1/
DATA LTRPER/
11HD,1HA,1HY,
21HW,1HE,1HE,1HK,
31HM,1HO,1HN,1HT,1HH,
41HP,1HR,1HI,1HV,1HA,1HT,1HE/
DATA KNTPER/3,4,5,7/
DATA LTRDAY/
11HS,1HU,1HN,1HD,1HA,1HY,
21HM,1HO,1HN,1HD,1HA,1HY,
31HT,1HU,1HE,1HS,1HD,1HA,1HY,
41HW,1HE,1HD,1HN,1HE,1HS,1HD,1HA,1HY,
51HT,1HH,1HU,1HR,1HS,1HD,1HA,1HY,
61HF,1HR,1HI,1HD,1HA,1HY,
71HS,1HA,1HT,1HU,1HR,1HD,1HA,1HY/
DATA KNTDAY/6,6,7,9,8,6,8/
DATA IDSK,JDSK/20,21/
C
C CANCEL OUT INITIAL DEVICE AND OWNER
DO 1 I=1,30
1 LSTOWN(I)=' '
DO 2 I=1,6
2 LSTDSK(I)=' '
MAXFIL=0
C
C ASK USER IF PROCESSING DAILY, WEEKLY OR MONTHLY FILES
C OR A PRIVATE PACK DIRECTORY
TYPE 3
3 FORMAT(' PAKDIR'/' Compacts directories for FNDFIL')
4 TYPE 5
5 FORMAT(' Period (DAY, WEEK, MONTH) or PRIVATE pack? ',$)
ACCEPT 9,IBUFFR
LOWBFR=1
MANY=0
CALL DALOSS(1,12,LTRPER,1,4,
1KNTPER,IBUFFR,132,LOWBFR,KIND,ITIME,LCNWRD,
2LCNKNT,LCNBFR,MANY,LCNERR)
IF(KIND.EQ.3)GO TO 6
IF(KIND.EQ.4)GO TO 6
GO TO 4
6 ITIME=ITIME-2
KNTTAP=0
IF(ITIME.EQ.2)GO TO 27
IF(ITIME.EQ.1)GO TO 19
IF(ITIME.EQ.0)GO TO 15
C
C ASK USER TO IDENTIFY DAY
7 TYPE 8
8 FORMAT(' Day (SUN, MON, etc.)? ',$)
ACCEPT 9,IBUFFR
9 FORMAT(132A1)
LOWBFR=1
MANY=0
CALL DALOSS(1,50,LTRDAY,1,7,
1KNTDAY,IBUFFR,132,LOWBFR,KIND,IDAY,LCNWRD,
2LCNKNT,LCNBFR,MANY,LCNERR)
IF(KIND.EQ.3)GO TO 10
IF(KIND.NE.4)GO TO 7
10 NAMOUT=4
I=0
J=0
11 J=J+1
IF(J.GE.IDAY)GO TO 12
I=I+KNTDAY(J)
GO TO 11
12 DO 13 J=1,3
I=I+1
13 LBUFFR(J)=LTRDAY(I)
ENCODE(10,14,FILOUT)LBUFFR(1),LBUFFR(2),LBUFFR(3)
14 FORMAT(3A1,7H .FND)
GO TO 31
C
C ASK USER TO IDENTIFY WEEK
15 TYPE 16
16 FORMAT(' Week (A, B, C, D, E)? ',$)
ACCEPT 9,IBUFFR
LOWBFR=1
MANY=0
CALL DALOSS(1,10,LTRWEK,1,10,
1KNTWEK,IBUFFR,132,LOWBFR,KIND,IWEEK,LCNWRD,
2LCNKNT,LCNBFR,MANY,LCNERR)
IF(KIND.EQ.3)GO TO 17
IF(KIND.NE.4)GO TO 15
17 NAMOUT=4
IF(IWEEK.GT.5)IWEEK=IWEEK-5
LBUFFR(1)=1HW
LBUFFR(2)=1HK
LBUFFR(3)=LTRWEK(IWEEK)
ENCODE(10,18,FILOUT)LTRWEK(IWEEK)
18 FORMAT(4HWEEK,1A1,5H .FND)
GO TO 31
C
C ASK USER FOR NUMBER OF FIRST MONTHLY TAPE
19 TYPE 20
20 FORMAT(' First tape number (0 if automatic)? ',$)
ACCEPT 21,KNTTAP
21 FORMAT(I)
IF(KNTTAP.GT.0)GO TO 26
OPEN(UNIT=JDSK,FILE='PAKDIR.NXT',ACCESS='SEQIN',
1DIRECTORY=LOCFIL,ERR=22)
READ(JDSK,21,ERR=22),KNTTAP
CLOSE(UNIT=JDSK,ERR=22)
IF(KNTTAP.GT.0)GO TO 24
22 TYPE 23
23 FORMAT(' Cannot read first tape number from PAKDIR.NXT')
GO TO 19
24 ITIME=3
TYPE 25,KNTTAP
25 FORMAT(' First tape number will be',1I5)
26 FILOUT='PAKDIR.FND'
KNTTAP=KNTTAP-1
NAMOUT=2
LBUFFR(1)=1HM
LBUFFR(2)=1HB
GO TO 31
C PRIVATE PACK DIRECTORY
27 TYPE 28
28 FORMAT(' Pack name? '$)
ACCEPT 9,IBUFFR
ENCODE(10,29,FILOUT)(IBUFFR(I),I=1,4)
29 FORMAT(4A1,6H .FND)
DO 30 I=1,4
30 LBUFFR(I)=IBUFFR(I)
NAMOUT=4
31 CONTINUE
C
C GET FILE NAME
OPEN(UNIT=JDSK,FILE=FILOUT,
1ACCESS='SEQOUT',DIRECTORY=LOCFIL)
IRECNT=0
32 KNTFIL=-1
IEOF=0
33 TYPE 34
34 FORMAT(' Author (BACKUP, DIRECT)? '$)
ACCEPT 9,IBUFFR
LOWBFR=1
MANY=0
CALL DALOSS(1,20,LTRTYP,1,3,
1KNTTYP,IBUFFR,132,LOWBFR,KIND,IAUTHR,LCNWRD,
2LCNKNT,LCNBFR,MANY,LCNERR)
IF(KIND.EQ.1)GO TO 108
IF(KIND.EQ.3)GO TO 35
IF(KIND.NE.4)GO TO 33
35 IAUTHR=IAUTHR-1
IF(IAUTHR.LE.1)GO TO 37
TYPE 36
36 FORMAT(' Checksummed direct not yet supported')
GO TO 33
37 TYPE 38
38 FORMAT(' File? ',$)
ACCEPT 39,FILNAM
39 FORMAT(1A10)
OPEN(UNIT=IDSK,FILE=FILNAM,ACCESS='SEQIN',ERR=40)
GO TO 42
40 TYPE 41,FILNAM
41 FORMAT(' Could not open file ',1A10)
GO TO 32
C
C CANCEL OUT LAST NAME AND EXTENSION AT START OF EACH FILE
42 DO 43 I=1,6
43 LSTNAM(I)=' '
DO 44 I=1,3
44 LSTEXT(I)=' '
KNTERR=0
GO TO 49
C
C NEW OUTPUT TAPE
45 IEOF=1
46 IF(NOWOUT.GT.0)WRITE(JDSK,47)(KBUFFR(I),I=1,NOWOUT)
47 FORMAT(132A1)
IF(KNTFIL.GT.0)TYPE 48,MBUFFR,KNTFIL
48 FORMAT(' Tape ',6A1,' contains',I6,' files')
IF(KNTFIL.GT.0)MAXFIL=MAXFIL+KNTFIL
IF(IEOF.NE.0)GO TO 32
KNTTAP=KNTTAP+1
KNTFIL=0
C
C READ AND EXPAND NEW LINE FROM DIRECTORY FILE
49 NOWOUT=0
50 READ(IDSK,51,END=45)IBUFFR
51 FORMAT(132A1)
JUSED=0
CALL DACOPY(0,8,IBUFFR,1,132,
1132,JUSED,JBUFFR,NXTINI,NXTBGN,MAXPRT)
CALL LINTYP(JBUFFR,IFFILE,IAUTHR)
IF(IFFILE.LT.0)GO TO 46
IF(IFFILE.EQ.0)GO TO 50
C
C GET COMPONENTS OF FILE SPEC
CALL CHOPUP(JBUFFR,NEWNAM,LNGNAM,NEWEXT,LNGEXT,
1NEWDSK,NEWOWN,KREATE,NEWLNG,IAUTHR,KNTERR)
IF(KREATE.LT.0)GO TO 50
IF(IRECNT.LT.KREATE)IRECNT=KREATE
C
C INSERT SEPARATING COMMA
52 INIOUT=NOWOUT
IF(NOWOUT.LE.0)GO TO 53
NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=1H,
C
C TEST IF OWNER OF FILE CHANGES
53 NEEDED=0
DO 54 INDEX=1,30
IF(NEWOWN(INDEX).NE.1H )GO TO 56
54 CONTINUE
DO 55 INDEX=1,30
55 NEWOWN(INDEX)=LSTOWN(INDEX)
GO TO 71
56 DO 57 INDEX=1,30
IF(NEWOWN(INDEX).NE.LSTOWN(INDEX))GO TO 58
57 CONTINUE
GO TO 71
C
C PUT OWNER INTO BUFFER
58 NEEDED=1
NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=1H[
IBASIS=0
IFCMA=0
DO 70 IPART=1,5
JBEGIN=IBASIS
JEND=IBASIS+6
59 JBEGIN=JBEGIN+1
IF(JBEGIN.GT.JEND)GO TO 70
IF(NEWOWN(JBEGIN).EQ.1H )GO TO 59
60 IF(NEWOWN(JEND).NE.1H )GO TO 61
JEND=JEND-1
GO TO 60
61 KOLUMN=IBASIS
DO 62 INDEX=1,6
KOLUMN=KOLUMN+1
IF(NEWOWN(KOLUMN).NE.LSTOWN(KOLUMN))GO TO 63
62 CONTINUE
NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=1H*
IFCMA=0
GO TO 70
63 IF(IFCMA.EQ.0)GO TO 64
NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=1H,
64 KOLUMN=IBASIS
IBEGIN=0
DO 69 INDEX=1,6
KOLUMN=KOLUMN+1
IF(KOLUMN.LT.JBEGIN)GO TO 69
IF(KOLUMN.GT.JEND)GO TO 69
KOMPAR=NEWOWN(KOLUMN)
IF(IPART.GT.2)GO TO 65
IF(KOMPAR.NE.1H0)GO TO 65
IF(IBEGIN.EQ.0)GO TO 69
65 DO 66 LOCMRK=1,8
IF(KOMPAR.EQ.LTRMRK(LOCMRK))GO TO 67
66 CONTINUE
GO TO 68
67 NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=1H'
68 NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=KOMPAR
IBEGIN=1
69 CONTINUE
IFCMA=1
70 IBASIS=IBASIS+6
C
C TEST IF DISK CHANGES
71 DO 72 INDEX=1,6
IF(NEWDSK(INDEX).NE.1H )GO TO 74
72 CONTINUE
DO 73 INDEX=1,6
73 NEWDSK(INDEX)=LSTDSK(INDEX)
GO TO 78
74 DO 75 INDEX=1,6
IF(NEWDSK(INDEX).NE.LSTDSK(INDEX))GO TO 76
75 CONTINUE
GO TO 78
76 NEEDED=-1
NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=1H:
DO 77 INDEX=1,6
IF(NEWDSK(INDEX).EQ.1H )GO TO 77
NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=NEWDSK(INDEX)
77 CONTINUE
C
C INSERT CLOSING BRACKET IF ONLY OWNER CHANGES,
C OR INSERT COMMA IF DISK CHANGES
78 IF(NEEDED.EQ.0)GO TO 79
NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
IF(NEEDED.GT.0)KBUFFR(NOWOUT)=1H]
IF(NEEDED.LT.0)KBUFFR(NOWOUT)=1H,
C
C INSERT CREATION DATE
79 J36=KREATE/36
K36=KREATE-(36*J36)
I36=J36/36
J36=J36-(36*I36)
NOWOUT=NOWOUT+3
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT-2)=IDIGIT(I36+1)
KBUFFR(NOWOUT-1)=IDIGIT(J36+1)
KBUFFR(NOWOUT)=IDIGIT(K36+1)
C
C INSERT LENGTH OF FILE
DO 80 INDEX=1,6
IF(NEWLNG(INDEX).EQ.1H )GO TO 80
NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=NEWLNG(INDEX)
80 CONTINUE
C
C ADD NAME OF FILE TO LINE BEING WRITTEN
DO 81 INDEX=1,6
IF(NEWNAM(INDEX).NE.LSTNAM(INDEX))GO TO 82
81 CONTINUE
NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=1H*
GO TO 88
82 DO 87 INDEX=1,LNGNAM
KOMPAR=NEWNAM(INDEX)
DO 83 LOCMRK=1,8
IF(KOMPAR.EQ.LTRMRK(LOCMRK))GO TO 85
83 CONTINUE
IF(INDEX.NE.1)GO TO 86
DO 84 I=1,10
IF(KOMPAR.EQ.IDIGIT(I))GO TO 85
84 CONTINUE
GO TO 86
85 NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=1H'
86 NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=NEWNAM(INDEX)
87 CONTINUE
IF(LNGNAM.GE.6)GO TO 88
IFDOT=1
GO TO 89
88 IFDOT=0
C
C ADD EXTENSION OF FILE TO LINE BEING WRITTEN
89 IF(LNGEXT.LE.0)GO TO 97
DO 90 INDEX=1,3
IF(NEWEXT(INDEX).NE.LSTEXT(INDEX))GO TO 91
90 CONTINUE
NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=1H*
GO TO 97
91 IF(IFDOT.EQ.0)GO TO 92
NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=1H.
92 DO 96 INDEX=1,LNGEXT
KOMPAR=NEWEXT(INDEX)
DO 93 LOCMRK=1,8
IF(KOMPAR.EQ.LTRMRK(LOCMRK))GO TO 94
93 CONTINUE
GO TO 95
94 NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
KBUFFR(NOWOUT)=1H'
95 NOWOUT=NOWOUT+1
IF(NOWOUT.GT.MAXOUT)GO TO 107
96 KBUFFR(NOWOUT)=KOMPAR
C
C WRITE OUT TAPE LABEL INTO OUTPUT FILE IF FIRST FILE
97 IF(KNTFIL.GT.0)GO TO 102
IF(KNTFIL.LT.0)KNTTAP=KNTTAP+1
KNTFIL=0
IF(ITIME.GT.0)GO TO 98
IF(LSTDSK(4).NE.NEWDSK(4))KNTTAP=1
98 DO 99 I=1,NAMOUT
MBUFFR(I)=LBUFFR(I)
99 CONTINUE
IF(ITIME.LE.0)MBUFFR(4)=NEWDSK(4)
LFTNAM=NAMOUT
I=1
IF(KNTTAP.GE.10)I=2
IF(KNTTAP.GE.100)I=3
IF(KNTTAP.GE.1000)I=4
IF(KNTTAP.GE.10000)I=5
IF(KNTTAP.GE.100000)I=6
IF(LFTNAM.GT.(6-I))LFTNAM=6-I
CALL DANUMB(1,KNTTAP,10,MBUFFR,LFTNAM,6,6)
DO 100 I=1,6
100 IF(MBUFFR(I).EQ.1H )MBUFFR(I)=1H0
WRITE(JDSK,101)MBUFFR
101 FORMAT(1H],132A1)
C
C STORE THE NEW INFORMATION ABOUT THIS FILE
102 DO 103 INDEX=1,30
103 LSTOWN(INDEX)=NEWOWN(INDEX)
DO 104 INDEX=1,6
104 LSTDSK(INDEX)=NEWDSK(INDEX)
DO 105 INDEX=1,6
105 LSTNAM(INDEX)=NEWNAM(INDEX)
DO 106 INDEX=1,3
106 LSTEXT(INDEX)=NEWEXT(INDEX)
KNTFIL=KNTFIL+1
GO TO 50
C
C OUTPUT LINE IF NEW DESCRIPTION WOULD OVERFLOW LINE
107 IF(INIOUT.GT.0)WRITE(JDSK,47)(KBUFFR(I),I=1,INIOUT)
NOWOUT=0
GO TO 52
C
C IF PUBLIC PACK, CHANGE NAME OF OUTPUT FILE TO BE BASED ON DATE
108 IF(ITIME.LE.0)GO TO 119
IF(ITIME.EQ.2)GO TO 119
IYEAR=IRECNT/(12*31)
IMONTH=(IRECNT/31)-(12*IYEAR)
IDATE=IRECNT-(31*IMONTH)-(12*31*IYEAR)
IYEAR=IYEAR+64
IF(IYEAR.GE.100)IYEAR=IYEAR-100
IMONTH=IMONTH+1
IDATE=IDATE+1
IF(IDATE.GT.15)GO TO 109
IMONTH=IMONTH-1
IF(IMONTH.GT.0)GO TO 109
IMONTH=12
IYEAR=IYEAR-1
109 IF(IYEAR.LT.10)ENCODE(10,110,FILOUT)LA5MTH(IMONTH),IYEAR
IF(IYEAR.GE.10)ENCODE(10,111,FILOUT)LA5MTH(IMONTH),IYEAR
110 FORMAT(1A3,1H0,1I1,5H .FND)
111 FORMAT(1A3,1I2,5H .FND)
CLOSE(UNIT=JDSK,FILE=FILOUT,ERR=112)
GO TO 114
112 TYPE 113,FILOUT
113 FORMAT(' File PAKDIR.FND cannot be renamed to ',1A10)
FILOUT='PAKDIR.FND'
114 IF(ITIME.NE.3)GO TO 120
KNTTAP=KNTTAP+1
OPEN(UNIT=JDSK,FILE='PAKDIR.NXT',ACCESS='SEQOUT',
1DIRECTORY=LOCFIL,ERR=117)
WRITE(JDSK,115,ERR=117)KNTTAP
115 FORMAT(I10)
CLOSE(UNIT=JDSK,ERR=117)
TYPE 116,KNTTAP
116 FORMAT(' Next montly save will begin with tape',1I5)
GO TO 120
117 TYPE 118
118 FORMAT(' Cannot write next tape number in PAKDIR.NXT')
GO TO 120
119 CLOSE(UNIT=JDSK)
C
C INFORM USER OF WHAT HAS BEEN DONE BY THIS PROGRAM
120 IF(KNTFIL.GT.0)TYPE 48,MBUFFR,KNTFIL
TYPE 121,MAXFIL
121 FORMAT(1X,I6,' total files')
TYPE 122,FILOUT
122 FORMAT(' Output file is ',1A10)
STOP
END
SUBROUTINE LINTYP(JBUFFR,IFFILE,IAUTHR)
C RENBR(/IDENTIFY TYPE OF LINE IN INPUT DIRECTORY)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C THIS ROUTINE DETERMINES IF LINE CONTAINS A FILE
C SPECIFICATION BY TESTING FOR THE < AND > AROUND THE
C PROTECTION CODE AND FOR THE MINUS SIGNS IN THE DATE
C FIELD. LINES WHICH START NEW TAPES ARE ALSO
C IDENTIFIED.
C
C IFFILE = -1, RETURNED IF STARTING NEW TAPE
C = 0, RETURNED IF NOT A FILE SPEC
C = 1, RETURNED IF IS A FILE SPEC
C
COMMON/FNDFMT/LOCBAC(10),LOCDIR(10)
DIMENSION JBUFFR(132),LTRCON(24),LTRBGN(17),LTRTHR(16)
C
C LINE BEFORE FIRST TAPE IN DIRECTORY WRITTEN BY BACKUP
DATA LTRBGN/
11HS,1Ht,1Ha,1Hr,1Ht,1H ,1Ho,1Hf,1H ,1Hs,
21Ha,1Hv,1He,1H ,1Hs,1He,1Ht/
C
C LINE BEFORE CONTINUATION TAPE IN DIRECTORY WRITTEN BY BACKUP
DATA LTRCON/
11HC,1Ho,1Hn,1Ht,1Hi,1Hn,1Hu,1Ha,1Ht,1Hi,
21Ho,1Hn,1H ,1Ho,1Hf,1H ,1Hs,1Ha,1Hv,1He,
31H ,1Hs,1He,1Ht/
C
C LINE BEFORE EACH TAPE IN DIRECTORY WRITTEN BY DIRECT
DATA LTRTHR/
11H ,1H ,1H ,1HR,1He,1Ha,1Hd,1H ,1HD,1He,
21Hn,1Hs,1Hi,1Ht,1Hy,1H:/
C
C BRANCH TO CODE FOR PROGRAM WHICH WROTE DIRECTORY
IF(IAUTHR.NE.0)GO TO 5
C
C TEST FOR START OF TAPE IF BACKUP MADE DIRECTORIES
C LOCLES = LOCATION OF LESS THAN SIGN IN FILE SPEC
C LOCGRT = LOCATION OF GREATER THAN SIGN IN FILE SPEC
C LOC1ST = LOCATION OF FIRST MINUS SIGN IN DATE
C LOC2ND = LOCATION OF SECOND MINUS SIGN IN DATE
LOCLES=LOCBAC(7)
LOCGRT=LOCBAC(8)
LOC1ST=LOCBAC(9)
LOC2ND=LOCBAC(10)
DO 1 I=1,24
IF(JBUFFR(I).NE.LTRCON(I))GO TO 2
1 CONTINUE
IFFILE=-1
GO TO 8
2 INDEX=0
3 INDEX=INDEX+1
IF(INDEX.GT.(132-17))GO TO 7
JNDEX=INDEX
DO 4 I=1,17
IF(JBUFFR(JNDEX).NE.LTRBGN(I))GO TO 3
4 JNDEX=JNDEX+1
IFFILE=-1
GO TO 8
C
C TEST FOR START OF TAPE IF DIRECT/MID USED
5 LOCLES=LOCDIR(7)
LOCGRT=LOCDIR(8)
LOC1ST=LOCDIR(9)
LOC2ND=LOCDIR(10)
DO 6 I=1,16
IF(JBUFFR(I).NE.LTRTHR(I))GO TO 7
6 CONTINUE
IFFILE=-1
GO TO 8
C
C TEST FOR LINE CONTAINING FILE DESCRIPTION
7 IFFILE=0
IF(JBUFFR(LOCLES).NE.1H<)GO TO 8
IF(JBUFFR(LOCGRT).NE.1H>)GO TO 8
IF(JBUFFR(LOC1ST).NE.1H-)GO TO 8
IF(JBUFFR(LOC2ND).NE.1H-)GO TO 8
IFFILE=1
8 RETURN
END
SUBROUTINE CHOPUP(JBUFFR,NEWNAM,LNGNAM,NEWEXT,LNGEXT,
1NEWLOC,NEWOWN,KREATE,NEWLNG,IAUTHR,KNTERR)
C RENBR(/CHOP UP LINE IN DIRECTORY INTO PARTS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C JBUFFR = INPUT CHARACTER STRING, RETURNED UNCHANGED
C NEWNAM = RETURNED WITH FILE NAME
C LNGNAM = RETURNED WITH NUMBER OF CHARACTERS IN FILE NAME
C NEWEXT = RETURNED WITH FILE EXTENSION
C LNGEXT = RETURNED WITH NUMBER OF CHARACTERS IN EXTENSION
C NEWLOC = RETURNED WITH CHARACTERS OF DEVICE NAME
C NEWOWN = RETURNED WITH PATH. EACH COMPONENT OF PATH IS
C LEFT JUSTIFIED IN 6 CHARACTERS WITH BLANK FILL.
C NEITHER BRACKETS NOR COMMAS ARE INCLUDED.
C KREATE = RETURNED WITH CREATION DATE AS NUMBER OF DAYS
C SINCE 1-JAN-64, ASSUMING 31 DAY MONTHS
C NEWLNG = RETURNED WITH CHARACTERS OF FILE LENGTH
C WITH BLANK FILL
C
COMMON/FNDFMT/LOCBAC(10),LOCDIR(10)
DIMENSION JBUFFR(132),NEWNAM(6),NEWEXT(3),
1NEWLNG(6),NEWDAT(9),NEWLOC(6),NEWOWN(30),LTRMTH(36),
2LWRMTH(36),LTRDGT(10)
C UPPER CASE FIRST 3 LETTERS OF EACH MONTH NAME
DATA LTRMTH/
1 1HJ,1HA,1HN, 1HF,1HE,1HB, 1HM,1HA,1HR,
2 1HA,1HP,1HR, 1HM,1HA,1HY, 1HJ,1HU,1HN,
3 1HJ,1HU,1HL, 1HA,1HU,1HG, 1HS,1HE,1HP,
4 1HO,1HC,1HT, 1HN,1HO,1HV, 1HD,1HE,1HC/
C LOWER CASE FIRST 3 LETTERS OF EACH MONTH NAME
DATA LWRMTH/
1 1Hj,1Ha,1Hn, 1Hf,1He,1Hb, 1Hm,1Ha,1Hr,
2 1Ha,1Hp,1Hr, 1Hm,1Ha,1Hy, 1Hj,1Hu,1Hn,
3 1Hj,1Hu,1Hl, 1Ha,1Hu,1Hg, 1Hs,1He,1Hp,
4 1Ho,1Hc,1Ht, 1Hn,1Ho,1Hv, 1Hd,1He,1Hc/
C DIGITS 0 THROUGH 9
DATA LTRDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
IF(IAUTHR.NE.0)GO TO 1
C
C DEFINE FIELD LOCATIONS IF BACKUP MADE DIRECTORIES
ININAM=LOCBAC(1)
INIEXT=LOCBAC(2)
INILNG=LOCBAC(3)
INIDAT=LOCBAC(4)
INILOC=LOCBAC(5)
INIOWN=LOCBAC(6)
GO TO 2
C
C DEFINE FIELD LOCATIONS IF DIRECT MADE DIRECTORIES
1 ININAM=LOCDIR(1)
INIEXT=LOCDIR(2)
INILNG=LOCDIR(3)
INIDAT=LOCDIR(4)
INILOC=LOCDIR(5)
INIOWN=LOCDIR(6)
C
C GET FILE NAME
2 KOLUMN=ININAM
LNGNAM=0
DO 3 KOPY=1,6
NEWNAM(KOPY)=JBUFFR(KOLUMN)
IF(JBUFFR(KOLUMN).NE.1H )LNGNAM=KOPY
3 KOLUMN=KOLUMN+1
C
C GET FILE EXTENSION
KOLUMN=INIEXT
LNGEXT=0
DO 4 KOPY=1,3
NEWEXT(KOPY)=JBUFFR(KOLUMN)
IF(JBUFFR(KOLUMN).NE.1H )LNGEXT=KOPY
4 KOLUMN=KOLUMN+1
C
C GET FILE LENGTH
KOLUMN=INILNG
DO 5 KOPY=1,6
NEWLNG(KOPY)=JBUFFR(KOLUMN)
5 KOLUMN=KOLUMN+1
C
C GET FILE CREATION DATE
KOLUMN=INIDAT
DO 6 KOPY=1,9
NEWDAT(KOPY)=JBUFFR(KOLUMN)
6 KOLUMN=KOLUMN+1
C
C GET FILE LOCATION
NXTCLM=INILOC
KOLUMN=INILOC-1
7 IF(NXTCLM.GT.132)GO TO 8
IF(JBUFFR(NXTCLM).EQ.1H:)GO TO 8
IF(JBUFFR(NXTCLM).EQ.1H )KOLUMN=NXTCLM
NXTCLM=NXTCLM+1
GO TO 7
8 DO 10 KOPY=1,6
KOLUMN=KOLUMN+1
IF(KOLUMN.GE.NXTCLM)GO TO 9
NEWLOC(KOPY)=JBUFFR(KOLUMN)
GO TO 10
9 NEWLOC(KOPY)=' '
10 CONTINUE
C
C GET FILE OWNER
KOLUMN=INIOWN
NXTCLM=0
11 IF(JBUFFR(KOLUMN).EQ.1H[)GO TO 12
KOLUMN=KOLUMN+1
IF(KOLUMN.LE.132)GO TO 11
12 KOLUMN=KOLUMN+1
DO 16 KOPY=1,30
13 IF(KOPY.LE.NXTCLM)GO TO 15
IF(KOLUMN.GT.132)GO TO 15
IF(JBUFFR(KOLUMN).EQ.1H])GO TO 15
IF(JBUFFR(KOLUMN).NE.1H,)GO TO 14
KOLUMN=KOLUMN+1
NXTCLM=NXTCLM+6
GO TO 13
14 NEWOWN(KOPY)=JBUFFR(KOLUMN)
KOLUMN=KOLUMN+1
GO TO 16
15 NEWOWN(KOPY)=' '
16 CONTINUE
C
C EVALUATE DAY
IDATE=0
DO 18 I=1,2
LTRNOW=NEWDAT(I)
DO 17 J=1,10
IF(LTRNOW.NE.LTRDGT(J))GO TO 17
IDATE=(10*IDATE)+J-1
GO TO 18
17 CONTINUE
18 CONTINUE
C
C EVALUATE YEAR
IYEAR=0
DO 20 I=8,9
LTRNOW=NEWDAT(I)
DO 19 J=1,10
IF(LTRNOW.NE.LTRDGT(J))GO TO 19
IYEAR=(10*IYEAR)+J-1
GO TO 20
19 CONTINUE
20 CONTINUE
C
C EVALUATE 3 LETTER MONTH ABBREVIATION
IMONTH=0
JMONTH=0
21 IMONTH=IMONTH+1
IF(IMONTH.GT.12)GO TO 23
I=3
J=JMONTH
JMONTH=JMONTH+3
22 IF(J.GE.JMONTH)GO TO 25
I=I+1
J=J+1
IF(NEWDAT(I).EQ.LTRMTH(J))GO TO 22
IF(NEWDAT(I).EQ.LWRMTH(J))GO TO 22
GO TO 21
C
C ERROR IN INPUT LINE
23 KREATE=-1
IF(KNTERR.EQ.0)TYPE 24
24 FORMAT(' *** Input file contains errors ***')
KNTERR=KNTERR+1
GO TO 26
C
C CONVERT TO 1 JAN 64 AS BASE
25 IYEAR=IYEAR-64
IF(IYEAR.LT.0)IYEAR=IYEAR+100
KREATE=(12*31*IYEAR)+(31*(IMONTH-1))+(IDATE-1)
C
C RETURN TO CALLING PROGRAM
26 RETURN
END