Trailing-Edge
-
PDP-10 Archives
-
decuslib20-07
-
decus/20-0171/weekly.for
There are 2 other files named weekly.for in the archive. Click here to see a list.
BLOCK DATA
C RENBR(/FIXED INFORMATION FOR CALENDAR PROGRAM)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C CHARACTERS TO SHIFT DIABLO TYPING 1/120 INCH FOR BOLDING
COMMON/CALONE/LTRDRK(7)
C
C LTRDRK = SEQUENCE TO MOVER DIABLO PRINTHEAD 1/120 INCH
C THIS IS DONE BY CHANGING WIDTH OF EACH CHARACTER TO 1/120 INCH
C TYPING A SPACE, THEN CHANGING WIDTH BACK TO 1/12 INCH
C ESC, ^- OR US, ^B, SPACE, ESC, ^-, VT OR WHATEVER HAS CODE 11
DATA LTRDRK/
1"155004020100,"175004020100,"011004020100,
21H ,
3"155004020100,"175004020100,"055004020100/
END
C RENBR(WEEKLY/MERGE DAILY SCHEDULES INTO WEEKLY SCHEDULE)
C
C DONALD BARTH, YALE UNIVERSITY, SOM
C
C THIS PROGRAM READS 6 FILES CONTAINING DAILY SCHEDULES
C FOR THE DAYS MONDAY THROUGH SATURDAY. THE FIRST LINE
C IN EACH FILE FOR A PARTICULAR TIME SHOULD CONTAIN THAT
C TIME IN THE FORM HH:MM AT THE START OF THE LINE.
C THE PROGRAM WILL SORT THROUGH THE FILES, PUTTING THE
C INFORMATION FOR A PARTICULAR TIME TOGETHER ON THE SAME
C LINE IN THE OUTPUT. EACH LINE OF THE DAILY FILES SHOULD
C BE NO WIDER THAN 25 CHARACTERS.
C
C FOLLOWING STORE INFORMATION ABOUT EACH COLUMN
C LNGCLM = NUMBER OF LINS STORED FOR EACH COLUMN
C KLOSE = CLOSING TIME BEING REPRESENTED IN EACH COLUMN
C NOWLIN = LINE NUMBER TO NEXT BE REPRESENTED IN EACH COLUMN
C JFBOLD = 0 IF NORMAL DENSITY, 1 IF DARK
C DIMENSION LNGCLM(LMTCLM),NOWLIN(LMTCLM)
DIMENSION LNGCLM(7),KLOSE(7),NOWLIN(7),JFBOLD(7)
C
C FOLLOWING STORES INFORMATION ABOUT EACH LINE IN EACH COLUMN
C ITIME = STARTING TIME IF ONE IS GIVEN, -1 OTHERWISE
C JTIME = ENDING TIME IF ONE IS GIVEN, -1 OTHERWISE
C KTIME = FOR WEEKENDS, 0=SATURDAY EVENT, 1=SUNDAY, 2=BOTH DAYS
C IFBOLD = 0 FOR NORMAL LINES, 1 FOR BOLD LINES
C DIMENSION ITIME(LMTCLM,LMTLIN),JTIME(LMTCLM,LMTLIN)
DIMENSION ITIME(7,500),JTIME(7,500),KTIME(500),IFBOLD(7,500)
C
C FOLLOWING STORES PORTION OF SINGLE LINE IN SINGLE COLUMN
C WHILE THIS IS A1 PACKED BEFORE IT IS A5 PACKED
C DIMENSION LTRONE(LMTWRD*LMTBYT)
DIMENSION LTRONE(25)
C
C FOLLOWING STORES A SINGLE OUTPUT LINE
C DIMENSION LTRLIN((LMTWRD*LMTBYT*LMTCLM)+LMTCLM)
DIMENSION LTRLIN(182)
C
C FOLLOWING STORE CHARACTERS PACKED 5 PER COMPUTER WORD
C LA5ONE = STORES CHARACTERS ON 1 LINE IN A SINGLE COLUMN
C BEFORE THESE ARE STORED IN LA5ALL ARRAY
C LA5LIN = ACCUMULATES A SINGLE OUTPUT LINE FOR ALL COLUMNS
C LA5ALL = STORES ENTIRE SCHEDULE FOR 1 WEEK
C DIMENSION LA5ONE(LMTWRD),LA5LIN(LMTWRD*LMTCLM),
C 1LA5ALL(LMTCLM,LMTWRD,LMTLIN)
DIMENSION LA5ONE(5),LA5LIN(35),LA5ALL(7,5,500)
C
C FOLLOWING STORE CHARACTERS USED IN CONSTRUCTIONS
C LTRDGT = THE DIGITS ZERO THROUGH NINE
C LTRMTH = THE 3 LETTER ABBREVIATIONS OF THE MONTHS
DIMENSION LTRDGT(10),LTRMTH(36),LWRMTH(36),LTRDAY(24),
1LTREND(29),LNGEND(3),LTRAM(5),LWRAM(5),LNGAM(3)
C
C LTRDAT = ARRAY INTO WHICH STARTING DATE IS READ
C LTRPRF = ARRAY INTO WHICH EACH LINE OF PROFILE FILE IS READ
C LTRFIL = ARRAY IN WHICH FILE NAME IS CONSTRUCTED
C LTRRAW = ARRAY INTO WHICH EACH LINE OF SCHEDULE IS READ
C EACH LINE IS READ INTO LTRRAW, TIME STAMPS STRIPPED OFF AND
C STORED IN LTRONE, PACKED INTO LTRCLM, THEN STORED IN LA5ALL
C UNTIL PRINTING WHEN AN OUTPUT LINE IS CONSTRUCTED IN LA5LIN.
C LTRTOP = ARRAY USED TO HOLD TOP LINES WRITTEN ABOVE CALENDAR
DIMENSION LTRFIL(10),LTRRAW(80),LTRDAT(40),LTRPRF(80),
1LTRTOP(158)
C
C VOCABULAR OF WORDS WHICH CAN APPEAR IN LISTS OF DATES
DIMENSION LTRTO(19),LWRTO(19),LNGTO(6)
C
C LETTERS USED FOR MOVING PRINTHEAD 1/120 INCH ON DIABLO
C TERMINAL FOR USE IN GETTING BOLDFACE EVENT NAMES
COMMON/CALONE/LTRDRK(7)
C
C INPUT AND OUTPUT FILE NAMES PACKED BY 1A10 FORMAT
DOUBLE PRECISION FILINP,FILOUT
C
C LMTLIN = MAXIMUM NUMBER OF LINES FOR 1 WEEK
C LMTRAW = MAXIMUM NUMBER OF CHARACTERS IN A SINGLE LINE READ
C FROM THE SCHEDULE FILE
C LMTDAT = MAXIMUM NUMBER OF CHARACTERS IN STARTING DATE
C LMTPRF = MAXIMUM NUMBER OF CHARACTERS IN A LINE
C READ FROM THE PROFILE FILE WHICH SELECTS
C REPEATING FILES
C LMTCLM = MAXIMUM NUMBER OF COLUMNS. AS DISTRIBUTED
C THIS PROGRAM PRODUCES 6 PARALLEL COLUMNS,
C PLACING SATURDAY AND SUNDAY TOGETHER IN THE
C SIXTH COLUMN. IF THE OUTPUT PRINTER CAN
C MORE CHARACTERS ACROSS THE WIDTH OF THE PAGE,
C THEN LMTCLM CAN BE SET TO 7 AND KLMEND THEN
C SHOULD BE SET TO 8 SO THAT THE RIGHT COLUMN
C IS NOT TAKEN AS A COMBINED WEEKEND COLUMN.
C LMTWRD = NUMBER OF COMPUTER WORDS INTO WHICH THE
C CHARACTERS TO BE IN A COLUMN ARE STORED.
C THESE ARE READ WITH A MULTIPLE OF A1 FORMAT
C THEN STORED WITH A MULTIPLE OF A5 FORMAT.
C LMTBYT = NUMBER OF CHARACTERS WHICH CAN BE PACKED
C INTO A SINGLE COMPUTER WORD
C KLMEND = COLUMN NUMBER OF COLUMN TO BE TAKEN AS THE
C COMBINED SATURDAY/SUNDAY WEEKEND COLUMN. IF
C THE OUTPUT DEVICE CAN DISPLAY ENOUGH CHARACTERS
C TO HAVE SATURDAY AND SUNDAY IN SEPARATE COLUMNS,
C THEN KLMEND SHOULD BE SET TO 1 MORE THAN LMTCLM.
C
DATA LMTLIN,LMTRAW,LMTDAT,LMTPRF,LMTCLM,LMTWRD,
1 LMTBYT,KLMEND,LMTTOP/
2 500,80,40,80,6,5,5,6,158/
C
C SHORT NAMES OF DAYS OF WEEK
DATA LTRDAY/
11HS,1Hu,1Hn, 1HM,1Ho,1Hn, 1HT,1Hu,1He,
21HW,1He,1Hd, 1HT,1Hh,1Hu, 1HF,1Hr,1Hi,
31HS,1Ha,1Ht, 1HS,1H/,1HS/
C
C WEEKEND DAY IDENTIFICATIONS
DATA LTREND/
11H ,1H ,1HS,1Ha,1Ht,1Hu,1Hr,1Hd,1Ha,1Hy,
21H ,1H ,1HS,1Hu,1Hn,1Hd,1Ha,1Hy,
31H ,1H ,1HB,1Ho,1Ht,1Hh,1H ,1Hd,1Ha,1Hy,1Hs/
DATA LNGEND/10,8,11/
C
C AM, M, PM
DATA LTRAM/1HA,1HM,1HM,1HP,1HM/
DATA LWRAM/1Ha,1Hm,1Hm,1Hp,1Hm/
DATA LNGAM/2,1,2/
DATA LMTAM/3/
C
C DATE SEPARATOR WORDS
DATA LTRTO/
11HT,1HO,
21HT,1HH,1HR,1HU,
31HT,1HH,1HR,1HO,1HU,1HG,1HH,
41HA,1HN,1HD,
51HO,1HR,
61H,/
DATA LWRTO/
11Ht,1Ho,
21Ht,1Hh,1Hr,1Hu,
31Ht,1Hh,1Hr,1Ho,1Hu,1Hg,1Hh,
41Ha,1Hn,1Hd,
51Ho,1Hr,
61H,/
DATA LNGTO/2,4,7,3,2,1/
DATA LMTTO/6/
C
C DIGITS ZERO THROUGH NINE
DATA LTRDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C SHORT FORM OF DATES OF MONTHS
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/
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/
DATA LTRSPA,LTREXC,LTRSTA/1H ,1H!,1H*/
C
C UNIT NUMBERS
DATA ITTY,IDISK,JDISK,KDISK/5,1,20,21/
C
C CALCULATE NUMBER OF BYTES ACROSS A SINGLE COLUMN
LMTPAC=LMTWRD*LMTBYT
C
C TURN OFF USE OF RIGHT COLUMN AS COMBINED SATURDAY
C SUNDAY COLUMN IF OUTPUT DEVICE CAN SHOW MORE CHRACTERS
IF(LMTCLM.GE.7)KLMEND=LMTCLM+1
C
C TELL USER WHAT PROGRAM THIS IS
WRITE(ITTY,1)
1 FORMAT(' WEEKLY'/
1' Merges daily schedules into weekly calendar'/1X)
C
C ASK USER FOR STARTING DATE
2 WRITE(ITTY,3)
3 FORMAT(' Starting date (a Monday)? ',$)
READ(ITTY,4)LTRDAT
4 FORMAT(80A1)
LOWBFR=1
CALL DADATE(1,LTRDAT,80,LOWBFR,KIND,
1IDAY,IMONTH,IYEAR,LCNBFR)
IF(IDAY.LT.0)GO TO 5
IF(IMONTH.LT.0)GO TO 5
IF(IYEAR.LT.0)GO TO 5
IF(IYEAR.LE.80)IYEAR=IYEAR+2000
IF(IYEAR.LT.100)IYEAR=IYEAR+1900
GO TO 7
5 WRITE(ITTY,6)
6 FORMAT(' Date must include day, month and year'/
1' Use any conventional notation such as'/
2' October 20, 82 or 20 October 82 or 10/20/82')
GO TO 2
7 CALL DAWEEK(0,ISMITH,IDAY,IMONTH,IYEAR,IWEEK)
K=3*IMONTH
J=K-2
M=3*IWEEK
L=M-2
WRITE(ITTY,8)(LTRDAY(I),I=L,M),IDAY,
1(LWRMTH(I),I=J,K),IYEAR
8 FORMAT(' ',3A1,' ',1I2,'-',3A1,'-',1I4)
IF(IWEEK.EQ.2)GO TO 10
WRITE(ITTY,9)
9 FORMAT(' Starting date must be a Monday')
GO TO 2
C
C ASK USER HOW MANY WEEKS ARE TO BE IN CALENDAR
10 WRITE(ITTY,11)
11 FORMAT(' Show how many weeks? ',$)
READ(ITTY,12)MAXWEK
12 FORMAT(I)
IF(MAXWEK.LE.0)GO TO 10
C
C GET NAME OF OUTPUT FILE AND OPEN IT
13 WRITE(ITTY,14)
14 FORMAT(' Name of output file? ',$)
READ(ITTY,15)LTRPRF
15 FORMAT(80A1)
MAXPRF=LMTPRF
16 IF(LTRPRF(MAXPRF).NE.LTRSPA)GO TO 18
MAXPRF=MAXPRF-1
IF(MAXPRF.GT.0)GO TO 16
WRITE(ITTY,17)
17 FORMAT(' File name must be specified')
GO TO 13
18 LOWPRF=0
19 LOWPRF=LOWPRF+1
IF(LTRPRF(LOWPRF).EQ.LTRSPA)GO TO 19
IFILE=1
GO TO 116
20 WRITE(ITTY,21)
21 FORMAT(' File cannot be written')
GO TO 13
22 WRITE(ITTY,23)
23 FORMAT(' File name must be 1 to 6 letters or digits,'/
1' optionally followed by period and 0 to 3 letters or digits')
GO TO 13
24 CONTINUE
C
C ASK IF DIABLO OR DECWRITER OUTPUT IS DESIRED
WRITE(ITTY,25)
25 FORMAT(' Answer 0 if on Decwriter, 1 if on Diablo'/
1' Will calendar be printed on Decwriter or Diablo? ',$)
READ(ITTY,26)KNDDRK
26 FORMAT(I)
C
C START OF WEEK LOOP
DO 178 NOWWEK=1,MAXWEK
C
C READ IN COLUMN OF TEXT FOR EACH DAY OF WEEK
MAXLIN=0
IWHICH=0
MAXSHO=0
DO 125 KOLUMN=1,LMTCLM
LINE=0
LNGCLM(KOLUMN)=0
27 IPASS=0
C
C CONVERT SMITHSONIAN DATE TO DAY, MONTH YEAR AND DAY OF WEEK
CALL DAWEEK(-1,ISMITH,IDAY,IMONTH,IYEAR,IWEEK)
C
C INSERT DATE INTO LINE TO BE WRITTEN ACROSS TOP OF ALL COLUMNS
MIDSHO=MAXSHO+(LMTPAC/2)
DO 28 I=1,LMTPAC
MAXSHO=MAXSHO+1
LTRLIN(MAXSHO)=LTRSPA
28 CONTINUE
I=IDAY/10
J=IDAY-(10*I)
LTRLIN(MIDSHO-4)=LTRDGT(I+1)
LTRLIN(MIDSHO-3)=LTRDGT(J+1)
LTRLIN(MIDSHO-2)='-'
I=3*IMONTH-2
LTRLIN(MIDSHO-1)=LWRMTH(I)
LTRLIN(MIDSHO)=LWRMTH(I+1)
LTRLIN(MIDSHO+1)=LWRMTH(I+2)
LTRLIN(MIDSHO+2)='-'
I=IYEAR/100
J=IYEAR/10
I=J-(10*I)
J=IYEAR-(10*J)
LTRLIN(MIDSHO+3)=LTRDGT(I+1)
LTRLIN(MIDSHO+4)=LTRDGT(J+1)
C
C GET NAME OF NEXT FILE NAMED BY PROFILE FILE FOR DESIRED DATE
OPEN(UNIT=JDISK,FILE='WEEKLY.DAY',ACCESS='SEQIN')
29 CALL PROFIL(IWHICH,ISMITH,ITTY,JDISK,LMTPRF,
1LTRPRF,LOWPRF,MAXPRF,KNDDAY)
IF(IWHICH.EQ.0)GO TO 103
C
C REMOVE WEEDEND AND ALL ENTRIES FOR SUNDAY
IF(IWEEK.NE.1)GO TO 30
IF(KNDDAY.NE.1)GO TO 29
C
C OPEN THE FILE NAMED BY THE PROFILE FILE
30 IFILE=2
GO TO 116
31 WRITE(ITTY,32)(LTRPRF(I),I=1,MAXPRF)
32 FORMAT(
1' Incorrect file name in line in calendar profile:'/
21X,80A1)
GO TO 29
33 WRITE(ITTY,34)(LTRPRF(I),I=1,MAXPRF)
34 FORMAT(
1' Cannot read file specified by line in calendar profile:'/
21X,80A1)
GO TO 29
C
C CONSTRUCT NAME OF DATED INPUT FILE AND OPEN IT
C THE FILE NAME IS SIMILAR TO 12NOV.82 FOR NOVEMBER 12, 1982
35 I=IDAY/10
J=IDAY-(10*I)
LTRPRF(1)=LTRDGT(I+1)
LTRPRF(2)=LTRDGT(J+1)
I=3*IMONTH-2
LTRPRF(3)=LTRMTH(I)
LTRPRF(4)=LTRMTH(I+1)
LTRPRF(5)=LTRMTH(I+2)
I=IYEAR/100
J=IYEAR/10
I=J-(10*I)
J=IYEAR-(10*J)
LTRPRF(6)='.'
LTRPRF(7)=LTRDGT(I+1)
LTRPRF(8)=LTRDGT(J+1)
LOWPRF=1
MAXPRF=8
IFILE=3
GO TO 116
C
C GET NEXT LINE FROM INPUT FILE
C INCR = -1, IGNORE LINES TILL NEXT TIMESTAMP, DATE NOT
C IN RANGE INDICATED
C = 0, FIRST LINE IN EVENT DESCRIPTION
C = 1, SUBSEQUENT LINE IN EVENT DESCRIPTION
C = 2, NO TIMESTAMP YET FOUND IN INPUT FILE
C IPASS = 0, READ ITEMS FROM FILES NAMED IN PROFILE FILE
C = 1, READ ITEMS FROM DATED FILE
C JPASS = 0, CHECK FOR FIRST TIMESTAMP ON LINE
C = 1, CHECK FOR SECOND TIMESTAMP ON LINE
C KPASS = -1, NO DATE FOUND ON LINE AFTER TIMESTAMP
C = 0, UNKNOWN ITEM FOUND WHEN CHECKING FOR THE
C WORDS TO OR AND. CHECK IF THIS IS A DATE
C = 1, A KNOWN ITEM, EITHER A DATE OR A WORD, WAS
C THE LAST ITEM FOUND
36 INCR=2
MINLIN=LINE+1
37 READ(IDISK,38,END=104)LTRRAW
38 FORMAT(80A1)
MAXRAW=LMTRAW
39 IF(LTRRAW(MAXRAW).NE.LTRSPA)GO TO 40
MAXRAW=MAXRAW-1
IF(MAXRAW.GT.0)GO TO 39
GO TO 37
40 MAXUSE=1
41 IF(LTRRAW(MAXUSE).EQ.LTREXC)GO TO 42
MAXUSE=MAXUSE+1
IF(MAXUSE.LE.MAXRAW)GO TO 41
42 MAXUSE=MAXUSE-1
IF(MAXUSE.LE.0)GO TO 37
C
C EVALUATE THE TIMESTAMP
LOWBFR=1
JPASS=0
43 IHOUR=-1
IMINUT=-1
IFAMPM=0
44 IF(LOWBFR.GT.MAXUSE)GO TO 37
IF(LTRRAW(LOWBFR).NE.1H )GO TO 46
LOWBFR=LOWBFR+1
GO TO 44
45 LOWBFR=LOWBFR+1
IF(LOWBFR.GT.MAXUSE)GO TO 83
46 LTRNOW=LTRRAW(LOWBFR)
IF(LTRNOW.EQ.1H:)GO TO 48
DO 47 I=1,10
IF(LTRNOW.NE.LTRDGT(I))GO TO 47
IF(IHOUR.LT.0)IHOUR=0
IHOUR=(10*IHOUR)+I-1
GO TO 45
47 CONTINUE
GO TO 83
48 LOWBFR=LOWBFR+1
IF(LOWBFR.GT.MAXUSE)GO TO 59
LTRNOW=LTRRAW(LOWBFR)
DO 49 I=1,10
IF(LTRNOW.NE.LTRDGT(I))GO TO 49
IF(IMINUT.LT.0)IMINUT=0
IMINUT=(10*IMINUT)+I-1
GO TO 48
49 CONTINUE
IFAMPM=0
J=0
50 IFAMPM=IFAMPM+1
IF(IFAMPM.GT.LMTAM)GO TO 58
K=J
J=J+LNGAM(IFAMPM)
L=LOWBFR-1
51 K=K+1
L=L+1
IF(K.GT.J)GO TO 52
IF(L.GT.MAXUSE)GO TO 50
LTRNOW=LTRRAW(L)
IF(LTRNOW.EQ.LTRAM(K))GO TO 51
IF(LTRNOW.EQ.LWRAM(K))GO TO 51
GO TO 50
52 LOWBFR=L
GO TO(53,54,55),IFAMPM
C 12:00 AM (MIDNIGHT) TO 12:59 AM SUBTRACT 12 FROM HOURS
53 IF(IHOUR.EQ.12)IHOUR=IHOUR-12
GO TO 59
C 12:00 (NOON) IS ONLY POSSIBLE USE OF M BY ITSELF
54 IF(IHOUR.NE.12)GO TO 57
IF(IMINUT.NE.0)GO TO 57
GO TO 59
C 12:01 PM TO 12:59 PM UNCHANGED
C 1:00 PM TO 12:00 PM (MIDNIGHT) ADD ON 12 TO HOURS
55 IF(IHOUR.LT.12)GO TO 56
IF(IMINUT.GT.0)GO TO 59
56 IHOUR=IHOUR+12
GO TO 59
57 LOWBFR=LOWBFR-1
58 IFAMPM=0
59 IF(IHOUR.LT.0)GO TO 83
IF(IMINUT.LT.0)GO TO 83
IF(JPASS.NE.0)GO TO 65
IF(LINE.GE.LMTLIN)GO TO 104
IF(INCR.NE.0)LINE=LINE+1
INCR=0
C
C STORE STARTING TIME
ITIME(KOLUMN,LINE)=(100*IHOUR)+IMINUT
JTIME(KOLUMN,LINE)=-1
IFBOLD(KOLUMN,LINE)=-1
IF(IPASS.NE.0)IFBOLD(KOLUMN,LINE)=1
IF(IWEEK.EQ.1)GO TO 60
IF(IWEEK.EQ.7)GO TO 61
GO TO 62
60 KTIME(LINE)=1
GO TO 62
61 KTIME(LINE)=0
IF(KNDDAY.GE.9)KTIME(LINE)=2
62 IF(LOWBFR.GT.MAXUSE)GO TO 101
IF(LTRRAW(LOWBFR).EQ.1H )LOWBFR=LOWBFR+1
INIBFR=LOWBFR
63 IF(LOWBFR.GE.MAXUSE)GO TO 101
IF(LTRRAW(LOWBFR).NE.1H )GO TO 64
LOWBFR=LOWBFR+1
GO TO 63
C
C CHECK FOR SECOND TIME STAMP ON LINE
64 IF(LTRRAW(LOWBFR).NE.1H-)GO TO 68
LOWBFR=LOWBFR+1
INIBFR=LOWBFR
JPASS=1
GO TO 43
C
C STORE ENDING TIME
65 LTIME=(100*IHOUR)+IMINUT
IF(LTIME.GE.ITIME(KOLUMN,LINE))GO TO 66
IHOUR=IHOUR+12
GO TO 65
66 JTIME(KOLUMN,LINE)=LTIME
IF(LOWBFR.GT.MAXUSE)GO TO 101
IF(LTRRAW(LOWBFR).EQ.1H )LOWBFR=LOWBFR+1
INIBFR=LOWBFR
67 IF(LOWBFR.GE.MAXUSE)GO TO 101
IF(LTRRAW(LOWBFR).NE.1H )GO TO 68
LOWBFR=LOWBFR+1
GO TO 67
C
C GET FIRST DATE IN DATE RANGE
68 KPASS=-1
C
C EVALUATE DATE
69 IF(LOWBFR.GT.MAXUSE)GO TO 101
IF(LTRRAW(LOWBFR).NE.LTRSPA)GO TO 70
LOWBFR=LOWBFR+1
GO TO 69
70 INIBFR=LOWBFR
CALL DADATE(1,LTRRAW,MAXUSE,LOWBFR,KIND,
1JDAY,JMONTH,JYEAR,LCNBFR)
IF(KIND.LE.3)GO TO 81
IF(KIND.GE.18)GO TO 81
IF(JDAY.LT.0)GO TO 81
IF(JMONTH.LT.0)GO TO 81
IF(JYEAR.LT.0)GO TO 81
IF(JYEAR.LE.80)JYEAR=JYEAR+2000
IF(JYEAR.LT.100)JYEAR=JYEAR+1900
CALL DAWEEK(0,KSMITH,JDAY,JMONTH,JYEAR,JWEEK)
IF(KPASS.GT.0)GO TO 78
KPASS=1
C
C LOOK FOR SEPARATING WORDS TO, THROUGH, AND, COMMA
71 JSMITH=KSMITH
ICHECK=LOWBFR-1
72 ICHECK=ICHECK+1
IF(ICHECK.GT.MAXUSE)GO TO 76
IF(LTRRAW(ICHECK).EQ.LTRSPA)GO TO 72
KMDTO=0
ICHECK=ICHECK-1
KCHECK=0
73 KMDTO=KMDTO+1
IF(KMDTO.GT.LMTTO)GO TO 77
JCHECK=ICHECK
LCHECK=KCHECK
KCHECK=KCHECK+LNGTO(KMDTO)
74 LCHECK=LCHECK+1
JCHECK=JCHECK+1
IF(LCHECK.GT.KCHECK)GO TO 75
IF(JCHECK.GT.MAXUSE)GO TO 73
IF(LTRTO(LCHECK).EQ.LTRRAW(JCHECK))GO TO 74
IF(LWRTO(LCHECK).EQ.LTRRAW(JCHECK))GO TO 74
GO TO 73
75 LOWBFR=JCHECK
GO TO(69,69,69,78,78,78),KMDTO
C
C CHECK IF DESIRED DATE IS IN INDICATED RANGE
76 LOWBFR=MAXUSE+1
77 KPASS=0
78 IF(ISMITH.LT.JSMITH)GO TO 79
IF(ISMITH.GT.KSMITH)GO TO 79
GO TO 80
79 IF(LOWBFR.GT.MAXUSE)GO TO 101
IF(KPASS.EQ.0)GO TO 69
GO TO 71
C
C REMOVE AN ITEM FROM THE CALENDAR
80 LINE=LINE-1
INCR=-1
GO TO 37
C
C UNKNOWN ITEM FOUND TO RIGHT OF TIME OR TIME RANGE
81 IF(KPASS.LT.0)GO TO 84
WRITE(ITTY,82)FILINP
82 FORMAT(
1' Item right of date taken as event description in file: ',1A10)
GO TO 86
C
C UNKNOWN ITEM FOUND INSTEAD OF TIME STAMP
83 IF(INCR.LT.0)GO TO 37
IF(JPASS.EQ.0)GO TO 88
84 WRITE(ITTY,85)FILINP
85 FORMAT(
1' Item right of time taken as event description in file: ',1A10)
86 WRITE(ITTY,87)(LTRRAW(I),I=1,MAXRAW)
87 FORMAT(1X,80A1)
J=INIBFR-1
WRITE(ITTY,87)(LTRSPA,I=1,J),(LTRSTA,I=INIBFR,MAXUSE)
GO TO 89
C
C SHIFT STUFF RIGHT OF DATE AND STORE
88 INIBFR=1
89 IF(INIBFR.GT.MAXUSE)GO TO 37
IF(LTRRAW(INIBFR).NE.LTRSPA)GO TO 90
INIBFR=INIBFR+1
GO TO 89
90 ISHIFT=0
IF(INCR.EQ.1)ISHIFT=2
DO 93 I=1,LMTPAC
IF(ISHIFT.NE.0)GO TO 91
IF(INIBFR.GT.MAXUSE)GO TO 92
LTRONE(I)=LTRRAW(INIBFR)
INIBFR=INIBFR+1
GO TO 93
91 ISHIFT=ISHIFT-1
92 LTRONE(I)=' '
93 CONTINUE
IF(INIBFR.GT.MAXUSE)GO TO 95
WRITE(ITTY,94)FILINP
94 FORMAT(
1' Excess characters discarded in line read from file: ',1A10)
WRITE(ITTY,87)(LTRRAW(I),I=1,MAXRAW)
J=INIBFR-1
WRITE(ITTY,87)(LTRSPA,I=1,J),(LTRSTA,I=INIBFR,MAXUSE)
95 CONTINUE
C
C PACK THE LINE AS THOUGH READ BY 5A5 FORMAT
ENCODE(LMTPAC,96,LA5ONE)LTRONE
96 FORMAT(25A1)
C
C STORE THE LINE
IF(INCR.EQ.0)GO TO 99
IF(LINE.GE.LMTLIN)GO TO 104
LINE=LINE+1
ITIME(KOLUMN,LINE)=-1
IF(LINE.GT.MINLIN)ITIME(KOLUMN,LINE)=ITIME(KOLUMN,LINE-1)
JTIME(KOLUMN,LINE)=-1
IF(LINE.GT.MINLIN)JTIME(KOLUMN,LINE)=JTIME(KOLUMN,LINE-1)
IFBOLD(KOLUMN,LINE)=0
IF(IWEEK.EQ.1)GO TO 97
IF(IWEEK.EQ.7)GO TO 98
GO TO 99
97 KTIME(LINE)=1
GO TO 99
98 KTIME(LINE)=0
IF(KNDDAY.GE.9)KTIME(LINE)=2
99 IF(INCR.EQ.0)INCR=1
DO 100 J=1,LMTWRD
LA5ALL(KOLUMN,J,LINE)=LA5ONE(J)
100 CONTINUE
GO TO 37
C
C STORE BLANK LINE IF ONLY TIMESTAMP ON LINE
101 DO 102 J=1,LMTWRD
LA5ALL(KOLUMN,J,LINE)=' '
102 CONTINUE
GO TO 37
C
C CLOSE THE PROFILE FILE
103 CLOSE(UNIT=JDISK)
IPASS=1
KNDDAY=IWEEK
GO TO 35
C
C DONE READING THE SCHEDULE FILE
104 CLOSE(UNIT=IDISK)
IF(IPASS.EQ.0)GO TO 29
105 CONTINUE
LNGCLM(KOLUMN)=LINE
IF(LINE.GT.MAXLIN)MAXLIN=LINE
IF(IWEEK.EQ.7)GO TO 115
C
C SUMMARIZE
M=3*IWEEK
IF(KOLUMN.EQ.KLMEND)M=3*8
L=M-2
K=3*IMONTH
J=K-2
WRITE(ITTY,106)(LTRDAY(I),I=L,M),
1IDAY,(LWRMTH(I),I=J,K),IYEAR,LINE
106 FORMAT(' ',3A1,1X,1I2,'-',3A1,'-',1I4,', Lines:',1I5)
C
C SORT THE ITEMS FOR THIS COLUMN
IF(LINE.LE.0)GO TO 115
DO 114 IOUTER=1,LINE
KOMPAR=ITIME(KOLUMN,IOUTER)
LOWEST=IOUTER
DO 108 INNER=IOUTER,LINE
IF(ITIME(KOLUMN,INNER).GT.KOMPAR)GO TO 108
IF(ITIME(KOLUMN,INNER).LT.KOMPAR)GO TO 107
IF(JTIME(KOLUMN,INNER).GT.JTIME(KOLUMN,LOWEST))GO TO 108
IF(JTIME(KOLUMN,INNER).LT.JTIME(KOLUMN,LOWEST))GO TO 107
IF(KOLUMN.NE.KLMEND)GO TO 108
IF(KTIME(INNER).GE.KTIME(LOWEST))GO TO 108
107 KOMPAR=ITIME(KOLUMN,INNER)
LOWEST=INNER
108 CONTINUE
IF(LOWEST.LE.IOUTER)GO TO 114
ISAVE=ITIME(KOLUMN,LOWEST)
JSAVE=JTIME(KOLUMN,LOWEST)
IF(KOLUMN.EQ.KLMEND)KSAVE=KTIME(LOWEST)
LSAVE=IFBOLD(KOLUMN,LOWEST)
DO 109 I=1,LMTWRD
LA5ONE(I)=LA5ALL(KOLUMN,I,LOWEST)
109 CONTINUE
110 IF(LOWEST.LE.IOUTER)GO TO 112
ITIME(KOLUMN,LOWEST)=ITIME(KOLUMN,LOWEST-1)
JTIME(KOLUMN,LOWEST)=JTIME(KOLUMN,LOWEST-1)
IF(KOLUMN.EQ.KLMEND)KTIME(LOWEST)=KTIME(LOWEST-1)
IFBOLD(KOLUMN,LOWEST)=IFBOLD(KOLUMN,LOWEST-1)
DO 111 I=1,LMTWRD
LA5ALL(KOLUMN,I,LOWEST)=LA5ALL(KOLUMN,I,LOWEST-1)
111 CONTINUE
LOWEST=LOWEST-1
GO TO 110
112 ITIME(KOLUMN,LOWEST)=ISAVE
JTIME(KOLUMN,LOWEST)=JSAVE
IF(KOLUMN.EQ.KLMEND)KTIME(LOWEST)=KSAVE
IFBOLD(KOLUMN,LOWEST)=LSAVE
DO 113 I=1,LMTWRD
LA5ALL(KOLUMN,I,LOWEST)=LA5ONE(I)
113 CONTINUE
114 CONTINUE
115 ISMITH=ISMITH+1
MAXSHO=MAXSHO+1
LTRLIN(MAXSHO)=LTRSPA
IF(KOLUMN.NE.KLMEND)GO TO 125
IF(IWEEK.EQ.1)GO TO 125
IWEEK=1
GO TO 27
C
C *******************************************************
C * *
C * PACK FILE NAME SPECIFIED BY USER OR FILE AND OPEN *
C * *
C *******************************************************
C
116 MAXPRT=0
LOCDOT=0
LOCEND=0
DO 119 I=1,10
LTRFIL(I)=' '
IF(LOWPRF.LE.MAXPRF)LTRFIL(I)=LTRPRF(LOWPRF)
LOWPRF=LOWPRF+1
IF(LTRFIL(I).EQ.1H )GO TO 118
IF(LOCEND.NE.0)GO TO 124
MAXPRT=I
IF(LTRFIL(I).NE.1H.)GO TO 117
IF(LOCDOT.NE.0)GO TO 124
IF(I.GT.7)GO TO 124
LOCDOT=1
GO TO 119
117 IF(I.LT.7)GO TO 119
IF(LOCDOT.EQ.0)GO TO 124
GO TO 119
118 LOCEND=1
119 CONTINUE
IF(LOCDOT.EQ.0)LTRFIL(MAXPRT+1)='.'
GO TO(120,122,123),IFILE
120 ENCODE(10,121,FILOUT)LTRFIL
121 FORMAT(10A1)
C TTYSIM ON SOME SYSTEMS SPECIFIES THAT FILES WRITTEN
C ON UNIT GIVEN AS ARGUMENT HAVE LEFT CHARACTER IN EACH
C LINE CONVERTED DIRECTLY TO THE CARRIAGE CONTROL.
CALL TTYSIM(KDISK)
OPEN(UNIT=KDISK,FILE=FILOUT,ACCESS='SEQOUT',
1CARRIAGECONTROL='FORTRAN',ERR=20)
GO TO 24
122 ENCODE(10,121,FILINP)LTRFIL
OPEN(UNIT=IDISK,FILE=FILINP,ACCESS='SEQIN',ERR=33)
GO TO 36
123 ENCODE(10,121,FILINP)LTRFIL
OPEN(UNIT=IDISK,FILE=FILINP,ACCESS='SEQIN',ERR=105)
GO TO 36
C
C BRANCH TO ERROR MESSAGES IF ERROR IN FILE NAME
124 GO TO(22,31,105),IFILE
C
C **************************************************
C * *
C * ALL FILE DESCRIBING THIS WEEK HAVE BEEN READ *
C * *
C **************************************************
C
125 CONTINUE
C
C ************************
C * *
C * PRINT THE CALENDAR *
C * *
C ************************
C
C LABEL THE COLUMNS
IF(MAXLIN.LE.0)GO TO 178
WRITE(KDISK,126)
126 FORMAT(1H1)
OPEN(UNIT=IDISK,FILE='WEEKLY.TOP',ACCESS='SEQIN',ERR=133)
127 READ(IDISK,128,END=132)LTRTOP
128 FORMAT(158A1)
MAXTOP=LMTTOP
129 IF(LTRTOP(MAXTOP).NE.LTRSPA)GO TO 130
MAXTOP=MAXTOP-1
IF(MAXTOP.GT.1)GO TO 129
130 WRITE(KDISK,131)(LTRTOP(I),I=1,MAXTOP)
131 FORMAT(1X,158A1)
GO TO 127
132 CLOSE(UNIT=IDISK)
WRITE(KDISK,136)
133 WRITE(KDISK,134)
C 1'ABCDEFGHIJKLMLKJIHGFEDCBA ',
134 FORMAT(1H ,
1' Monday ',
2' Tuesday ',
3' Wednesday ',
4' Thursday ',
5' Friday ',
6' Saturday')
WRITE(KDISK,135)(LTRLIN(I),I=1,130)
135 FORMAT(1X,130A1,' and Sunday')
WRITE(KDISK,136)
136 FORMAT(1X)
C
C PREPARE TO CONSTRUCT NEXT LINE OF OUTPUT FILE
DO 137 KOLUMN=1,LMTCLM
NOWLIN(KOLUMN)=1
KLOSE(KOLUMN)=-1
137 CONTINUE
IWKEND=-1
INITIM=-1
LSTTIM=-1
C
C CHECK FOR LOWEST TIME NOT YET DISPLAYED
138 MINMUM=-1
DO 139 KOLUMN=1,LMTCLM
IF(NOWLIN(KOLUMN).GT.LNGCLM(KOLUMN))GO TO 139
LINE=NOWLIN(KOLUMN)
IF(ITIME(KOLUMN,LINE).LT.0)GO TO 139
IF(MINMUM.LT.0)MINMUM=ITIME(KOLUMN,LINE)
IF(MINMUM.GT.ITIME(KOLUMN,LINE))MINMUM=ITIME(KOLUMN,LINE)
139 CONTINUE
C
C WRITE RULE IF HOUR IS CHANGING
IF(INITIM.EQ.MINMUM)GO TO 145
IF(INITIM.GE.0)GO TO 140
IF(MINMUM.GE.0)GO TO 141
140 I=INITIM/100
J=MINMUM/100
IF(I.EQ.J)GO TO 145
141 IWIDTH=0
DO 143 KOLUMN=1,LMTCLM
DO 142 I=1,LMTPAC
IWIDTH=IWIDTH+1
LTRLIN(IWIDTH)='-'
142 CONTINUE
IWIDTH=IWIDTH+1
LTRLIN(IWIDTH)='+'
143 CONTINUE
WRITE(KDISK,144)(LTRLIN(I),I=1,IWIDTH)
144 FORMAT(1X,'+',182A1)
145 IF(MINMUM.LT.0)GO TO 178
C
C CHECK IF ITEM IN COLUMN GOES ON LINE NOW
IWIDTH=0
DO 165 KOLUMN=1,LMTCLM
NOWCLM=5*(KOLUMN-1)
LINE=NOWLIN(KOLUMN)
LSTTIM=-1
IF(LNGCLM(KOLUMN).LT.LINE)GO TO 162
IF(ITIME(KOLUMN,LINE).GT.MINMUM)GO TO 162
C
C INSERT TIME STAMP INTO CURRENT LINE
IF(ITIME(KOLUMN,LINE).LT.0)GO TO 158
IF(INITIM.NE.MINMUM)GO TO 146
IF(KLOSE(KOLUMN).NE.JTIME(KOLUMN,LINE))GO TO 146
IF(KOLUMN.NE.KLMEND)GO TO 158
IF(IWKEND.NE.KTIME(LINE))GO TO 146
GO TO 158
146 KLOSE(KOLUMN)=JTIME(KOLUMN,LINE)
IF(KOLUMN.EQ.KLMEND)IWKEND=KTIME(LINE)
LTIME=ITIME(KOLUMN,LINE)
KOLON=IWIDTH+2
JPASS=0
147 J=LTIME
IF(J.LT.100)J=J+1200
IF(J.GE.1300)J=J-1200
IF(J.GE.1300)J=J-1200
IF(J.GE.1000)KOLON=KOLON+1
I=KOLON+2
148 K=J/10
J=J-(10*K)
LTRLIN(I)=LTRDGT(J+1)
J=K
I=I-1
IF(I.EQ.KOLON)I=KOLON-1
IF(J.GT.0)GO TO 148
IF(I.GT.(KOLON-2))GO TO 148
LTRLIN(KOLON)=':'
IF(JPASS.NE.0)GO TO 149
IF(JTIME(KOLUMN,LINE).LT.0)GO TO 149
LTRLIN(KOLON+3)='-'
LTIME=JTIME(KOLUMN,LINE)
KOLON=KOLON+5
JPASS=1
GO TO 147
149 KOLON=KOLON+2
LTRLIN(KOLON+1)=LTRSPA
KOLON=KOLON+1
IF(LTIME.GT.2400)LTIME=LTIME-2400
IF(LTIME.GT.1200)GO TO 151
IF(LTIME.EQ.1200)GO TO 150
LTRLIN(KOLON+1)='a'
LTRLIN(KOLON+2)='m'
KOLON=KOLON+2
GO TO 152
150 LTRLIN(KOLON+1)='m'
KOLON=KOLON+1
GO TO 152
151 LTRLIN(KOLON+1)='p'
LTRLIN(KOLON+2)='m'
KOLON=KOLON+2
GO TO 152
152 IF(KOLUMN.NE.KLMEND)GO TO 156
I=0
K=0
153 IF(I.GT.KTIME(LINE))GO TO 154
I=I+1
J=K+1
K=K+LNGEND(I)
GO TO 153
154 DO 155 I=J,K
KOLON=KOLON+1
LTRLIN(KOLON)=LTREND(I)
155 CONTINUE
156 DO 157 I=1,LMTPAC
IWIDTH=IWIDTH+1
IF(IWIDTH.GT.KOLON)LTRLIN(IWIDTH)=' '
157 CONTINUE
JFBOLD(KOLUMN)=0
GO TO 164
C
C ADD A SCHEDULE ITEM TO THE OUTPUT LINE
158 DO 159 I=1,LMTWRD
LA5ONE(I)=LA5ALL(KOLUMN,I,LINE)
159 CONTINUE
DECODE(LMTPAC,160,LA5ONE)LTRONE
160 FORMAT(25A1)
DO 161 I=1,LMTPAC
IWIDTH=IWIDTH+1
LTRLIN(IWIDTH)=LTRONE(I)
161 CONTINUE
KLOSE(KOLUMN)=JTIME(KOLUMN,LINE)
IF(KOLUMN.EQ.KLMEND)IWKEND=KTIME(LINE)
JFBOLD(KOLUMN)=IFBOLD(KOLUMN,LINE)
LINE=LINE+1
NOWLIN(KOLUMN)=LINE
GO TO 164
C
C INSERT BLANKS IF NEXT TIME STAMP BEYOND CURRENT
162 DO 163 I=1,LMTPAC
IWIDTH=IWIDTH+1
LTRLIN(IWIDTH)=' '
163 CONTINUE
JFBOLD(KOLUMN)=0
C
C INSERT SINGLE RULING BETWEEN COLUMNS
164 IWIDTH=IWIDTH+1
LTRLIN(IWIDTH)='|'
165 CONTINUE
INITIM=MINMUM
C
C WRITE LINE TO OUTPUT FILE
WRITE(KDISK,166)(LTRLIN(I),I=1,IWIDTH)
166 FORMAT(1X,'|',182A1)
IWIDTH=0
MAXBLD=0
DO 173 KOLUMN=1,LMTCLM
C IF(JFBOLD(KOLUMN).LT.0)GO TO 1640
IF(JFBOLD(KOLUMN).GT.0)GO TO 170
DO 167 I=1,LMTPAC
IWIDTH=IWIDTH+1
LTRLIN(IWIDTH)=LTRSPA
167 CONTINUE
GO TO 172
168 JDARK=1
DO 169 I=1,LMTPAC
IWIDTH=IWIDTH+1
IF(LTRLIN(IWIDTH).EQ.1H,)JDARK=0
IF(JDARK.EQ.0)LTRLIN(IWIDTH)=LTRSPA
IF(LTRLIN(IWIDTH).NE.LTRSPA)MAXBLD=IWIDTH
169 CONTINUE
GO TO 172
170 DO 171 I=1,LMTPAC
IWIDTH=IWIDTH+1
IF(LTRLIN(IWIDTH).NE.LTRSPA)MAXBLD=IWIDTH
171 CONTINUE
172 IWIDTH=IWIDTH+1
LTRLIN(IWIDTH)=LTRSPA
173 CONTINUE
IF(MAXBLD.LE.0)GO TO 177
IF(KNDDRK.NE.0)GO TO 175
C BOLDFACE ON DECWRITER (MATRIX) PRINTER
WRITE(KDISK,174)(LTRLIN(I),I=1,MAXBLD)
WRITE(KDISK,174)(LTRLIN(I),I=1,MAXBLD)
WRITE(KDISK,174)(LTRLIN(I),I=1,MAXBLD)
WRITE(KDISK,174)(LTRLIN(I),I=1,MAXBLD)
174 FORMAT('+ ',182A1)
GO TO 177
C BOLDFACE ON DIABLO (PRECISION) PRINTER
175 WRITE(KDISK,176)(LTRLIN(I),I=1,MAXBLD)
WRITE(KDISK,176)LTRDRK,(LTRLIN(I),I=1,MAXBLD)
176 FORMAT('+ ',182A1)
177 GO TO 138
C
C ALL DONE PROCESSING FILES
178 CONTINUE
WRITE(KDISK,179)
179 FORMAT('1')
CLOSE(UNIT=KDISK)
WRITE(ITTY,180)
180 FORMAT(1X)
C
C CALENDAR COMPLETED
181 STOP
END
SUBROUTINE PROFIL(IWHICH,ISMITH,ITTY,JDISK,
1LMTPRF,LTRPRF,LOWPRF,MAXPRF,KNDDAY)
C RENBR(/FIND LINE IN PROFILE FOR DESIRED DATE)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C IWHICH = SHOULD BE SET TO ZERO BEFORE THIS ROUTINE IS
C FIRST CALLED FOR A NEW DATE. THEREAFTER, IWHICH
C SHOULD BE SENT BACK TO THIS ROUTINE UNCHANGED
C UNTIL IT IS RETURNED AGAIN SET TO ZERO.
C IWHICH = 0 RETURNED, IF END-OF-FILE WAS READ. DO NOT
C CALL THIS ROUTINE AGAIN FOR THIS DATE.
C = 1 RETURNED, IF RETURNING FILE SPECIFICATION
C FOR A SPECIAL SCHEDULE, BUT NO REGULAR
C SCHEDULE HAS YET BEEN FOUND FOR THIS DATE.
C = 2 RETURNED, IF RETURNING FILE SPECIFICATION
C FOR A SPECIAL SCHEDULE, AND A REGULAR
C SCHEDULE WAS FOUND EARLIER FOR THIS DATE.
C NOTE THAT THIS DOES NOT MEAN THAT THIS ROUTINE
C ACTUALLY RETURNED AN ITEM IN A REGULAR
C SCHEDULE FOR THE DESIRED DATE, SINCE THE REGULAR
C SCHEDULE FOR THIS DATE MIGHT HAVE NEGLECTED TO
C DEFINE A FILE SPECIFICATION FOR THE CORRESPONDING
C DAY OF THE WEEK AND SO WAS HANDLED INTERNALLY.
C = 3 RETURNED, IF RETURNING A REGULAR SCHEDULE.
C ISMITH = INPUT CONTAINING DESIRED SMITHSONIAN DATE
C IWEEK = DAY OF WEEK, 1=SUNDAY, 7=SATURDAY
C ITTY = UNIT NUMBER ON WHICH TO WRITE ERROR MESSAGES.
C JDISK = UNIT NUMBER FROM WHICH TO READ PROFILE FILE.
C LMTPRF = DIMENSION OF LTRPRF ARRAY IN WHICH THE LINE
C OF THE FILE FOR DESIRED DATE IS RETURNED
C LTRPRF = RETURNED CONTAINING THE TEXT OF THE LINE FOUND FOR
C THE DESIRED DATE.
C LOWPRF = RETURNED POINTING TO FIRST PRINTING CHARACTER TO
C RIGHT OF DAY OF WEEK NAME IN TEXT RETURNED IN LTRPRF.
C MAXPRF = RETURNED POINTING TO RIGHTMOST PRINTING CHARACTER
C IN LTRPRF ARRAY, EXCLUDING COMMENT IF ANY.
C KNDDAY = RETURNED IDENTIFYING WORD WHICH APPEARS AT START
C OF LINE CONTAINING FILE SPECIFICATION
C = 1 THRU 7, SUNDAY: THRU SATURDAY:
C = WEEKDAY:
C = WEEKEND:
C = ALL:
C
DIMENSION LTRCMD(104),LWRCMD(104),LTRPRF(LMTPRF),LNGCMD(13),
1LTRTO(19),LWRTO(19),LNGTO(6)
DATA LTRCMD/
11HS,1HU,1HN,1HD,1HA,1HY,1H:,
21HM,1HO,1HN,1HD,1HA,1HY,1H:,
31HT,1HU,1HE,1HS,1HD,1HA,1HY,1H:,
41HW,1HE,1HD,1HN,1HE,1HS,1HD,1HA,1HY,1H:,
51HT,1HH,1HU,1HR,1HS,1HD,1HA,1HY,1H:,
61HF,1HR,1HI,1HD,1HA,1HY,1H:,
71HS,1HA,1HT,1HU,1HR,1HD,1HA,1HY,1H:,
81HW,1HE,1HE,1HK,1HD,1HA,1HY,1H:,
91HW,1HE,1HE,1HK,1HE,1HN,1HD,1H:,
11HA,1HL,1HL,1H:,
21HR,1HE,1HG,1HU,1HL,1HA,1HR,1H:,
31HS,1HP,1HE,1HC,1HI,1HA,1HL,1H:,
41HE,1HN,1HD,1H-,1HO,1HF,1H-,1HF,1HI,1HL,1HE/
DATA LWRCMD/
11Hs,1Hu,1Hn,1Hd,1Ha,1Hy,1H:,
21Hm,1Ho,1Hn,1Hd,1Ha,1Hy,1H:,
31Ht,1Hu,1He,1Hs,1Hd,1Ha,1Hy,1H:,
41Hw,1He,1Hd,1Hn,1He,1Hs,1Hd,1Ha,1Hy,1H:,
51Ht,1Hh,1Hu,1Hr,1Hs,1Hd,1Ha,1Hy,1H:,
61Hf,1Hr,1Hi,1Hd,1Ha,1Hy,1H:,
71Hs,1Ha,1Ht,1Hu,1Hr,1Hd,1Ha,1Hy,1H:,
81Hw,1He,1He,1Hk,1Hd,1Ha,1Hy,1H:,
91Hw,1He,1He,1Hk,1He,1Hn,1Hd,1H:,
11Ha,1Hl,1Hl,1H:,
21Hr,1He,1Hg,1Hu,1Hl,1Ha,1Hr,1H:,
31Hs,1Hp,1He,1Hc,1Hi,1Ha,1Hl,1H:,
41He,1Hn,1Hd,1H-,1Ho,1Hf,1H-,1Hf,1Hi,1Hl,1He/
DATA LNGCMD/7,7,8,10,9,7,9,8,8,4,8,8,11/
DATA LMTCMD/13/
C
C DATE SEPARATOR WORDS
DATA LTRTO/
11HT,1HO,
21HT,1HH,1HR,1HU,
31HT,1HH,1HR,1HO,1HU,1HG,1HH,
41HA,1HN,1HD,
51HO,1HR,
61H,/
DATA LWRTO/
11Ht,1Ho,
21Ht,1Hh,1Hr,1Hu,
31Ht,1Hh,1Hr,1Ho,1Hu,1Hg,1Hh,
41Ha,1Hn,1Hd,
51Ho,1Hr,
61H,/
DATA LNGTO/2,4,7,3,2,1/
DATA LMTTO/6/
C
C LTREXC = THE EXCLAMATION POINT USED TO INDICATE THAT
C THE REST OF THE LINE IS A COMMENT TO BE IGNORED
C LTRSPA = THE SPACE CHARACTER
DATA LTREXC,LTRSPA,LTRCOM/1H!,1H ,1H,/
C
C DETERMINE WHICH DAY OF WEEK CORRESPONDS TO DATE
CALL DAWEEK(-1,ISMITH,IDAY,IMONTH,IYEAR,IWEEK)
C
C INDICATE IF CONTINUING PREVIOUS SPECIAL OR REGULAR SCHEDULE
IRANGE=0
IF(IWHICH.EQ.1)IRANGE=-1
IF(IWHICH.EQ.2)IRANGE=-1
IF(IWHICH.EQ.3)IRANGE=1
C
C READ NEXT LINE FROM FILE
1 READ(JDISK,2,END=32)LTRPRF
2 FORMAT(80A1)
C
C FIND RIGHTMOST PRINTING CHARACTER
MAXPRT=LMTPRF
3 IF(MAXPRT.LE.0)GO TO 1
IF(LTRPRF(MAXPRT).NE.LTRSPA)GO TO 4
MAXPRT=MAXPRT-1
GO TO 3
C
C LOOK FOR INITIAL KEYWORD
4 ICHECK=0
5 ICHECK=ICHECK+1
IF(ICHECK.GT.MAXPRT)GO TO 1
IF(LTRPRF(ICHECK).EQ.LTRSPA)GO TO 5
IF(LTRPRF(ICHECK).EQ.LTREXC)GO TO 1
KOMAND=0
ICHECK=ICHECK-1
KCHECK=0
6 KOMAND=KOMAND+1
IF(KOMAND.GT.LMTCMD)GO TO 20
JCHECK=ICHECK
LCHECK=KCHECK
KCHECK=KCHECK+LNGCMD(KOMAND)
7 LCHECK=LCHECK+1
JCHECK=JCHECK+1
IF(LCHECK.GT.KCHECK)GO TO 8
IF(JCHECK.GT.MAXPRT)GO TO 6
IF(LTRCMD(LCHECK).EQ.LTRPRF(JCHECK))GO TO 7
IF(LWRCMD(LCHECK).EQ.LTRPRF(JCHECK))GO TO 7
GO TO 6
C
C DETERMINE WHETHER DATE RANGE IS ALLOWED
8 IF(KOMAND.EQ.13)GO TO 32
IF(KOMAND.LE.10)GO TO 22
IF(IRANGE.GT.0)IWHICH=2
IRANGE=0
IF(IWHICH.LE.1)GO TO 9
IF(KOMAND.EQ.11)GO TO 1
C
C GET FIRST DATE IN DATE RANGE
9 LOWPRF=JCHECK
KPASS=0
C
C EVALUATE DATE
10 CALL DADATE(1,LTRPRF,LMTPRF,LOWPRF,KIND,
1IDAY,IMONTH,IYEAR,LCNBFR)
IF(KIND.LE.3)GO TO 20
IF(KIND.GE.18)GO TO 20
IF(IDAY.LT.0)GO TO 20
IF(IMONTH.LT.0)GO TO 20
IF(IYEAR.LT.0)GO TO 20
IF(IYEAR.LE.80)IYEAR=IYEAR+2000
IF(IYEAR.LT.100)IYEAR=IYEAR+1900
CALL DAWEEK(0,KSMITH,IDAY,IMONTH,IYEAR,JWEEK)
IF(KPASS.NE.0)GO TO 18
KPASS=1
C
C LOOK FOR SEPARATING WORDS TO, THROUGH, AND, COMMA
11 JSMITH=KSMITH
ICHECK=LOWPRF-1
12 ICHECK=ICHECK+1
IF(ICHECK.GT.MAXPRT)GO TO 16
IF(LTRPRF(ICHECK).EQ.LTRSPA)GO TO 12
IF(LTRPRF(ICHECK).EQ.LTREXC)GO TO 16
KMDTO=0
ICHECK=ICHECK-1
KCHECK=0
13 KMDTO=KMDTO+1
IF(KMDTO.GT.LMTTO)GO TO 17
JCHECK=ICHECK
LCHECK=KCHECK
KCHECK=KCHECK+LNGTO(KMDTO)
14 LCHECK=LCHECK+1
JCHECK=JCHECK+1
IF(LCHECK.GT.KCHECK)GO TO 15
IF(JCHECK.GT.MAXPRT)GO TO 13
IF(LTRTO(LCHECK).EQ.LTRPRF(JCHECK))GO TO 14
IF(LWRTO(LCHECK).EQ.LTRPRF(JCHECK))GO TO 14
GO TO 13
15 LOWPRF=JCHECK
GO TO(10,10,10,18,18,18),KMDTO
C
C CHECK IF DESIRED DATE IS IN INDICATED RANGE
16 LOWPRF=MAXPRT+1
17 KPASS=0
18 IF(ISMITH.LT.JSMITH)GO TO 19
IF(ISMITH.GT.KSMITH)GO TO 19
IRANGE=1
IF(KOMAND.EQ.12)IRANGE=-1
GO TO 1
19 IF(LOWPRF.GT.MAXPRT)GO TO 1
IF(KPASS.EQ.0)GO TO 10
GO TO 11
C
C ERROR IN PROFILE FILE
20 WRITE(ITTY,21)(LTRPRF(I),I=1,MAXPRT)
21 FORMAT(
1' Calendar profile contains following unrecognizable line:'/
21X,80A1)
GO TO 1
C
C RETURN THE TEXT TO RIGHT OF DAY OF WEEK NAME
22 IF(IRANGE.EQ.0)GO TO 1
IF(KOMAND.LE.7)GO TO 25
IF(KOMAND.EQ.8)GO TO 23
IF(KOMAND.EQ.9)GO TO 24
C ALL:
GO TO 26
C WEEKDAYS:
23 IF(IWEEK.EQ.1)GO TO 1
IF(IWEEK.EQ.7)GO TO 1
GO TO 26
C WEEKEND:
24 IF(IWEEK.EQ.1)GO TO 26
IF(IWEEK.EQ.7)GO TO 26
GO TO 1
C SPECIFIC DAY
25 IF(KOMAND.NE.IWEEK)GO TO 1
26 LOWPRF=JCHECK
27 IF(LOWPRF.GT.MAXPRT)GO TO 1
IF(LTRPRF(LOWPRF).EQ.LTREXC)GO TO 1
IF(LTRPRF(LOWPRF).NE.LTRSPA)GO TO 28
LOWPRF=LOWPRF+1
GO TO 27
28 MAXPRF=LOWPRF
29 MAXPRF=MAXPRF+1
IF(MAXPRF.GT.MAXPRT)GO TO 30
IF(LTRPRF(MAXPRF).NE.LTREXC)GO TO 29
30 MAXPRF=MAXPRF-1
IF(LTRPRF(MAXPRF).EQ.LTRSPA)GO TO 30
KNDDAY=KOMAND
IF(IRANGE.LT.0)GO TO 31
IWHICH=3
GO TO 33
31 IF(IWHICH.EQ.0)IWHICH=1
IF(IWHICH.EQ.3)IWHICH=2
GO TO 33
C
C END-OF-FILE READ
32 IWHICH=0
C
C RETURN TO CALLING PROGRAM
33 RETURN
END
SUBROUTINE DADATE(IALLOW,IBUFFR,MAXBFR,LOWBFR,KIND ,
1 IDAY ,IMONTH,IYEAR ,LCNBFR)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C IALLOW = 0, ACCEPT NUMBER, DATE, TIME OR DAY OF WEEK.
C SINGLE NUMBER IS RETURNED IN IYEAR
C = 1, ACCEPT NUMBER OR DATE ONLY.
C SINGLE NUMBER IS RETURNED IN IYEAR
C = 2, ACCEPT NUMBER OR TIME ONLY.
C SINGLE NUMBER IS RETURNED IN IDAY
C = 3, ACCEPT DAY OF WEEK ONLY
C KIND = 1, NOTHING FOUND
C = 2, UNKNOWN ITEM
C = 3, SINGLE NUMBER
C = 4, OCTOBER
C = 5, 20 OCTOBER
C = 6, 20-OCTOBER OR 20/OCTOBER
C = 7, 10-20 OR 10/20
C = 8, OCTOBER 20
C = 9, OCTOBER-20 OR OCTOBER/20
C = 10, OCTOBER,81
C = 11, 20 OCTOBER 81
C = 12, 20 OCTOBER,81
C = 13, 20-OCT-81 OR 20/OCT/81
C = 14, 10-20-81 OR 10/20/81
C = 15, OCTOBER 20 81
C = 16, OCTOBER 20, 81
C = 17, OCTOBER-20-81 OR OCTOBER/20/81
C = 18, 11:00
C = 19, AM OR PM OR NOON OR MIDNIGHT
C = 20, 11 AM OR 11 PM OR 12 NOON OR 12 MIDNIGHT
C = 21, 11:00 AM OR 11:00 PM OR 12:00 NOON
C OR 12:00 MIDNIGHT
C = 22, SATURDAY
C IDAY = IF DATE, RETURNED WITH DAY OF MONTH
C = IF NAME OF DAY, 1 IF SUNDAY, 7 IF SATURDAY
C = IF TIME, RETURNED WITH HOUR
C = IF NUMBER AND IALLOW IS 2, RETURND WITH VALUE
C IMONTH = IF DATE, 1 IF JANUARY, 12 IF DECEMBER
C = IF TIME, RETURNED WITH MINUTES
C IYEAR = IF DATE, RETURNED WITH YEAR
C = IF TIME, 1 IF AM, 2 IF PM, 3 IF M OR NOON,
C 4 IF MIDNIGHT
C = IF NUMBER AND IALLOW IS 0 OR 1, RETURND WITH VALUE
C
DIMENSION LTRMTH(151),LWRMTH(151),LNGMTH(27),LTRDGT(10),
1IBUFFR(MAXBFR)
DATA LTRMTH/1HJ,1HA,1HN,1HU,1HA,1HR,1HY, 1HF,1HE,
11HB,1HR,1HU,1HA,1HR,1HY, 1HM,1HA,1HR,1HC,1HH,1HA,
21HP,1HR,1HI,1HL, 1HM,1HA,1HY, 1HJ,1HU,1HN,1HE,
3 1HJ,1HU,1HL,1HY, 1HA,1HU,1HG,1HU,1HS,1HT,
41HS,1HE,1HP,1HT,1HE,1HM,1HB,1HE,1HR, 1HO,1HC,1HT,
51HO,1HB,1HE,1HR, 1HN,1HO,1HV,1HE,1HM,1HB,1HE,1HR,
6 1HD,1HE,1HC,1HE,1HM,1HB,1HE,1HR, 1HA,1HM,
71HP,1HM, 1HN,1HO,1HO,1HN, 1HM,1HI,1HD,1HN,1HI,
81HG,1HH,1HT, 1HA,1H.,1HM,1H., 1HP,1H.,1HM,1H.,
9 1HM,1H., 1HM, 1HS,1HU,1HN,1HD,1HA,1HY,
11HM,1HO,1HN,1HD,1HA,1HY, 1HT,1HU,1HE,1HS,1HD,1HA,
21HY, 1HW,1HE,1HD,1HN,1HE,1HS,1HD,1HA,1HY, 1HT,
31HH,1HU,1HR,1HS,1HD,1HA,1HY, 1HF,1HR,1HI,1HD,1HA,
41HY, 1HS,1HA,1HT,1HU,1HR,1HD,1HA,1HY/
DATA LWRMTH/1Hj,1Ha,1Hn,1Hu,1Ha,1Hr,1Hy, 1Hf,1He,
11Hb,1Hr,1Hu,1Ha,1Hr,1Hy, 1Hm,1Ha,1Hr,1Hc,1Hh,1Ha,
21Hp,1Hr,1Hi,1Hl, 1Hm,1Ha,1Hy, 1Hj,1Hu,1Hn,1He,
3 1Hj,1Hu,1Hl,1Hy, 1Ha,1Hu,1Hg,1Hu,1Hs,1Ht,
41Hs,1He,1Hp,1Ht,1He,1Hm,1Hb,1He,1Hr, 1Ho,1Hc,1Ht,
51Ho,1Hb,1He,1Hr, 1Hn,1Ho,1Hv,1He,1Hm,1Hb,1He,1Hr,
6 1Hd,1He,1Hc,1He,1Hm,1Hb,1He,1Hr, 1Ha,1Hm,
71Hp,1Hm, 1Hn,1Ho,1Ho,1Hn, 1Hm,1Hi,1Hd,1Hn,1Hi,
81Hg,1Hh,1Ht, 1Ha,1H.,1Hm,1H., 1Hp,1H.,1Hm,1H.,
9 1Hm,1H., 1Hm, 1Hs,1Hu,1Hn,1Hd,1Ha,1Hy,
11Hm,1Ho,1Hn,1Hd,1Ha,1Hy, 1Ht,1Hu,1He,1Hs,1Hd,1Ha,
21Hy, 1Hw,1He,1Hd,1Hn,1He,1Hs,1Hd,1Ha,1Hy, 1Ht,
31Hh,1Hu,1Hr,1Hs,1Hd,1Ha,1Hy, 1Hf,1Hr,1Hi,1Hd,1Ha,
41Hy, 1Hs,1Ha,1Ht,1Hu,1Hr,1Hd,1Ha,1Hy/
DATA LNGMTH/7,8,5,5,3,4,4,6,9,7,8,8,
12,2,4,8,4,4,2,1,
26,6,7,9,8,6,8/
C INISFX = SUBSCRIPT IN LTRMTH OF START OF SUFFIXES
C INIDAY = SUBSCRIPT IN LTRMTH OF START OF DAY NAMES
C LMTMTH = SUBSCRIPT IN LNGMTH OF END OF MONTH NAME LENGTHS
C LMTMTH = SUBSCRIPT IN LNGMTH OF END OF SUFFIX LENGTHS
C LMTMTH = SUBSCRIPT IN LNGMTH OF END OF DAY NAME LENGTHS
DATA INISFX,INIDAY/74,101/
DATA LMTMTH,LMTSFX,LMTDAY/12,20,27/
C
DATA LTRDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA ITAB/"045004020100/
DATA IBLANK/1H /
DATA IMINUS,ISLASH,ICOMMA,ICOLON/1H-,1H/,1H,,1H:/
C
C SEARCH FOR FIRST PRINTING CHARACTER
IDAY=-1
IMONTH=-1
IYEAR=-1
KIND=1
GO TO 2
1 LOWBFR=LOWBFR+1
2 IF(LOWBFR.GT.MAXBFR)GO TO 65
NOWLTR=IBUFFR(LOWBFR)
IF(NOWLTR.EQ.IBLANK)GO TO 1
IF(NOWLTR.EQ.ITAB)GO TO 1
LCNBFR=LOWBFR
NOWBFR=LOWBFR
C
C TEST FOR LEADING NUMBER
IFIRST=0
ISECON=0
ITHIRD=0
KIND=2
ISEPAR=0
IF(IALLOW.EQ.3)GO TO 16
GO TO 4
3 NOWBFR=NOWBFR+1
LSTBFR=NOWBFR
IF(NOWBFR.GT.MAXBFR)GO TO 46
NOWLTR=IBUFFR(NOWBFR)
4 DO 5 I=1,10
IF(NOWLTR.NE.LTRDGT(I))GO TO 5
IFIRST=(10*IFIRST)+I-1
KIND=3
GO TO 3
5 CONTINUE
IF(KIND.EQ.2)GO TO 13
C
C LOOK FOR SLASH OR MINUS AFTER NUMBER
IF(IALLOW.EQ.2)GO TO 8
IF(NOWLTR.NE.IMINUS)GO TO 6
ISEPAR=1
GO TO 7
6 IF(NOWLTR.NE.ISLASH)GO TO 8
ISEPAR=2
7 NOWBFR=NOWBFR+1
GO TO 13
8 IF(IALLOW.EQ.1)GO TO 12
IF(NOWLTR.NE.ICOLON)GO TO 12
C
C LOOK FOR NUMBER AFTER COLON
KIND=18
IDAY=IFIRST
9 NOWBFR=NOWBFR+1
LSTBFR=NOWBFR
IF(NOWBFR.GT.MAXBFR)GO TO 46
NOWLTR=IBUFFR(NOWBFR)
DO 10 I=1,10
IF(NOWLTR.NE.LTRDGT(I))GO TO 10
ISECON=(10*ISECON)+I-1
IMONTH=ISECON
GO TO 9
10 CONTINUE
GO TO 12
C
C LOOK FOR FIRST PRINTING CHARACTER AFTER NUMBER
11 NOWBFR=NOWBFR+1
IF(NOWBFR.GT.MAXBFR)GO TO 46
NOWLTR=IBUFFR(NOWBFR)
12 IF(NOWLTR.EQ.IBLANK)GO TO 11
IF(NOWLTR.EQ.ITAB)GO TO 11
C
C LOOK FOR ALPHABETIC WORD
C NO NUMBER = LOOK FOR ANY WORD
C NUMBER = LOOK FOR MONTH OR AM OR A.M.
C NUMBER SLASH = LOOK FOR MONTH
C NUMBER COLON = LOOK FOR AM OR A.M.
13 IF(IALLOW.EQ.2)GO TO 15
ITEST=0
ILOOP=1
JLOOP=LMTDAY
IF(IALLOW.EQ.1)GO TO 14
IF(KIND.EQ.2)GO TO 17
IF(KIND.EQ.18)GO TO 15
IF(ISEPAR.NE.0)GO TO 14
ILOOP=1
JLOOP=LMTSFX
GO TO 17
14 ILOOP=1
JLOOP=LMTMTH
GO TO 17
15 ILOOP=LMTMTH+1
JLOOP=LMTSFX
ITEST=INISFX
GO TO 17
16 ILOOP=LMTSFX+1
JLOOP=LMTDAY
ITEST=INIDAY
17 LONGER=0
IUNIQU=0
JUNIQU=0
DO 23 JTEST=ILOOP,JLOOP
MATCHD=0
KTEST=ITEST
ITEST=ITEST+LNGMTH(JTEST)
LTEST=NOWBFR
18 KTEST=KTEST+1
IF(KTEST.GT.ITEST)GO TO 23
IF(LTRMTH(KTEST).EQ.IBUFFR(LTEST))GO TO 19
IF(LWRMTH(KTEST).EQ.IBUFFR(LTEST))GO TO 19
GO TO 23
19 MATCHD=MATCHD+1
IF(MATCHD.LT.LONGER)GO TO 22
IF(MATCHD.GT.LONGER)GO TO 20
IF(KTEST.LT.ITEST)GO TO 21
20 LONGER=MATCHD
IUNIQU=JTEST
JUNIQU=ITEST-KTEST
GO TO 22
21 IF(JUNIQU.NE.0)IUNIQU=0
22 LTEST=LTEST+1
IF(LTEST.LE.MAXBFR)GO TO 18
23 CONTINUE
IF(IUNIQU.NE.0)GO TO 24
IF(KIND.EQ.2)GO TO 65
IF(KIND.EQ.18)GO TO 64
IF(ISEPAR.NE.0)GO TO 34
GO TO 46
24 NOWBFR=NOWBFR+LONGER
LSTBFR=NOWBFR
IF(KIND.EQ.2)GO TO 26
IF(IUNIQU.LE.LMTMTH)GO TO 25
IF(KIND.EQ.18)GO TO 61
GO TO 60
25 KIND=5
ISECON=IUNIQU
GO TO 36
26 IF(IUNIQU.LE.LMTMTH)GO TO 27
IF(IUNIQU.LE.LMTSFX)GO TO 59
GO TO 62
27 KIND=4
IFIRST=IUNIQU
C
C LOOK FOR / OR - IMMEDIATELY AFTER MONTH NAME
IF(IBUFFR(NOWBFR).NE.IMINUS)GO TO 28
ISEPAR=1
GO TO 29
28 IF(IBUFFR(NOWBFR).NE.ISLASH)GO TO 30
ISEPAR=2
29 NOWBFR=NOWBFR+1
IF(KIND.EQ.5)GO TO 44
GO TO 34
30 IF(ISEPAR.NE.0)GO TO 46
GO TO 32
C
C SEARCH FOR FIRST PRINTING CHARACTER AFTER MONTH
31 NOWBFR=NOWBFR+1
32 IF(NOWBFR.GT.MAXBFR)GO TO 46
NOWLTR=IBUFFR(NOWBFR)
IF(NOWLTR.EQ.IBLANK)GO TO 31
IF(NOWLTR.EQ.ITAB)GO TO 31
GO TO 34
C
C LOOK FOR SECOND NUMBER AFTER NUMBER- OR NUMBER/
33 NOWBFR=NOWBFR+1
LSTBFR=NOWBFR
34 IF(NOWBFR.GT.MAXBFR)GO TO 46
NOWLTR=IBUFFR(NOWBFR)
DO 35 I=1,10
IF(NOWLTR.NE.LTRDGT(I))GO TO 35
ISECON=(10*ISECON)+I-1
IF(KIND.EQ.3)KIND=7
IF(KIND.EQ.4)KIND=8
GO TO 33
35 CONTINUE
C KIND = 3, NUMBER/
C = 4, OCT OR OCT/
C = 7, 20/10
C = 8, OCT 20 OR OCT/20
IF(KIND.EQ.7)GO TO 37
IF(KIND.EQ.8)GO TO 36
IF(KIND.EQ.3)GO TO 46
IF(ISEPAR.NE.0)GO TO 46
GO TO 41
C
C LOOK FOR / OR - AFTER SECOND NUMBER
36 IF(ISEPAR.EQ.0)GO TO 41
37 IF(ISEPAR.NE.1)GO TO 38
IF(IBUFFR(NOWBFR).NE.IMINUS)GO TO 46
GO TO 39
38 IF(ISEPAR.NE.2)GO TO 46
IF(IBUFFR(NOWBFR).NE.ISLASH)GO TO 46
39 NOWBFR=NOWBFR+1
GO TO 44
C
C LOOK FOR COMMA AFTER MONTH NAME AND NUMBER
40 NOWBFR=NOWBFR+1
41 IF(NOWBFR.GT.MAXBFR)GO TO 46
NOWLTR=IBUFFR(NOWBFR)
IF(NOWLTR.EQ.IBLANK)GO TO 40
IF(NOWLTR.EQ.ITAB)GO TO 40
IF(NOWLTR.NE.ICOMMA)GO TO 44
ISEPAR=-1
C
C LOOK FOR FIRST PRINTING CHARACTER AFTER COMMA AFTER MONTH
42 NOWBFR=NOWBFR+1
IF(NOWBFR.GT.MAXBFR)GO TO 46
NOWLTR=IBUFFR(NOWBFR)
IF(NOWLTR.EQ.IBLANK)GO TO 42
IF(NOWLTR.EQ.ITAB)GO TO 42
GO TO 44
C
C LOOK FOR 3RD NUMBER
43 NOWBFR=NOWBFR+1
LSTBFR=NOWBFR
44 IF(NOWBFR.GT.MAXBFR)GO TO 46
NOWLTR=IBUFFR(NOWBFR)
DO 45 I=1,10
IF(NOWLTR.NE.LTRDGT(I))GO TO 45
ITHIRD=(10*ITHIRD)+I-1
IF(KIND.EQ.4)KIND=10
IF(KIND.EQ.7)KIND=14
IF(KIND.EQ.5)KIND=11
IF(KIND.EQ.8)KIND=15
GO TO 43
45 CONTINUE
C
C DATE COMPLETED
C
C DIAGONAL OR HORIZONTAL LINE INDICATES NEXT CHARACTER
C NUMBERS IN PARENTHESES ARE THE VALUE OF KIND BEFORE
C AND AFTER ADJUSTING FOR THE SEPARATING CHARACTERS/-,
C
C
C 10(7) ------ / ----- 81(14)
C *
C *
C 20(3) ----- / ----- OCT(5/6) ----- / ----- 81(11/13)
C *
C *
C OCT(5) ----- , ----- 81(11/12)
C *
C *
C 81(11)
C
C
C 81(15)
C *
C *
C 20(8) ----- , ----- 81(15/16)
C *
C *
C OCT(4) ----- / ----- 20(8/9) ----- / ----- 81(15/17)
C *
C *
C , ----- 81(10)
C
C ISEPAR = 0, NO PRINTING SEPARATOR CHARACTERS FOUND
C = -1, COMMA FOUND
C = 1, SLASH FOUND
C = 2, MINUS SIGN FOUND
C
C ADJUST FOR THE SEPARATING CHARACTERS / - AND ,
46 IF(KIND.EQ.3)GO TO 51
IF(KIND.EQ.4)GO TO 53
IF(KIND.EQ.5)GO TO 47
IF(KIND.EQ.7)GO TO 55
IF(KIND.EQ.8)GO TO 48
IF(KIND.EQ.10)GO TO 56
IF(KIND.EQ.11)GO TO 49
IF(KIND.EQ.14)GO TO 58
IF(KIND.EQ.15)GO TO 50
GO TO 64
C CONVERT KIND=5
47 IF(ISEPAR.NE.0)KIND=6
GO TO 54
C CONVERT KIND=8
48 IF(ISEPAR.NE.0)KIND=9
GO TO 55
C CONVERT KIND=11
49 IF(ISEPAR.LT.0)KIND=12
IF(ISEPAR.GT.0)KIND=13
GO TO 57
C CONVERT KIND=15
50 IF(ISEPAR.LT.0)KIND=16
IF(ISEPAR.GT.0)KIND=17
GO TO 58
C
C YEAR
51 IF(IALLOW.EQ.2)GO TO 52
IYEAR=IFIRST
GO TO 64
52 IDAY=IFIRST
GO TO 64
C
C MONTH
53 IMONTH=IFIRST
GO TO 64
C
C DAY MONTH
54 IDAY=IFIRST
IMONTH=ISECON
GO TO 64
C
C MONTH DAY
55 IDAY=ISECON
IMONTH=IFIRST
GO TO 64
C
C MONTH YEAR
56 IMONTH=IFIRST
IYEAR=ITHIRD
GO TO 64
C
C DAY MONTH YEAR
57 IDAY=IFIRST
IMONTH=ISECON
IYEAR=ITHIRD
GO TO 64
C
C MONTH DAY YEAR
58 IDAY=ISECON
IMONTH=IFIRST
IYEAR=ITHIRD
GO TO 64
C
C AM OR PM
59 KIND=19
GO TO 63
C
C NUMBER AM
60 KIND=20
IDAY=IFIRST
GO TO 63
C
C NUMBER COLON AM
61 KIND=21
GO TO 63
C
C WEEKDAY
62 KIND=22
IDAY=IUNIQU-LMTSFX
GO TO 64
C
C HANDLE EQUIVALENT SUFFIXES
C A.M. = AM, P.M. = PM, M = NOON
63 IYEAR=IUNIQU-LMTMTH
IF(IYEAR.EQ.8)IYEAR=3
IF(IYEAR.GT.4)IYEAR=IYEAR-4
GO TO 64
C
C RETURN TO CALLING PROGRAM
64 LOWBFR=LSTBFR
65 RETURN
END
SUBROUTINE DAWEEK(IWHICH,ISMITH,IDAY,IMONTH,IYEAR,IWEEK)
C RENBR(/INTERCONVERT CONVENTIONAL AND SMITHSONIAN DATES)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C IWHICH = 0, 1, 2, 3, CONVERT DAY, MONTH AND YEAR INPUT
C IN IDAY, IMONTH AND IYEAR TO SMITHSONIAN DATE.
C = 3, CHECK CURRENT DAY, MONTH AND YEAR. RETURN
C THESE AS IDAY, IMONTH, IYEAR
C = 2, CHECK DAY, MONTH AND YEAR BEFORE COMPUTING
C SMITHSONIAN DATE. IF DAY IS MISSING (-1 OR 0)
C SET TO END OF MONTH. IF MONTH IS MISSING, SET
C TO DECEMBER. IF YEAR IS MISSING, SET TO CURRENT
C YEAR IF DAY IS TODAY OR LATER, OR ELSE TO NEXT
C YEAR. THE NEWDAT ROUTINE IS CALLED TO OBTAIN
C THE CURRENT DATE. NEWDAT RETURNS THE FOLLOWING
C INFORMATION AS INTEGER VALUES.
C 1ST ARGUMENT = DAY OF CURRENT MONTH
C 2ND ARGUMENT = MONTH OF CURRENT YEAR
C 3RD ARGUMENT = CURRENT YEAR, INCLUDING THE
C CENTURIAL AND MILLENNIAL DIGITS.
C = 1, SIMILAR TO IWHICH=2, EXCEPT THAT A MISSING
C DAY IS SET TO START OF MONTH AND MISSING MONTH
C IS SET TO JANUARY.
C = 0, DO NOT CHECK DAY, MONTH AND YEAR.
C = -1, CONVERT SMITHSONIAN DATE INPUT IN ISMITH
C TO DAY, MONTH AND YEAR.
C ISMITH = NUMBER OF DAYS SINCE 18 NOVEMBER 1858 TAKING
C THAT BASE DATE AS DAY 1.
C THIS ROUTINE DEFINES ISMITH IF IWHICH=0, 1 OR 2.
C ISMITH IS USED TO COMPUTE THE DAY, MONTH AND
C YEAR IF IWHICH=-1.
C IDAY = DAY OF MONTH. IDAY=1 IS FIRST DAY OF MONTH.
C IDAY, IMONTH AND IYEAR ARE USED TO COMPUTE
C THE SMITHSONIAN DATE IF IWHICH=0, 1 OR 2.
C THE SMITHSONIAN DATE IS USED TO COMPUTE
C IDAY, IMONTH AND IYEAR IF IWHICH=-1.
C IMONTH = SERIAL NUMBER OF MONTH IN YEAR, SUCH THAT
C 1=JANUARY AND 12=DECEMBER.
C IYEAR = YEAR. THIS CONTAINS ALL 4 DIGITS, NOT JUST
C THE RIGHT 2 DIGITS. FOR DATE 12-FEB-1980,
C IDAY=12
C IMONTH=2
C IYEAR=1980
C IWEEK = RETURNED CONTAINING THE DAY OF THE WEEK FOR
C THE REQUESTED DATE, SUCH THAT 1=SUNDAY AND
C 7=SATURDAY. IWEEK IS RETURNED SET BY THIS
C ROUTINE REGARDLESS OF THE VALUE OF IWHICH.
C
C NUMBER OF DAYS IN NONLEAP YEAR PRIOR TO EACH MONTH
DIMENSION LOCMTH(12)
DATA LOCMTH/0,31,59,90,120,151,181,212,243,273,304,
1334/
IF(IWHICH.LT.0)GO TO 14
IF(IWHICH.EQ.0)GO TO 12
C
C ************************************
C * *
C * CHECK DATE AND INSERT DEFAULTS *
C * *
C ************************************
C
C IWHICH = 2, FILL IN WITH LAST MONTH OF YEAR
C OR WITH LAST DAY OF MONTH
C = 1, FILL IN WITH FIRST MONTH OF YEAR
C OR WITH FIRST DAY OF MONTH
CALL NEWDAT(JDAY,JMONTH,JYEAR)
IF(IWHICH.LT.3)GO TO 1
IDAY=JDAY
IMONTH=JMONTH
IYEAR=JYEAR
GO TO 12
1 KDAY=0
IF(IYEAR.GE.0)GO TO 5
IF(IMONTH.LE.0)GO TO 3
IF(IMONTH.LT.JMONTH)GO TO 4
IF(IMONTH.GT.JMONTH)GO TO 3
IF(IDAY.GT.0)GO TO 2
KDAY=1
GO TO 3
2 IF(IDAY.LT.JDAY)GO TO 4
3 IYEAR=JYEAR
GO TO 5
4 IYEAR=JYEAR+1
5 IF(IYEAR.GE.100)GO TO 6
IYEAR=IYEAR+(100*(JYEAR/100))
IF(IYEAR.LT.JYEAR)IYEAR=IYEAR+100
6 IF(IMONTH.GT.0)GO TO 7
IMONTH=1
IF(IWHICH.EQ.2)IMONTH=12
7 IF(IMONTH.GT.12)IMONTH=12
LDAY=31
IF(IMONTH.LT.12)LDAY=LOCMTH(IMONTH+1)-LOCMTH(IMONTH)
IF(IMONTH.NE.2)GO TO 9
ILEAP=IYEAR/4
JLEAP=IYEAR/100
KLEAP=IYEAR/400
LLEAP=IYEAR/4000
IF(IYEAR.NE.(4*ILEAP))GO TO 9
IF(IYEAR.EQ.(4000*LLEAP))GO TO 9
IF(IYEAR.EQ.(400*KLEAP))GO TO 8
IF(IYEAR.EQ.(100*JLEAP))GO TO 9
8 LDAY=29
9 IF(IDAY.GT.0)GO TO 10
IDAY=1
IF(IWHICH.EQ.2)IDAY=LDAY
IF(KDAY.EQ.0)GO TO 10
IF(IDAY.LT.JDAY)IYEAR=IYEAR+1
10 IF(IDAY.GT.LDAY)IDAY=LDAY
IF(IYEAR.GT.1858)GO TO 12
IF(IYEAR.LT.1858)GO TO 11
IF(IMONTH.GT.11)GO TO 12
IF(IMONTH.LT.11)GO TO 11
IF(IDAY.GE.18)GO TO 12
11 IDAY=18
IMONTH=11
IYEAR=1858
C
C **************************************************
C * *
C * CONVERT DAY, MONTH, YEAR TO SMITHSONIAN DATE *
C * *
C **************************************************
C
C COMPUTE YEARS DIVISIBLE BY 4, 100, 400 AND 4000
12 ILEAP=IYEAR/4
JLEAP=IYEAR/100
KLEAP=IYEAR/400
LLEAP=IYEAR/4000
C
C COMPUTE DAYS SINCE END OF FIRST WEEK BEFORE BASE
C YEAR ASSUMING FOLLOWING RULES WERE ALWAYS APPLIED.
C 1. ANY YEAR DIVISIBLE BY 4 IS A LEAP YEAR EXCEPT
C CENTURIES NOT DIVISIBLE BY 400 ARE NOT LEAP YEARS
C MILLENNIUMS DIVISIBLE BY 4000 ARE NOT LEAP YEARS
C 2. ALL NONLEAP YEARS CONTAIN 365 DAYS AND ALL
C LEAP YEARS CONTAIN 366 DAYS.
C OFFSET OF 771 ADJUSTS FOR LEAP YEARS FROM YEAR ZERO
C TO BASE YEAR AND LENGTH OF FIRST WEEK IN BASE YEAR
ISMITH=(365*(IYEAR-1858))+ILEAP-JLEAP+KLEAP-LLEAP
1+LOCMTH(IMONTH)+IDAY-771
C
C SUBTRACT 1 IF THIS IS LEAP YEAR BUT NOT YET IN MARCH
IF(IYEAR.NE.(4*ILEAP))GO TO 24
IF(IYEAR.EQ.(4000*LLEAP))GO TO 24
IF(IYEAR.EQ.(400*KLEAP))GO TO 13
IF(IYEAR.EQ.(100*JLEAP))GO TO 24
13 IF(IMONTH.LE.2)ISMITH=ISMITH-1
GO TO 24
C
C **************************************************
C * *
C * CONVERT SMITHSONIAN DATE TO DAY, MONTH, YEAR *
C * *
C **************************************************
C
C DETERMINE YEAR IF NO YEARS WERE LEAP YEARS
14 IYEAR=1858+((ISMITH+321)/365)
C
C ADJUST YEAR BY NUMBER OF LEAP YEARS FROM YEAR 0
ILEAP=IYEAR/4
JLEAP=IYEAR/100
KLEAP=IYEAR/400
LLEAP=IYEAR/4000
JSMITH=ISMITH-ILEAP+JLEAP-KLEAP+LLEAP
IYEAR=1858+((JSMITH+770)/365)
C
C AT THIS POINT, THE YEAR IS CORRECT FOR ALL BUT
C THE 31ST OF DECEMBER OF A YEAR PRECEDING A LEAP YEAR
IYEAR=IYEAR+1
IF(IYEAR.NE.(4*ILEAP))GO TO 16
IF(IYEAR.EQ.(4000*LLEAP))GO TO 16
IF(IYEAR.EQ.(400*KLEAP))GO TO 15
IF(IYEAR.EQ.(100*JLEAP))GO TO 16
15 JSMITH=JSMITH+1
16 IYEAR=1858+((JSMITH+770)/365)
C
C DETERMINE THE LOCATION OF THE DAY WITHIN THE YEAR
C INYEAR = 1 THROUGH 365 IF YEAR IS NOT LEAP YEAR.
C = 0 THROUGH 365 IF YEAR IS LEAP YEAR.
ILEAP=IYEAR/4
JLEAP=IYEAR/100
KLEAP=IYEAR/400
LLEAP=IYEAR/4000
INYEAR=ISMITH-(365*(IYEAR-1858))
1-ILEAP+JLEAP-KLEAP+LLEAP+771
IF(IYEAR.NE.(4*ILEAP))GO TO 21
IF(IYEAR.EQ.(4000*LLEAP))GO TO 21
IF(IYEAR.EQ.(400*KLEAP))GO TO 17
IF(IYEAR.EQ.(100*JLEAP))GO TO 21
C
C CONVERT DAY IN LEAP YEAR TO MONTH AND DAY IN MONTH
17 IMONTH=0
18 IMONTH=IMONTH+1
IF(IMONTH.GT.12)GO TO 20
IF(IMONTH.GT.2)GO TO 19
IF(INYEAR.GE.LOCMTH(IMONTH))GO TO 18
GO TO 20
19 IF(INYEAR.GT.LOCMTH(IMONTH))GO TO 18
20 IMONTH=IMONTH-1
IDAY=INYEAR-LOCMTH(IMONTH)
IF(IMONTH.LE.2)IDAY=IDAY+1
GO TO 24
C
C CONVERT DAY NOT IN LEAP YEAR TO MONTH AND DAY
21 IMONTH=0
22 IMONTH=IMONTH+1
IF(IMONTH.GT.12)GO TO 23
IF(INYEAR.GT.LOCMTH(IMONTH))GO TO 22
23 IMONTH=IMONTH-1
IDAY=INYEAR-LOCMTH(IMONTH)
C
C CONVERT SMITHSONIAN DATE TO DAY OF WEEK
24 JSMITH=ISMITH+3
IWEEK=JSMITH/7
IWEEK=JSMITH-(7*IWEEK)+1
25 RETURN
END
SUBROUTINE NEWDAT(IDAY,IMONTH,IYEAR)
DOUBLE PRECISION LTRDAT
DIMENSION NAMMTH(12)
DATA NAMMTH/'Jan','Feb','Mar','Apr','May','Jun',
1'Jul','Aug','Sep','Oct','Nov','Dec'/
CALL DATE(LTRDAT)
DECODE(9,1,LTRDAT)IDAY,LTRMTH,IYEAR
1 FORMAT(I2,1X,A3,1X,I2)
IYEAR=IYEAR+1900
DO 2 I=1,12
IF(LTRMTH.NE.NAMMTH(I))GO TO 2
IMONTH=I
GO TO 3
2 CONTINUE
IMONTH=0
3 RETURN
END
SUBROUTINE TTYSIM(IDISK)
C RENBR(/REPLACE FIRST CHARACTERS BY CARRIAGE CONTROLS)
C
C ***************************
C * *
C * THIS IS A DUMMY ROUTINE *
C * *
C ***************************
C
C THE ASSEMBLY VERSION OF THIS ROUTINE CAUSES THE FIRST
C CHARACTER ON EACH LINE OF THE NEXT FILE WRITTEN ONTO
C UNIT IDISK TO BE CONVERTED DIRECTLY TO THE CARRIAGE
C CONTROL CHARACTER GIVING THE PROPER LINE SPACING.
C
C THIS IS NO LONGER NEEDED IN VERSION 7 OF FORTRAN ON
C THE DECSYSTEM10 OR DECSYSTEM20 SINCE IT HAS BEEN
C REPLACED BY CARRIAGECONTROL='FORTRAN' IN THE OPEN
C STATEMENTS OF THE FILES NEEDING THIS CONVERSION.
C
RETURN
END